contrib/toolbar.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Toolbar
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2011 Philippe Brochard <hocwp@free.fr>
   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 "toolbar.lisp")
  28 ;;;
  29 ;;; --------------------------------------------------------------------------
  30
  31 (in-package :clfswm)
  32
  33 (format t "Loading Toolbar code... ")
  34
  35 (defstruct toolbar root-x root-y root direction size thickness placement refresh-delay
  36            autohide modules font window gc border-size)
  37
  38 (defparameter *toolbar-list* nil)
  39 (defparameter *toolbar-module-list* nil)
  40
  41 ;;; CONFIG - Toolbar window string colors
  42 (defconfig *toolbar-window-font-string* *default-font-string*
  43   'Toolbar "Toolbar window font string")
  44 (defconfig *toolbar-window-background* "black"
  45   'Toolbar "Toolbar Window background color")
  46 (defconfig *toolbar-window-foreground* "green"
  47   'Toolbar "Toolbar Window foreground color")
  48 (defconfig *toolbar-window-border* "red"
  49   'Toolbar "Toolbar Window border color")
  50 (defconfig *toolbar-default-border-size* 0
  51   'Toolbar "Toolbar Window border size")
  52 (defconfig *toolbar-window-transparency* *default-transparency*
  53   'Toolbar "Toolbar window background transparency")
  54 (defconfig *toolbar-default-thickness* 20
  55   'Toolbar "Toolbar default thickness")
  56 (defconfig *toolbar-default-refresh-delay* 30
  57   'Toolbar "Toolbar default refresh delay")
  58 (defconfig *toolbar-default-autohide* nil
  59   'Toolbar "Toolbar default autohide value")
  60
  61 (defconfig *toolbar-window-placement* 'top-left-placement
  62   'Placement "Toolbar window placement")
  63
  64 (defun toolbar-symbol-fun (name)
  65   (create-symbol 'toolbar- name '-module))
  66
  67 (defun toolbar-adjust-root-size (toolbar)
  68   (unless (toolbar-autohide toolbar)
  69     (let ((root (toolbar-root toolbar))
  70           (placement-name (symbol-name (toolbar-placement toolbar)))
  71           (thickness (+ (toolbar-thickness toolbar) (* 2 (toolbar-border-size toolbar)))))
  72       (when (root-p root)
  73         (case (toolbar-direction toolbar)
  74           (:horiz (cond ((search "TOP" placement-name)
  75                          (incf (root-y root) thickness)
  76                          (decf (root-h root) thickness))
  77                         ((search "BOTTOM" placement-name)
  78                          (decf (root-h root) thickness))))
  79           (t (cond ((search "LEFT" placement-name)
  80                     (incf (root-x root) thickness)
  81                     (decf (root-w root) thickness))
  82                    ((search "RIGHT" placement-name)
  83                     (decf (root-w root) thickness)))))))))
  84
  85
  86 (defun toolbar-draw-text (toolbar pos1 pos2 text)
  87   "pos1: percent, pos2: pixels"
  88   (labels ((horiz-text ()
  89              (let* ((height (- (xlib:font-ascent (toolbar-font toolbar)) (xlib:font-descent (toolbar-font toolbar))))
  90                     (dy (truncate (+ pos2 (/ height 2))))
  91                     (width (xlib:text-width (toolbar-font toolbar) text))
  92                     (pos (truncate (/ (* (- (xlib:drawable-width (toolbar-window toolbar)) width) pos1) 100))))
  93                (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) pos dy text)))
  94            (vert-text ()
  95              (let* ((width (xlib:max-char-width (toolbar-font toolbar)))
  96                     (dx (truncate (- pos2 (/ width 2))))
  97                     (dpos (xlib:max-char-ascent (toolbar-font toolbar)))
  98                     (height (* dpos (length text)))
  99                     (pos (+ (truncate (/ (* (- (xlib:drawable-height (toolbar-window toolbar)) height
 100                                                (xlib:max-char-descent (toolbar-font toolbar)))
 101                                             pos1) 100))
 102                             (xlib:font-ascent (toolbar-font toolbar)))))
 103                (loop for c across text
 104                   do (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) dx pos (string c))
 105                     (incf pos dpos)))))
 106     (case (toolbar-direction toolbar)
 107       (:horiz (horiz-text))
 108       (:vert (vert-text)))))
 109
 110
 111
 112 (defun refresh-toolbar (toolbar)
 113   (add-timer (toolbar-refresh-delay toolbar)
 114              (lambda ()
 115                (refresh-toolbar toolbar))
 116              :refresh-toolbar)
 117   (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
 118   (dolist (module (toolbar-modules toolbar))
 119     (let ((fun (toolbar-symbol-fun (first module))))
 120       (when (fboundp fun)
 121         (funcall fun toolbar module))))
 122   (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))
 123
 124
 125 (create-event-hook :exposure)
 126
 127 (defun define-toolbar-hooks (toolbar)
 128   (define-event-hook :exposure (window)
 129     (when (and (xlib:window-p window) (xlib:window-equal (toolbar-window toolbar) window))
 130       (refresh-toolbar toolbar))))
 131
 132
 133
 134
 135 (let ((windows-list nil))
 136   (defun is-toolbar-window-p (win)
 137     (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal)))
 138
 139   (defun close-toolbar (toolbar)
 140     (erase-timer :refresh-toolbar-window)
 141     (setf *never-managed-window-list*
 142           (remove (list #'is-toolbar-window-p nil)
 143                   *never-managed-window-list* :test #'equal))
 144     (awhen (toolbar-gc toolbar)
 145       (xlib:free-gcontext it))
 146     (awhen (toolbar-window toolbar)
 147       (xlib:destroy-window it))
 148     (awhen (toolbar-font toolbar)
 149       (xlib:close-font it))
 150     (xlib:display-finish-output *display*)
 151     (setf (toolbar-window toolbar) nil
 152           (toolbar-gc toolbar) nil
 153           (toolbar-font toolbar) nil))
 154
 155   (defun open-toolbar (toolbar)
 156     (let ((root (find-root-by-coordinates (toolbar-root-x toolbar) (toolbar-root-y toolbar))))
 157       (when (root-p root)
 158         (setf (toolbar-root toolbar) root)
 159         (let ((*get-current-root-fun* (lambda () root)))
 160           (setf (toolbar-font toolbar) (xlib:open-font *display* *toolbar-window-font-string*))
 161           (let* ((width (if (equal (toolbar-direction toolbar) :horiz)
 162                             (round (/ (* (root-w root) (toolbar-size toolbar)) 100))
 163                             (toolbar-thickness toolbar)))
 164                  (height (if (equal (toolbar-direction toolbar) :horiz)
 165                              (toolbar-thickness toolbar)
 166                              (round (/ (* (root-h root) (toolbar-size toolbar)) 100)))))
 167             (with-placement ((toolbar-placement toolbar) x y width height (toolbar-border-size toolbar))
 168               (setf (toolbar-window toolbar) (xlib:create-window :parent *root*
 169                                                                  :x x
 170                                                                  :y y
 171                                                                  :width width
 172                                                                  :height height
 173                                                                  :background (get-color *toolbar-window-background*)
 174                                                                  :border-width (toolbar-border-size toolbar)
 175                                                                  :border (when (plusp (toolbar-border-size toolbar))
 176                                                                            (get-color *toolbar-window-border*))
 177                                                                  :colormap (xlib:screen-default-colormap *screen*)
 178                                                                  :event-mask '(:exposure :key-press))
 179                     (toolbar-gc toolbar) (xlib:create-gcontext :drawable (toolbar-window toolbar)
 180                                                                :foreground (get-color *toolbar-window-foreground*)
 181                                                                :background (get-color *toolbar-window-background*)
 182                                                                :font (toolbar-font toolbar)
 183                                                                :line-style :solid))
 184               (push (toolbar-window toolbar) windows-list)
 185               (setf (window-transparency (toolbar-window toolbar)) *toolbar-window-transparency*)
 186               (push (list #'is-toolbar-window-p nil) *never-managed-window-list*)
 187               (map-window (toolbar-window toolbar))
 188               (raise-window (toolbar-window toolbar))
 189               (refresh-toolbar toolbar)
 190               (xlib:display-finish-output *display*)
 191               (define-toolbar-hooks toolbar))))))))
 192
 193 (defun open-all-toolbars ()
 194   "Open all toolbars"
 195   (dolist (toolbar *toolbar-list*)
 196     (open-toolbar toolbar))
 197   (dolist (toolbar *toolbar-list*)
 198     (toolbar-adjust-root-size toolbar)))
 199
 200 (defun close-all-toolbars ()
 201   (dolist (toolbar *toolbar-list*)
 202     (close-toolbar toolbar)))
 203
 204
 205 (defun add-toolbar (root-x root-y direction size placement &rest modules)
 206   "Add a new toolbar.
 207      root-x, root-y: root coordinates
 208      direction: one of :horiz or :vert
 209      size: toolbar size in percent of root size"
 210   (let ((toolbar (make-toolbar :root-x root-x :root-y root-y
 211                       :direction direction :size size
 212                       :thickness *toolbar-default-thickness*
 213                       :placement placement
 214                       :autohide *toolbar-default-autohide*
 215                       :refresh-delay *toolbar-default-refresh-delay*
 216                       :border-size *toolbar-default-border-size*
 217                       :modules modules)))
 218     (push toolbar *toolbar-list*)
 219     toolbar))
 220
 221
 222 (add-hook *init-hook* 'open-all-toolbars)
 223 (add-hook *close-hook* 'close-all-toolbars)
 224
 225
 226 (defmacro define-toolbar-module ((name) &body body)
 227   (let ((symbol-fun (toolbar-symbol-fun name)))
 228     `(progn
 229        (pushnew ',name *toolbar-module-list*)
 230        (defun ,symbol-fun (toolbar module)
 231          ,@body))))
 232
 233
 234
 235 (define-toolbar-module (clock)
 236   "The clock module"
 237   (multiple-value-bind (s m h)
 238       (get-decoded-time)
 239     (declare (ignore s))
 240     (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
 241                        (format nil "~2,'0D:~2,'0D" h m))))
 242
 243
 244 (define-toolbar-module (label)
 245   "The label module"
 246   (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
 247                      "Label"))
 248
 249
 250 (format t "done~%")