contrib/wallpaper.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Wallpaper utilities
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   9 ;;;
  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.
  14 ;;;
  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.
  19 ;;;
  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.
  23 ;;;
  24 ;;; Documentation: If you want to use this file, just add this line in
  25 ;;; your configuration file:
  26 ;;;
  27 ;;;   (load-contrib "wallpaper.lisp")
  28 ;;;
  29 ;;; Note: You need the 'convert' program from the ImageMagick package and the
  30 ;;;   'Esetroot' program. But you can change this last one.
  31 ;;;
  32 ;;; Usage example:
  33 ;;;
  34 ;;;  (defun my-wallpaper ()
  35 ;;;    (wallpaper "/home/you/.background-full" nil
  36 ;;;               "background-1.png"
  37 ;;;               "background-2.png"))
  38 ;;;
  39 ;;;  (add-hook *init-hook* 'my-wallpaper)
  40 ;;;
  41 ;;; You can have more screen heads than wallpaper images listed in the
  42 ;;; wallpaper function.
  43 ;;;
  44 ;;; You can force the wallpaper creation by replacing the nil value after the
  45 ;;; wallpaper basename with a true (t) value.
  46 ;;; --------------------------------------------------------------------------
  47
  48 (in-package :clfswm)
  49
  50 (format t "Loading Wallpaper code... ")
  51
  52
  53 (defconfig *wallpaper-command* "Esetroot -scale"
  54   'Wallpaper "Command to install the wallpaper")
  55
  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
  58
  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)
  62                    (let ((ind 0)
  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)))
  71
  72
  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*))))
  78                       images)
  79   (format t "Done.~%"))
  80
  81
  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.~%")))
  87
  88
  89
  90 (defun wallpaper-name (basename)
  91   (let ((sizes (or (get-connected-heads-size)
  92                    `((0 0 ,(x-drawable-width *root*) ,(x-drawable-height *root*)))))
  93         (count 0))
  94     (dolist (s sizes)
  95       (dolist (v s)
  96         (incf count (+ v count))))
  97     (format nil "~A-~A.png" basename count)))
  98
  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)))
 106
 107 ;;;
 108 ;;; End of code
 109 ;;;
 110 (format t "done~%")
 111
 112