1 ;;; --------------------------------------------------------------------------
2 ;;; CLFSWM - FullScreen Window Manager
4 ;;; --------------------------------------------------------------------------
5 ;;; Documentation: Wallpaper utilities
6 ;;; --------------------------------------------------------------------------
8 ;;; (C) 2015 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 (do-shell-output "~A" command
)))
73 (defun create-wallpaper (filename &rest images
)
74 (format t
"Creating wallpaper ~A from ~{~A ~}~%" filename images
)
75 (generate-wallpaper filename
(x-drawable-width *root
*) (x-drawable-height *root
*)
76 (or (get-connected-heads-size)
77 `((0 0 ,(x-drawable-width *root
*) ,(x-drawable-height *root
*))))
82 (defun use-wallpaper (filename)
83 (when (probe-file filename
)
84 (format t
"Using wallpaper ~A~%" filename
)
85 (do-shell (format nil
"~A ~A" *wallpaper-command
* filename
) nil t
)
86 (format t
"Done.~%")))
90 (defun wallpaper-name (basename)
91 (let ((sizes (or (get-connected-heads-size)
92 `((0 0 ,(x-drawable-width *root
*) ,(x-drawable-height *root
*)))))
96 (incf count
(+ v count
))))
97 (format nil
"~A-~A.png" basename count
)))
99 (defun wallpaper (basename force-create
&rest images
)
100 (let* ((filename (wallpaper-name basename
)))
101 (when (or force-create
(not (probe-file filename
)))
102 (open-notify-window '(" " " " " Please wait. Updating wallpaper... " " " " "))
103 (apply #'create-wallpaper filename images
)
104 (close-notify-window))
105 (use-wallpaper filename
)))