contrib/toolbar.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Toolbar
   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 "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 hide-state font window gc border-size)
  37
  38 (defstruct toolbar-module name pos display-fun click-fun rect)
  39
  40 (defparameter *toolbar-list* nil)
  41 (defparameter *toolbar-module-list* nil)
  42
  43 ;;; CONFIG - Toolbar window string colors
  44 (defconfig *toolbar-window-font-string* *default-font-string*
  45   'Toolbar "Toolbar window font string")
  46 (defconfig *toolbar-window-background* "black"
  47   'Toolbar "Toolbar Window background color")
  48 (defconfig *toolbar-window-foreground* "green"
  49   'Toolbar "Toolbar Window foreground color")
  50 (defconfig *toolbar-window-border* "red"
  51   'Toolbar "Toolbar Window border color")
  52 (defconfig *toolbar-default-border-size* 0
  53   'Toolbar "Toolbar Window border size")
  54 (defconfig *toolbar-window-transparency* *default-transparency*
  55   'Toolbar "Toolbar window background transparency")
  56 (defconfig *toolbar-default-thickness* 20
  57   'Toolbar "Toolbar default thickness")
  58 (defconfig *toolbar-default-refresh-delay* 30
  59   'Toolbar "Toolbar default refresh delay")
  60 (defconfig *toolbar-default-autohide* nil
  61   'Toolbar "Toolbar default autohide value")
  62 (defconfig *toolbar-sensibility* 3
  63   'Toolbar "Toolbar sensibility in pixels")
  64
  65 (defconfig *toolbar-window-placement* 'top-left-placement
  66   'Placement "Toolbar window placement")
  67
  68 (defun toolbar-symbol-fun (name &optional (type 'display))
  69   (create-symbol 'toolbar- name '-module- type))
  70
  71 (defun toolbar-adjust-root-size (toolbar)
  72   (unless (toolbar-autohide toolbar)
  73     (let ((root (toolbar-root toolbar))
  74           (placement-name (symbol-name (toolbar-placement toolbar)))
  75           (thickness (+ (toolbar-thickness toolbar) (* 2 (toolbar-border-size toolbar)))))
  76       (when (root-p root)
  77         (case (toolbar-direction toolbar)
  78           (:horiz (cond ((search "TOP" placement-name)
  79                          (incf (root-y root) thickness)
  80                          (decf (root-h root) thickness))
  81                         ((search "BOTTOM" placement-name)
  82                          (decf (root-h root) thickness))))
  83           (t (cond ((search "LEFT" placement-name)
  84                     (incf (root-x root) thickness)
  85                     (decf (root-w root) thickness))
  86                    ((search "RIGHT" placement-name)
  87                     (decf (root-w root) thickness)))))))))
  88
  89
  90 (defun toolbar-draw-text (toolbar pos1 pos2 text)
  91   "pos1: percent of toolbar, pos2: pixels in toolbar"
  92   (labels ((horiz-text ()
  93              (let* ((height (- (xlib:font-ascent (toolbar-font toolbar)) (xlib:font-descent (toolbar-font toolbar))))
  94                     (dy (truncate (+ pos2 (/ height 2))))
  95                     (width (xlib:text-width (toolbar-font toolbar) text))
  96                     (pos (truncate (/ (* (- (xlib:drawable-width (toolbar-window toolbar)) width) pos1) 100))))
  97                (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) pos dy text)
  98                (values (+ pos (xlib:drawable-x (toolbar-window toolbar)))
  99                        (xlib:drawable-y (toolbar-window toolbar))
 100                        width
 101                        (xlib:drawable-height (toolbar-window toolbar)))))
 102            (vert-text ()
 103              (let* ((width (xlib:max-char-width (toolbar-font toolbar)))
 104                     (dx (truncate (- pos2 (/ width 2))))
 105                     (dpos (xlib:max-char-ascent (toolbar-font toolbar)))
 106                     (height (* dpos (length text)))
 107                     (pos (+ (truncate (/ (* (- (xlib:drawable-height (toolbar-window toolbar)) height
 108                                                (xlib:max-char-descent (toolbar-font toolbar)))
 109                                             pos1) 100))
 110                             (xlib:font-ascent (toolbar-font toolbar)))))
 111                (loop for c across text
 112                     for i from 0
 113                   do (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) dx (+ pos (* i dpos)) (string c)))
 114                (values (xlib:drawable-x (toolbar-window toolbar))
 115                        (+ (- pos dpos) (xlib:drawable-y (toolbar-window toolbar)))
 116                        (xlib:drawable-width (toolbar-window toolbar))
 117                        height))))
 118     (case (toolbar-direction toolbar)
 119       (:horiz (horiz-text))
 120       (:vert (vert-text)))))
 121
 122
 123
 124 (defun refresh-toolbar (toolbar)
 125   (add-timer (toolbar-refresh-delay toolbar)
 126              (lambda ()
 127                (refresh-toolbar toolbar))
 128              :refresh-toolbar)
 129   (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
 130   (dolist (module (toolbar-modules toolbar))
 131     (when (fboundp (toolbar-module-display-fun module))
 132       (funcall (toolbar-module-display-fun module) toolbar module)))
 133   (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))
 134
 135 (defun toolbar-in-sensibility-zone-p (toolbar root-x root-y)
 136   (let* ((tb-win (toolbar-window toolbar))
 137          (win-x (xlib:drawable-x tb-win))
 138          (win-y (xlib:drawable-y tb-win))
 139          (width (xlib:drawable-width tb-win))
 140          (height (xlib:drawable-height tb-win))
 141          (tb-dir (toolbar-direction toolbar) )
 142          (placement-name (symbol-name (toolbar-placement toolbar))))
 143     (or (and (equal tb-dir :horiz) (search "TOP" placement-name)
 144              (<= root-y win-y (+ root-y *toolbar-sensibility*))
 145              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
 146         (and (equal tb-dir :horiz) (search "BOTTOM" placement-name)
 147              (<= (+ win-y height (- *toolbar-sensibility*)) root-y (+ win-y height))
 148              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
 149         (and (equal tb-dir :vert) (search "LEFT" placement-name)
 150              (<= root-x win-x (+ root-x *toolbar-sensibility*))
 151              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar))
 152         (and (equal tb-dir :vert) (search "RIGHT" placement-name)
 153              (<= (+ win-x width (- *toolbar-sensibility*)) root-x (+ win-x width))
 154              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar)))))
 155
 156 (use-event-hook :exposure)
 157 (use-event-hook :button-press)
 158 (use-event-hook :motion-notify)
 159 (use-event-hook :leave-notify)
 160
 161
 162 (defun toolbar-add-exposure-hook (toolbar)
 163   (define-event-hook :exposure (window)
 164     (when (and (xlib:window-p window) (xlib:window-equal (toolbar-window toolbar) window))
 165       (refresh-toolbar toolbar))))
 166
 167 (defun toolbar-add-hide-button-press-hook (toolbar)
 168   (define-event-hook :button-press (code root-x root-y)
 169     (when (= code 1)
 170       (let* ((tb-win (toolbar-window toolbar)))
 171         (when (toolbar-in-sensibility-zone-p toolbar root-x root-y)
 172           (if (toolbar-hide-state toolbar)
 173               (progn
 174                 (map-window tb-win)
 175                 (raise-window tb-win)
 176                 (refresh-toolbar toolbar)
 177                 (setf (toolbar-hide-state toolbar) nil))
 178               (progn
 179                 (hide-window tb-win)
 180                 (setf (toolbar-hide-state toolbar) t)))
 181           (wait-mouse-button-release)
 182           (stop-button-event)
 183           (exit-handle-event))))))
 184
 185 (defun toolbar-add-hide-motion-hook (toolbar)
 186   (define-event-hook :motion-notify (root-x root-y)
 187     (unless (compress-motion-notify)
 188       (when (and (toolbar-hide-state toolbar)
 189                  (toolbar-in-sensibility-zone-p toolbar root-x root-y))
 190         (map-window (toolbar-window toolbar))
 191         (raise-window (toolbar-window toolbar))
 192         (refresh-toolbar toolbar)
 193         (setf (toolbar-hide-state toolbar) nil)
 194         (exit-handle-event)))))
 195
 196 (defun toolbar-add-hide-leave-hook (toolbar)
 197   (define-event-hook :leave-notify (root-x root-y)
 198     (when (and (not (toolbar-hide-state toolbar))
 199                (not (in-window (toolbar-window toolbar) root-x root-y)))
 200       (hide-window (toolbar-window toolbar))
 201       (setf (toolbar-hide-state toolbar) t)
 202       (exit-handle-event))))
 203
 204 ;;    (when (and (xlib:window-equal (toolbar-window toolbar) window)
 205 ;;               (not (in-window (toolbar-window toolbar) root-x root-y)))
 206 ;;      (hide-window window)
 207 ;;      (setf (toolbar-hide-state toolbar) t)
 208 ;;      (exit-handle-event))))
 209
 210 (defun toolbar-add-clickable-module-hook (toolbar)
 211   (define-event-hook :button-press (code state root-x root-y)
 212     (when (and (in-window (toolbar-window toolbar) root-x root-y)
 213                (not (toolbar-hide-state toolbar)))
 214       (dolist (module (toolbar-modules toolbar))
 215         (when (and (in-rectangle root-x root-y (toolbar-module-rect module))
 216                    (fboundp (toolbar-module-click-fun module)))
 217           (funcall (toolbar-module-click-fun module) toolbar module code state)
 218           (stop-button-event)
 219           (exit-handle-event))))))
 220
 221
 222 (defun define-toolbar-hooks (toolbar)
 223   (toolbar-add-exposure-hook toolbar)
 224   (when (toolbar-clickable toolbar)
 225     (toolbar-add-clickable-module-hook toolbar))
 226   (case (toolbar-autohide toolbar)
 227     (:click (toolbar-add-hide-button-press-hook toolbar))
 228     (:motion (toolbar-add-hide-motion-hook toolbar)
 229              (toolbar-add-hide-leave-hook toolbar))))
 230
 231 (defun set-clickable-toolbar (toolbar)
 232   (dolist (module (toolbar-modules toolbar))
 233     (when (fboundp (toolbar-module-click-fun module))
 234       (setf (toolbar-clickable toolbar) t))))
 235
 236
 237
 238 (let ((windows-list nil))
 239   (defun is-toolbar-window-p (win)
 240     (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal)))
 241
 242   (defun close-toolbar (toolbar)
 243     (erase-timer :refresh-toolbar-window)
 244     (setf *never-managed-window-list*
 245           (remove (list #'is-toolbar-window-p nil)
 246                   *never-managed-window-list* :test #'equal))
 247     (awhen (toolbar-gc toolbar)
 248       (xlib:free-gcontext it))
 249     (awhen (toolbar-window toolbar)
 250       (xlib:destroy-window it))
 251     (awhen (toolbar-font toolbar)
 252       (xlib:close-font it))
 253     (xlib:display-finish-output *display*)
 254     (setf (toolbar-window toolbar) nil
 255           (toolbar-gc toolbar) nil
 256           (toolbar-font toolbar) nil))
 257
 258   (defun open-toolbar (toolbar)
 259     (let ((root (root (toolbar-root-x toolbar) (toolbar-root-y toolbar))))
 260       (when (root-p root)
 261         (setf (toolbar-root toolbar) root)
 262         (let ((*get-current-root-fun* (lambda () root)))
 263           (setf (toolbar-font toolbar) (xlib:open-font *display* *toolbar-window-font-string*))
 264           (let* ((width (if (equal (toolbar-direction toolbar) :horiz)
 265                             (round (/ (* (root-w root) (toolbar-size toolbar)) 100))
 266                             (toolbar-thickness toolbar)))
 267                  (height (if (equal (toolbar-direction toolbar) :horiz)
 268                              (toolbar-thickness toolbar)
 269                              (round (/ (* (root-h root) (toolbar-size toolbar)) 100)))))
 270             (with-placement ((toolbar-placement toolbar) x y width height (toolbar-border-size toolbar))
 271               (setf (toolbar-window toolbar) (xlib:create-window :parent *root*
 272                                                                  :x x
 273                                                                  :y y
 274                                                                  :width width
 275                                                                  :height height
 276                                                                  :background (get-color *toolbar-window-background*)
 277                                                                  :border-width (toolbar-border-size toolbar)
 278                                                                  :border (when (plusp (toolbar-border-size toolbar))
 279                                                                            (get-color *toolbar-window-border*))
 280                                                                  :colormap (xlib:screen-default-colormap *screen*)
 281                                                                  :event-mask '(:exposure :key-press :leave-window
 282                                                                                :pointer-motion))
 283                     (toolbar-gc toolbar) (xlib:create-gcontext :drawable (toolbar-window toolbar)
 284                                                                :foreground (get-color *toolbar-window-foreground*)
 285                                                                :background (get-color *toolbar-window-background*)
 286                                                                :font (toolbar-font toolbar)
 287                                                                :line-style :solid))
 288               (push (toolbar-window toolbar) windows-list)
 289               (setf (window-transparency (toolbar-window toolbar)) *toolbar-window-transparency*)
 290               (push (list #'is-toolbar-window-p nil) *never-managed-window-list*)
 291               (map-window (toolbar-window toolbar))
 292               (raise-window (toolbar-window toolbar))
 293               (refresh-toolbar toolbar)
 294               (when (toolbar-autohide toolbar)
 295                 (hide-window (toolbar-window toolbar))
 296                 (setf (toolbar-hide-state toolbar) t))
 297               (xlib:display-finish-output *display*)
 298               (set-clickable-toolbar toolbar)
 299               (define-toolbar-hooks toolbar))))))))
 300
 301 (defun optimize-all-toolbar-event ()
 302   (let ((use-button-press nil)
 303         (use-motion nil))
 304     (dolist (toolbar *toolbar-list*)
 305       (when (toolbar-clickable toolbar)
 306         (setf use-button-press t))
 307       (case (toolbar-autohide toolbar)
 308         (:motion (setf use-motion t))
 309         (:click (setf use-button-press t))))
 310     (unless use-button-press
 311       (unuse-event-hook :button-press))
 312     (unless use-motion
 313       (unuse-event-hook :motion-notify)
 314       (unuse-event-hook :leave-notify))))
 315
 316
 317 (defun open-all-toolbars ()
 318   "Open all toolbars"
 319   (dolist (toolbar *toolbar-list*)
 320     (open-toolbar toolbar))
 321   (dolist (toolbar *toolbar-list*)
 322     (toolbar-adjust-root-size toolbar))
 323   (optimize-all-toolbar-event))
 324
 325 (defun close-all-toolbars ()
 326   (dolist (toolbar *toolbar-list*)
 327     (close-toolbar toolbar)))
 328
 329 (defun create-toolbar-modules (modules)
 330   (loop for mod in modules
 331      collect (make-toolbar-module :name (first mod)
 332                                   :pos (second mod)
 333                                   :display-fun (toolbar-symbol-fun (first mod))
 334                                   :click-fun (toolbar-symbol-fun (first mod) 'click)
 335                                   :rect nil)))
 336
 337
 338 (defun add-toolbar (root-x root-y direction size placement modules
 339                     &key (autohide *toolbar-default-autohide*))
 340   "Add a new toolbar.
 341      root-x, root-y: root coordinates or if root-y is nil, root-x is the nth root in root-list.
 342      direction: one of :horiz or :vert
 343      size: toolbar size in percent of root size"
 344   (let ((toolbar (make-toolbar :root-x root-x :root-y root-y
 345                       :direction direction :size size
 346                       :thickness *toolbar-default-thickness*
 347                       :placement placement
 348                       :autohide autohide
 349                       :refresh-delay *toolbar-default-refresh-delay*
 350                       :border-size *toolbar-default-border-size*
 351                       :modules (create-toolbar-modules modules))))
 352     (push toolbar *toolbar-list*)
 353     toolbar))
 354
 355
 356 (add-hook *init-hook* 'open-all-toolbars)
 357 (add-hook *close-hook* 'close-all-toolbars)
 358
 359
 360 (defun set-toolbar-module-rectangle (module x y width height)
 361   (unless (toolbar-module-rect module)
 362     (setf (toolbar-module-rect module) (make-rectangle)))
 363   (setf (rectangle-x (toolbar-module-rect module)) x
 364         (rectangle-y (toolbar-module-rect module)) y
 365         (rectangle-width (toolbar-module-rect module)) width
 366         (rectangle-height (toolbar-module-rect module)) height))
 367
 368 (defmacro with-set-toolbar-module-rectangle ((module) &body body)
 369   (let ((x (gensym)) (y (gensym)) (width (gensym)) (height (gensym)))
 370     `(multiple-value-bind (,x ,y ,width ,height)
 371          ,@body
 372        (set-toolbar-module-rectangle ,module ,x ,y ,width ,height))))
 373
 374
 375
 376 (defmacro define-toolbar-module ((name) &body body)
 377   (let ((symbol-fun (toolbar-symbol-fun name)))
 378     `(progn
 379        (pushnew ',name *toolbar-module-list*)
 380        (defun ,symbol-fun (toolbar module)
 381          ,@body))))
 382
 383 (defmacro define-toolbar-module-click ((name) &body body)
 384   (let ((symbol-fun (toolbar-symbol-fun name 'click)))
 385     `(progn
 386        (pushnew ',name *toolbar-module-list*)
 387        (defun ,symbol-fun (toolbar module code state)
 388          ,@body))))
 389
 390
 391 ;;;
 392 ;;; Modules definitions
 393 ;;;
 394 (define-toolbar-module (clock)
 395   "The clock module"
 396   (multiple-value-bind (s m h)
 397       (get-decoded-time)
 398     (declare (ignore s))
 399     (toolbar-draw-text toolbar (toolbar-module-pos module) (/ *toolbar-default-thickness* 2)
 400                        (format nil "~2,'0D:~2,'0D" h m))))
 401
 402 (define-toolbar-module (clock-second)
 403   "The clock module"
 404   (multiple-value-bind (s m h)
 405       (get-decoded-time)
 406     (toolbar-draw-text toolbar (toolbar-module-pos module) (/ *toolbar-default-thickness* 2)
 407                        (format nil "~2,'0D:~2,'0D:~2,'0D" h m s))))
 408
 409
 410 (define-toolbar-module (label)
 411   "The label module"
 412   (toolbar-draw-text toolbar (toolbar-module-pos module) (/ *toolbar-default-thickness* 2)
 413                      "Label"))
 414
 415
 416 (define-toolbar-module (clickable-clock)
 417   "The clock module (clickable)"
 418   (multiple-value-bind (s m h)
 419       (get-decoded-time)
 420     (declare (ignore s))
 421     (with-set-toolbar-module-rectangle (module)
 422       (toolbar-draw-text toolbar (toolbar-module-pos module) (/ *toolbar-default-thickness* 2)
 423                          (format nil "Click:~2,'0D:~2,'0D" h m)))))
 424
 425
 426 (define-toolbar-module-click (clickable-clock)
 427   "Start a digital clock"
 428   (declare (ignore toolbar module state))
 429   (when (= code 1)
 430     (do-shell "xclock")))
 431
 432
 433 (format t "done~%")