1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Wallpaper utilities
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
10 ;;; This program is free software; you can redistribute it and/or modify
11 ;;; it under the terms of the GNU General Public License as published by
12 ;;; the Free Software Foundation; either version 3 of the License, or
13 ;;; (at your option) any later version.
15 ;;; This program is distributed in the hope that it will be useful,
16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;;; GNU General Public License for more details.
20 ;;; You should have received a copy of the GNU General Public License
21 ;;; along with this program; if not, write to the Free Software
22 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
24 ;;; Documentation: If you want to use this file, just add this line in
25 ;;; your configuration file:
27 ;;; (load-contrib "wallpaper.lisp")
29 ;;; Note: You need the 'convert' program from the ImageMagick package and the
30 ;;; 'Esetroot' program. But you can change this last one.
34 ;;; (defun my-wallpaper ()
35 ;;; (wallpaper "/home/you/.background-full" nil
36 ;;; "background-1.png"
37 ;;; "background-2.png"))
39 ;;; (add-hook *init-hook* 'my-wallpaper)
41 ;;; You can have more screen heads than wallpaper images listed in the
42 ;;; wallpaper function.
44 ;;; You can force the wallpaper creation by replacing the nil value after the
45 ;;; wallpaper basename with a true (t) value.
46 ;;; --------------------------------------------------------------------------
50 (format t
"Loading Wallpaper code... ")
53 (defconfig *wallpaper-command
* "Esetroot -scale"
54 'Wallpaper
"Command to install the wallpaper")
56 ;;; Example of generated line
57 ;;; convert -size 1000x1000 xc:skyblue background.png -geometry 700x600+150+10! -composite Tux_Wallpaper_by_Narcoblix.png -geometry 500x300+100+620! -composite composite.png
59 (defun generate-wallpaper (filename width height root-list image-filename-list
&optional
(background "black"))
60 (let ((command (with-output-to-string (str)
61 (format str
"convert -size ~Ax~A xc:~A " width height background
)
63 (len (1- (length image-filename-list
))))
64 (dolist (root root-list
)
65 (format str
"~A -geometry ~Ax~A+~A+~A! -composite " (nth ind image-filename-list
)
66 (third root
) (fourth root
) (first root
) (second root
))
67 (setf ind
(if (< ind len
) (1+ ind
) 0))))
68 (format str
"~A" filename
))))
69 (format t
"~A~%" command
)
70 (let ((output (do-shell command nil t
)))
71 (loop for line
= (read-line output nil nil
)
73 do
(format t
"~A~%" line
)))))
75 (defun create-wallpaper (filename &rest images
)
76 (format t
"Creating wallpaper ~A from ~{~A ~}~%" filename images
)
77 (generate-wallpaper filename
(x-drawable-width *root
*) (x-drawable-height *root
*)
78 (or (get-connected-heads-size)
79 `((0 0 ,(x-drawable-width *root
*) ,(x-drawable-height *root
*))))
84 (defun use-wallpaper (filename)
85 (when (probe-file filename
)
86 (format t
"Using wallpaper ~A~%" filename
)
87 (do-shell (format nil
"~A ~A" *wallpaper-command
* filename
) nil t
)
88 (format t
"Done.~%")))
92 (defun wallpaper-name (basename)
93 (let ((sizes (or (get-connected-heads-size)
94 `((0 0 ,(x-drawable-width *root
*) ,(x-drawable-height *root
*)))))
98 (incf count
(+ v count
))))
99 (format nil
"~A-~A.png" basename count
)))
101 (defun wallpaper (basename force-create
&rest images
)
102 (let* ((filename (wallpaper-name basename
)))
103 (when (or force-create
(not (probe-file filename
)))
104 (open-notify-window '(" " " " " Please wait. Updating wallpaper... " " " " "))
105 (apply #'create-wallpaper filename images
)
106 (close-notify-window))
107 (use-wallpaper filename
)))