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 clickable 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 (defconfig *toolbar-sensibility* 10
  61   'Toolbar "Toolbar sensibility in pixels")
  62
  63 (defconfig *toolbar-window-placement* 'top-left-placement
  64   'Placement "Toolbar window placement")
  65
  66 (defun toolbar-symbol-fun (name)
  67   (create-symbol 'toolbar- name '-module))
  68
  69 (defun toolbar-adjust-root-size (toolbar)
  70   (unless (toolbar-autohide toolbar)
  71     (let ((root (toolbar-root toolbar))
  72           (placement-name (symbol-name (toolbar-placement toolbar)))
  73           (thickness (+ (toolbar-thickness toolbar) (* 2 (toolbar-border-size toolbar)))))
  74       (when (root-p root)
  75         (case (toolbar-direction toolbar)
  76           (:horiz (cond ((search "TOP" placement-name)
  77                          (incf (root-y root) thickness)
  78                          (decf (root-h root) thickness))
  79                         ((search "BOTTOM" placement-name)
  80                          (decf (root-h root) thickness))))
  81           (t (cond ((search "LEFT" placement-name)
  82                     (incf (root-x root) thickness)
  83                     (decf (root-w root) thickness))
  84                    ((search "RIGHT" placement-name)
  85                     (decf (root-w root) thickness)))))))))
  86
  87
  88 (defun toolbar-draw-text (toolbar pos1 pos2 text)
  89   "pos1: percent, pos2: pixels"
  90   (labels ((horiz-text ()
  91              (let* ((height (- (xlib:font-ascent (toolbar-font toolbar)) (xlib:font-descent (toolbar-font toolbar))))
  92                     (dy (truncate (+ pos2 (/ height 2))))
  93                     (width (xlib:text-width (toolbar-font toolbar) text))
  94                     (pos (truncate (/ (* (- (xlib:drawable-width (toolbar-window toolbar)) width) pos1) 100))))
  95                (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) pos dy text)))
  96            (vert-text ()
  97              (let* ((width (xlib:max-char-width (toolbar-font toolbar)))
  98                     (dx (truncate (- pos2 (/ width 2))))
  99                     (dpos (xlib:max-char-ascent (toolbar-font toolbar)))
 100                     (height (* dpos (length text)))
 101                     (pos (+ (truncate (/ (* (- (xlib:drawable-height (toolbar-window toolbar)) height
 102                                                (xlib:max-char-descent (toolbar-font toolbar)))
 103                                             pos1) 100))
 104                             (xlib:font-ascent (toolbar-font toolbar)))))
 105                (loop for c across text
 106                   do (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) dx pos (string c))
 107                     (incf pos dpos)))))
 108     (case (toolbar-direction toolbar)
 109       (:horiz (horiz-text))
 110       (:vert (vert-text)))))
 111
 112
 113
 114 (defun refresh-toolbar (toolbar)
 115   (add-timer (toolbar-refresh-delay toolbar)
 116              (lambda ()
 117                (refresh-toolbar toolbar))
 118              :refresh-toolbar)
 119   (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
 120   (dolist (module (toolbar-modules toolbar))
 121     (let ((fun (toolbar-symbol-fun (first module))))
 122       (when (fboundp fun)
 123         (funcall fun toolbar module))))
 124   (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))
 125
 126 (defun toolbar-in-sensibility-zone-p (toolbar root-x root-y)
 127   (let* ((tb-win (toolbar-window toolbar))
 128          (win-x (xlib:drawable-x tb-win))
 129          (win-y (xlib:drawable-y tb-win))
 130          (width (xlib:drawable-width tb-win))
 131          (height (xlib:drawable-height tb-win))
 132          (tb-dir (toolbar-direction toolbar) )
 133          (placement-name (symbol-name (toolbar-placement toolbar))))
 134     (or (and (equal tb-dir :horiz) (search "TOP" placement-name)
 135              (<= root-y win-y (+ root-y *toolbar-sensibility*))
 136              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
 137         (and (equal tb-dir :horiz) (search "BOTTOM" placement-name)
 138              (<= (+ win-y height (- *toolbar-sensibility*)) root-y (+ win-y height))
 139              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
 140         (and (equal tb-dir :vert) (search "LEFT" placement-name)
 141              (<= root-x win-x (+ root-x *toolbar-sensibility*))
 142              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar))
 143         (and (equal tb-dir :vert) (search "RIGHT" placement-name)
 144              (<= (+ win-x width (- *toolbar-sensibility*)) root-x (+ win-x width))
 145              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar)))))
 146
 147 (use-event-hook :exposure)
 148 (use-event-hook :button-press)
 149 (use-event-hook :motion-notify)
 150 (use-event-hook :leave-notify)
 151
 152
 153 (defun toolbar-add-exposure-hook (toolbar)
 154   (define-event-hook :exposure (window)
 155     (when (and (xlib:window-p window) (xlib:window-equal (toolbar-window toolbar) window))
 156       (refresh-toolbar toolbar))))
 157
 158 (defun toolbar-add-hide-button-press-hook (toolbar)
 159   (let ((hide t))
 160     (define-event-hook :button-press (code root-x root-y)
 161       (when (= code 1)
 162         (let* ((tb-win (toolbar-window toolbar)))
 163           (when (toolbar-in-sensibility-zone-p toolbar root-x root-y)
 164             (if hide
 165                 (progn
 166                   (map-window tb-win)
 167                   (raise-window tb-win)
 168                   (refresh-toolbar toolbar))
 169                 (hide-window tb-win))
 170             (setf hide (not hide))
 171             (wait-mouse-button-release)
 172             (stop-button-event)
 173             (throw 'exit-handle-event nil)))))))
 174
 175 (defun toolbar-add-hide-motion-hook (toolbar)
 176   (define-event-hook :motion-notify (root-x root-y)
 177     (unless (compress-motion-notify)
 178       (when (toolbar-in-sensibility-zone-p toolbar root-x root-y)
 179         (map-window (toolbar-window toolbar))
 180         (raise-window (toolbar-window toolbar))
 181         (refresh-toolbar toolbar)
 182         (throw 'exit-handle-event nil)))))
 183
 184 (defun toolbar-add-hide-leave-hook (toolbar)
 185   (define-event-hook :leave-notify (window root-x root-y)
 186     (when (and (xlib:window-equal (toolbar-window toolbar) window)
 187                (not (in-window (toolbar-window toolbar) root-x root-y)))
 188       (hide-window window)
 189       (throw 'exit-handle-event nil))))
 190
 191 (defun define-toolbar-hooks (toolbar)
 192   (toolbar-add-exposure-hook toolbar)
 193   (when (toolbar-clickable toolbar)
 194     (define-event-hook :button-press (code root-x root-y)
 195       (dbg code root-x root-y)))
 196   (case (toolbar-autohide toolbar)
 197     (:click (toolbar-add-hide-button-press-hook toolbar))
 198     (:motion (toolbar-add-hide-motion-hook toolbar)
 199              (toolbar-add-hide-leave-hook toolbar))))
 200
 201 (defun set-clickable-toolbar (toolbar)
 202   (dolist (module *toolbar-module-list*)
 203     (when (and (member (first module) (toolbar-modules toolbar)
 204                        :test (lambda (x y) (equal x (first y))))
 205                (second module))
 206       (setf (toolbar-clickable toolbar) t))))
 207
 208
 209
 210
 211 (let ((windows-list nil))
 212   (defun is-toolbar-window-p (win)
 213     (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal)))
 214
 215   (defun close-toolbar (toolbar)
 216     (erase-timer :refresh-toolbar-window)
 217     (setf *never-managed-window-list*
 218           (remove (list #'is-toolbar-window-p nil)
 219                   *never-managed-window-list* :test #'equal))
 220     (awhen (toolbar-gc toolbar)
 221       (xlib:free-gcontext it))
 222     (awhen (toolbar-window toolbar)
 223       (xlib:destroy-window it))
 224     (awhen (toolbar-font toolbar)
 225       (xlib:close-font it))
 226     (xlib:display-finish-output *display*)
 227     (setf (toolbar-window toolbar) nil
 228           (toolbar-gc toolbar) nil
 229           (toolbar-font toolbar) nil))
 230
 231   (defun open-toolbar (toolbar)
 232     (let ((root (find-root-by-coordinates (toolbar-root-x toolbar) (toolbar-root-y toolbar))))
 233       (when (root-p root)
 234         (setf (toolbar-root toolbar) root)
 235         (let ((*get-current-root-fun* (lambda () root)))
 236           (setf (toolbar-font toolbar) (xlib:open-font *display* *toolbar-window-font-string*))
 237           (let* ((width (if (equal (toolbar-direction toolbar) :horiz)
 238                             (round (/ (* (root-w root) (toolbar-size toolbar)) 100))
 239                             (toolbar-thickness toolbar)))
 240                  (height (if (equal (toolbar-direction toolbar) :horiz)
 241                              (toolbar-thickness toolbar)
 242                              (round (/ (* (root-h root) (toolbar-size toolbar)) 100)))))
 243             (with-placement ((toolbar-placement toolbar) x y width height (toolbar-border-size toolbar))
 244               (setf (toolbar-window toolbar) (xlib:create-window :parent *root*
 245                                                                  :x x
 246                                                                  :y y
 247                                                                  :width width
 248                                                                  :height height
 249                                                                  :background (get-color *toolbar-window-background*)
 250                                                                  :border-width (toolbar-border-size toolbar)
 251                                                                  :border (when (plusp (toolbar-border-size toolbar))
 252                                                                            (get-color *toolbar-window-border*))
 253                                                                  :colormap (xlib:screen-default-colormap *screen*)
 254                                                                  :event-mask '(:exposure :key-press :leave-window))
 255                     (toolbar-gc toolbar) (xlib:create-gcontext :drawable (toolbar-window toolbar)
 256                                                                :foreground (get-color *toolbar-window-foreground*)
 257                                                                :background (get-color *toolbar-window-background*)
 258                                                                :font (toolbar-font toolbar)
 259                                                                :line-style :solid))
 260               (push (toolbar-window toolbar) windows-list)
 261               (setf (window-transparency (toolbar-window toolbar)) *toolbar-window-transparency*)
 262               (push (list #'is-toolbar-window-p nil) *never-managed-window-list*)
 263               (map-window (toolbar-window toolbar))
 264               (raise-window (toolbar-window toolbar))
 265               (refresh-toolbar toolbar)
 266               (when (toolbar-autohide toolbar)
 267                 (hide-window (toolbar-window toolbar)))
 268               (xlib:display-finish-output *display*)
 269               (set-clickable-toolbar toolbar)
 270               (define-toolbar-hooks toolbar))))))))
 271
 272 (defun open-all-toolbars ()
 273   "Open all toolbars"
 274   (dolist (toolbar *toolbar-list*)
 275     (open-toolbar toolbar))
 276   (dolist (toolbar *toolbar-list*)
 277     (toolbar-adjust-root-size toolbar)))
 278
 279 (defun close-all-toolbars ()
 280   (dolist (toolbar *toolbar-list*)
 281     (close-toolbar toolbar)))
 282
 283
 284 (defun add-toolbar (root-x root-y direction size placement modules
 285                     &key (autohide *toolbar-default-autohide*))
 286   "Add a new toolbar.
 287      root-x, root-y: root coordinates
 288      direction: one of :horiz or :vert
 289      size: toolbar size in percent of root size"
 290   (let ((toolbar (make-toolbar :root-x root-x :root-y root-y
 291                       :direction direction :size size
 292                       :thickness *toolbar-default-thickness*
 293                       :placement placement
 294                       :autohide autohide
 295                       :refresh-delay *toolbar-default-refresh-delay*
 296                       :border-size *toolbar-default-border-size*
 297                       :modules modules)))
 298     (push toolbar *toolbar-list*)
 299     toolbar))
 300
 301
 302 (add-hook *init-hook* 'open-all-toolbars)
 303 (add-hook *close-hook* 'close-all-toolbars)
 304
 305
 306 (defmacro define-toolbar-module ((name &optional clickable) &body body)
 307   (let ((symbol-fun (toolbar-symbol-fun name)))
 308     `(progn
 309        (pushnew (list ',name ,clickable) *toolbar-module-list*)
 310        (defun ,symbol-fun (toolbar module)
 311          ,@body))))
 312
 313
 314
 315
 316 ;;;
 317 ;;; Modules definitions
 318 ;;;
 319 (define-toolbar-module (clock)
 320   "The clock module"
 321   (multiple-value-bind (s m h)
 322       (get-decoded-time)
 323     (declare (ignore s))
 324     (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
 325                        (format nil "~2,'0D:~2,'0D" h m))))
 326
 327
 328 (define-toolbar-module (label)
 329   "The label module"
 330   (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
 331                      "Label"))
 332
 333
 334 (define-toolbar-module (clickable-clock t)
 335   "The clock module (clickable)"
 336   (multiple-value-bind (s m h)
 337       (get-decoded-time)
 338     (declare (ignore s))
 339     (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
 340                        (format nil "Click:~2,'0D:~2,'0D" h m))))
 341
 342
 343 (format t "done~%")