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