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, position in percent and arguments.
  44 ;;;                0%=left/up   <->   100%=right/down.
  45 ;;;                Example: '((clock 1) (label 50 \"My label\") (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 ;;;  ;; with default modules
  57 ;;;
  58 ;;;    (add-toolbar 0 0 :horiz 80 'top-middle-root-placement *default-toolbar*)
  59 ;;;
  60 ;;;
  61 ;;;  ;; Add an horizontal toolbar on root at coordinates 0,0 pixels
  62 ;;;
  63 ;;;    (add-toolbar 0 0 :horiz 90 'top-middle-root-placement
  64 ;;;                 '((clock 1) (label 50 "Plop") (clock-second 25) (clickable-clock 99))
  65 ;;;                 :autohide :click
  66 ;;;                 :refresh-delay 1)
  67 ;;;
  68 ;;;
  69 ;;;  ;; Add an horizontal toolbar on root at coordinates 0,0 pixels
  70 ;;;
  71 ;;;    (add-toolbar 0 0 :horiz 70 'bottom-middle-root-placement '((clock 1) (label 50 "Paf) (clock 99))
  72 ;;;                 :autohide :motion)
  73 ;;;
  74 ;;;
  75 ;;;  ;; Add a vertical toolbar on root 0
  76 ;;;
  77 ;;;    (add-toolbar 0 nil :vert 60 'middle-left-root-placement '((clock 1) (label 50 "My label") (clock 90)))
  78 ;;;
  79 ;;;
  80 ;;;  ;; Add a vertical toolbar on root 1
  81 ;;;
  82 ;;;    (add-toolbar 1 nil :vert 70 'bottom-right-root-placement '((clock 1) (label 50) (clickable-clock 99)))
  83 ;;; --------------------------------------------------------------------------
  84
  85 (in-package :clfswm)
  86
  87 (format t "Loading Toolbar code... ")
  88
  89 (pushnew :clfswm-toolbar *features*)
  90
  91 (defstruct toolbar root-x root-y root direction size thickness placement refresh-delay
  92            autohide modules clickable hide-state font window gc border-size
  93            exposure-hook button-press-hook motion-notify-hook leave-notify-hook)
  94
  95 (defstruct toolbar-module name pos display-fun click-fun args rect)
  96
  97 (defparameter *toolbar-list* nil)
  98 (defparameter *toolbar-module-list* nil)
  99
 100 (defparameter *toolbar-root-usage* nil)
 101
 102 (defconfig *default-toolbar* '((clfswm-menu 1)
 103                                (expose-mode-button 10)
 104                                (system-usage 90)
 105                                (clickable-clock 99))
 106   'Toolbar "Default toolbar modules")
 107
 108
 109 ;;; CONFIG - Toolbar window string colors
 110 (defconfig *toolbar-window-font-string* *default-font-string*
 111   'Toolbar "Toolbar window font string")
 112 (defconfig *toolbar-window-background* "black"
 113   'Toolbar "Toolbar Window background color")
 114 (defconfig *toolbar-window-foreground* "green"
 115   'Toolbar "Toolbar Window foreground color")
 116 (defconfig *toolbar-window-border* "red"
 117   'Toolbar "Toolbar Window border color")
 118 (defconfig *toolbar-default-border-size* 0
 119   'Toolbar "Toolbar Window border size")
 120 (defconfig *toolbar-window-transparency* *default-transparency*
 121   'Toolbar "Toolbar window background transparency")
 122 (defconfig *toolbar-default-thickness* 20
 123   'Toolbar "Toolbar default thickness")
 124 (defconfig *toolbar-default-refresh-delay* 30
 125   'Toolbar "Toolbar default refresh delay")
 126 (defconfig *toolbar-default-autohide* nil
 127   'Toolbar "Toolbar default autohide value")
 128 (defconfig *toolbar-sensibility* 3
 129   'Toolbar "Toolbar sensibility in pixels")
 130
 131 (defconfig *toolbar-window-placement* 'top-left-placement
 132   'Placement "Toolbar window placement")
 133
 134 (use-event-hook :exposure)
 135 (use-event-hook :button-press)
 136 (use-event-hook :motion-notify)
 137 (use-event-hook :leave-notify)
 138
 139 (defun toolbar-symbol-fun (name &optional (type 'display))
 140   (create-symbol-in-package :clfswm 'toolbar- name '-module- type))
 141
 142 (defmacro with-toolbar-root-usage ((root place) &body body)
 143   "Apply body only if root place is not already used"
 144   `(unless (member ,place (gethash ,root *toolbar-root-usage*))
 145      ,@body
 146      (pushnew ,place (gethash ,root *toolbar-root-usage*))))
 147
 148 (defun toolbar-adjust-root-size (toolbar &optional (dir +1))
 149   (unless (toolbar-autohide toolbar)
 150     (let ((root (toolbar-root toolbar))
 151           (placement-name (symbol-name (toolbar-placement toolbar)))
 152           (thickness (+ (toolbar-thickness toolbar) (* 2 (toolbar-border-size toolbar)))))
 153       (when (root-p root)
 154         (case (toolbar-direction toolbar)
 155           (:horiz (cond ((search "TOP" placement-name)
 156                          (with-toolbar-root-usage (root :top)
 157                            (incf (root-y root) (* thickness dir))
 158                            (decf (root-h root) (* thickness dir))))
 159                         ((search "BOTTOM" placement-name)
 160                          (with-toolbar-root-usage (root :bottom)
 161                            (decf (root-h root) (* thickness dir))))))
 162           (t (cond ((search "LEFT" placement-name)
 163                     (with-toolbar-root-usage (root :left)
 164                       (incf (root-x root) (* thickness dir))
 165                       (decf (root-w root) (* thickness dir))))
 166                    ((search "RIGHT" placement-name)
 167                     (with-toolbar-root-usage (root :right)
 168                       (decf (root-w root) (* thickness dir)))))))))))
 169
 170
 171 (defun toolbar-draw-text (toolbar pos1 pos2 text color)
 172   "pos1: percent of toolbar, pos2: pixels in toolbar"
 173   (labels ((horiz-text ()
 174              (let* ((height (- (xlib:font-ascent (toolbar-font toolbar)) (xlib:font-descent (toolbar-font toolbar))))
 175                     (dy (truncate (+ pos2 (/ height 2))))
 176                     (width (xlib:text-width (toolbar-font toolbar) text))
 177                     (pos (truncate (/ (* (- (xlib:drawable-width (toolbar-window toolbar)) width) pos1) 100))))
 178                (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) pos dy text)
 179                (values (+ pos (xlib:drawable-x (toolbar-window toolbar)))
 180                        (xlib:drawable-y (toolbar-window toolbar))
 181                        width
 182                        (xlib:drawable-height (toolbar-window toolbar)))))
 183            (vert-text ()
 184              (let* ((width (xlib:max-char-width (toolbar-font toolbar)))
 185                     (dx (truncate (- pos2 (/ width 2))))
 186                     (dpos (xlib:max-char-ascent (toolbar-font toolbar)))
 187                     (height (* dpos (length text)))
 188                     (pos (+ (truncate (/ (* (- (xlib:drawable-height (toolbar-window toolbar)) height
 189                                                (xlib:max-char-descent (toolbar-font toolbar)))
 190                                             pos1) 100))
 191                             (xlib:font-ascent (toolbar-font toolbar)))))
 192                (loop for c across text
 193                     for i from 0
 194                   do (xlib:draw-glyphs *pixmap-buffer* (toolbar-gc toolbar) dx (+ pos (* i dpos)) (string c)))
 195                (values (xlib:drawable-x (toolbar-window toolbar))
 196                        (+ (- pos dpos) (xlib:drawable-y (toolbar-window toolbar)))
 197                        (xlib:drawable-width (toolbar-window toolbar))
 198                        height))))
 199     (xlib:with-gcontext ((toolbar-gc toolbar) :foreground (get-color color))
 200       (case (toolbar-direction toolbar)
 201         (:horiz (horiz-text))
 202         (:vert (vert-text))))))
 203
 204
 205 (defun toolbar-module-text (toolbar module color formatter &rest text)
 206   "Print a formatted text at module position centered in toolbar"
 207   (toolbar-draw-text toolbar (toolbar-module-pos module) (/ *toolbar-default-thickness* 2)
 208                      (apply #'format nil formatter text)
 209                      color))
 210
 211 (defun is-valid-toolbar (toolbar)
 212   (member toolbar *toolbar-list*))
 213
 214
 215 (defun refresh-toolbar (toolbar)
 216   (when (is-valid-toolbar toolbar)
 217     (unless (toolbar-hide-state toolbar)
 218       (add-timer (toolbar-refresh-delay toolbar)
 219                  (lambda ()
 220                    (refresh-toolbar toolbar))
 221                  :refresh-toolbar)
 222       (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
 223       (dolist (module (toolbar-modules toolbar))
 224         (when (fboundp (toolbar-module-display-fun module))
 225           (apply (toolbar-module-display-fun module) toolbar module (toolbar-module-args module))))
 226       (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))))
 227
 228 (defun toolbar-in-sensibility-zone-p (toolbar root-x root-y)
 229   (let* ((tb-win (toolbar-window toolbar))
 230          (win-x (xlib:drawable-x tb-win))
 231          (win-y (xlib:drawable-y tb-win))
 232          (width (xlib:drawable-width tb-win))
 233          (height (xlib:drawable-height tb-win))
 234          (tb-dir (toolbar-direction toolbar) )
 235          (placement-name (symbol-name (toolbar-placement toolbar))))
 236     (or (and (equal tb-dir :horiz) (search "TOP" placement-name)
 237              (<= root-y win-y (+ root-y *toolbar-sensibility*))
 238              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
 239         (and (equal tb-dir :horiz) (search "BOTTOM" placement-name)
 240              (<= (+ win-y height (- *toolbar-sensibility*)) root-y (+ win-y height))
 241              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
 242         (and (equal tb-dir :vert) (search "LEFT" placement-name)
 243              (<= root-x win-x (+ root-x *toolbar-sensibility*))
 244              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar))
 245         (and (equal tb-dir :vert) (search "RIGHT" placement-name)
 246              (<= (+ win-x width (- *toolbar-sensibility*)) root-x (+ win-x width))
 247              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar)))))
 248
 249
 250 (defun toolbar-add-exposure-hook (toolbar)
 251   (push (define-event-hook :exposure (window)
 252           (when (and (is-valid-toolbar toolbar)
 253                      (xlib:window-p window)
 254                      (xlib:window-equal (toolbar-window toolbar) window))
 255             (refresh-toolbar toolbar)))
 256         (toolbar-exposure-hook toolbar)))
 257
 258
 259 (defun toggle-toolbar-hide-state (toolbar)
 260   (let* ((tb-win (toolbar-window toolbar)))
 261     (if (toolbar-hide-state toolbar)
 262         (progn
 263           (setf (toolbar-hide-state toolbar) nil)
 264           (map-window tb-win)
 265           (raise-window tb-win)
 266           (refresh-toolbar toolbar))
 267         (progn
 268           (hide-window tb-win)
 269           (setf (toolbar-hide-state toolbar) t)))))
 270
 271 (defun toolbar-add-hide-button-press-hook (toolbar)
 272   (push (define-event-hook :button-press (code root-x root-y)
 273           (when (and (is-valid-toolbar toolbar) (= code 1)
 274                      (toolbar-in-sensibility-zone-p toolbar root-x root-y))
 275             (toggle-toolbar-hide-state toolbar)
 276             (wait-mouse-button-release)
 277             (stop-button-event)
 278             (exit-handle-event)))
 279         (toolbar-button-press-hook toolbar)))
 280
 281 (defun toolbar-add-hide-motion-hook (toolbar)
 282   (push (define-event-hook :motion-notify (root-x root-y)
 283           (unless (compress-motion-notify)
 284             (when (and (is-valid-toolbar toolbar)
 285                        (toolbar-hide-state toolbar)
 286                        (toolbar-in-sensibility-zone-p toolbar root-x root-y))
 287               (map-window (toolbar-window toolbar))
 288               (raise-window (toolbar-window toolbar))
 289               (refresh-toolbar toolbar)
 290               (setf (toolbar-hide-state toolbar) nil)
 291               (exit-handle-event))))
 292          (toolbar-motion-notify-hook toolbar)))
 293
 294 (defun toolbar-add-hide-leave-hook (toolbar)
 295   (push (define-event-hook :leave-notify (root-x root-y)
 296           (when (and (is-valid-toolbar toolbar)
 297                      (not (toolbar-hide-state toolbar))
 298                      (not (in-window (toolbar-window toolbar) root-x root-y)))
 299             (hide-window (toolbar-window toolbar))
 300             (setf (toolbar-hide-state toolbar) t)
 301             (exit-handle-event)))
 302          (toolbar-leave-notify-hook toolbar)))
 303
 304
 305 (defun toolbar-add-clickable-module-hook (toolbar)
 306   (push (define-event-hook :button-press (code state root-x root-y)
 307           (when (and (is-valid-toolbar toolbar)
 308                      (in-window (toolbar-window toolbar) root-x root-y)
 309                      (not (toolbar-hide-state toolbar)))
 310             (dolist (module (toolbar-modules toolbar))
 311               (when (and (in-rectangle root-x root-y (toolbar-module-rect module))
 312                          (fboundp (toolbar-module-click-fun module)))
 313                 (apply (toolbar-module-click-fun module) toolbar module code state root-x root-y
 314                        (toolbar-module-args module))
 315                 (stop-button-event)
 316                 (exit-handle-event)))))
 317           (toolbar-button-press-hook toolbar)))
 318
 319
 320 (defun define-toolbar-hooks (toolbar)
 321   (toolbar-add-exposure-hook toolbar)
 322   (when (toolbar-clickable toolbar)
 323     (toolbar-add-clickable-module-hook toolbar))
 324   (case (toolbar-autohide toolbar)
 325     (:click (toolbar-add-hide-button-press-hook toolbar))
 326     (:motion (toolbar-add-hide-motion-hook toolbar)
 327              (toolbar-add-hide-leave-hook toolbar))))
 328
 329 (defun set-clickable-toolbar (toolbar)
 330   (dolist (module (toolbar-modules toolbar))
 331     (when (fboundp (toolbar-module-click-fun module))
 332       (setf (toolbar-clickable toolbar) t))))
 333
 334
 335 (defmacro remove-toolbar-hook (toolbar keyword)
 336   (let ((fun (create-symbol 'toolbar- keyword '-hook)))
 337     `(dolist (hook (,fun ,toolbar))
 338        (remove-event-hook ,keyword hook))))
 339
 340
 341
 342 (let ((windows-list nil))
 343   (defun is-toolbar-window-p (win)
 344     (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal)))
 345
 346   (defun close-toolbar (toolbar)
 347     (when (toolbar-p toolbar)
 348       (erase-timer :refresh-toolbar-window)
 349       (remove-toolbar-hook toolbar :exposure)
 350       (remove-toolbar-hook toolbar :button-press)
 351       (remove-toolbar-hook toolbar :leave-notify)
 352       (remove-toolbar-hook toolbar :motion-notify)
 353       (setf *never-managed-window-list*
 354             (remove (list #'is-toolbar-window-p nil)
 355                     *never-managed-window-list* :test #'equal))
 356       (awhen (toolbar-gc toolbar)
 357         (xlib:free-gcontext it))
 358       (awhen (toolbar-window toolbar)
 359         (xlib:destroy-window it))
 360       (awhen (toolbar-font toolbar)
 361         (xlib:close-font it))
 362       (xlib:display-finish-output *display*)
 363       (setf (toolbar-window toolbar) nil
 364             (toolbar-gc toolbar) nil
 365             (toolbar-font toolbar) nil)))
 366
 367   (defun open-toolbar (toolbar)
 368     (let ((root (root (toolbar-root-x toolbar) (toolbar-root-y toolbar))))
 369       (when (root-p root)
 370         (setf (toolbar-root toolbar) root)
 371         (let ((*get-current-root-fun* (lambda () root)))
 372           (setf (toolbar-font toolbar) (xlib:open-font *display* *toolbar-window-font-string*))
 373           (let* ((width (if (equal (toolbar-direction toolbar) :horiz)
 374                             (round (/ (* (root-w root) (toolbar-size toolbar)) 100))
 375                             (toolbar-thickness toolbar)))
 376                  (height (if (equal (toolbar-direction toolbar) :horiz)
 377                              (toolbar-thickness toolbar)
 378                              (round (/ (* (root-h root) (toolbar-size toolbar)) 100)))))
 379             (with-placement ((toolbar-placement toolbar) x y width height (toolbar-border-size toolbar))
 380               (setf (toolbar-window toolbar) (xlib:create-window :parent *root*
 381                                                                  :x x
 382                                                                  :y y
 383                                                                  :width width
 384                                                                  :height height
 385                                                                  :background (get-color *toolbar-window-background*)
 386                                                                  :border-width (toolbar-border-size toolbar)
 387                                                                  :border (when (plusp (toolbar-border-size toolbar))
 388                                                                            (get-color *toolbar-window-border*))
 389                                                                  :colormap (xlib:screen-default-colormap *screen*)
 390                                                                  :event-mask '(:exposure :key-press :leave-window
 391                                                                                :pointer-motion))
 392                     (toolbar-gc toolbar) (xlib:create-gcontext :drawable (toolbar-window toolbar)
 393                                                                :foreground (get-color *toolbar-window-foreground*)
 394                                                                :background (get-color *toolbar-window-background*)
 395                                                                :font (toolbar-font toolbar)
 396                                                                :line-style :solid))
 397               (push (toolbar-window toolbar) windows-list)
 398               (setf (window-transparency (toolbar-window toolbar)) *toolbar-window-transparency*)
 399               (add-in-never-managed-window-list (list 'is-toolbar-window-p nil))
 400               (map-window (toolbar-window toolbar))
 401               (raise-window (toolbar-window toolbar))
 402               (refresh-toolbar toolbar)
 403               (when (toolbar-autohide toolbar)
 404                 (hide-window (toolbar-window toolbar))
 405                 (setf (toolbar-hide-state toolbar) t))
 406               (xlib:display-finish-output *display*)
 407               (set-clickable-toolbar toolbar)
 408               (define-toolbar-hooks toolbar))))))))
 409
 410
 411
 412 (defun remove-toolbar (toolbar)
 413   (close-toolbar toolbar)
 414   (setf *toolbar-list* (remove toolbar *toolbar-list* :test #'equal)))
 415
 416
 417 (defun open-all-toolbars ()
 418   "Open all toolbars"
 419   (setf *toolbar-root-usage* (make-hash-table :test #'equal))
 420   (dolist (toolbar *toolbar-list*)
 421     (open-toolbar toolbar))
 422   (dolist (toolbar *toolbar-list*)
 423     (toolbar-adjust-root-size toolbar)))
 424
 425 (defun close-all-toolbars ()
 426   (setf *toolbar-root-usage* (make-hash-table :test #'equal))
 427   (dolist (toolbar *toolbar-list*)
 428     (toolbar-adjust-root-size toolbar -1))
 429   (dolist (toolbar *toolbar-list*)
 430     (remove-toolbar toolbar))
 431   (stop-system-poll))
 432
 433 (defun create-toolbar-modules (modules)
 434   (loop for mod in modules
 435      collect (make-toolbar-module :name (first mod)
 436                                   :pos (second mod)
 437                                   :display-fun (toolbar-symbol-fun (first mod))
 438                                   :click-fun (toolbar-symbol-fun (first mod) 'click)
 439                                   :args (cddr mod)
 440                                   :rect nil)))
 441
 442
 443 (defun add-toolbar (root-x root-y direction size placement modules
 444                     &key (autohide *toolbar-default-autohide*)
 445                     (thickness *toolbar-default-thickness*)
 446                     (refresh-delay *toolbar-default-refresh-delay*)
 447                     (border-size *toolbar-default-border-size*))
 448   "Add a new toolbar.
 449      root-x, root-y: root coordinates or if root-y is nil, root-x is the nth root in root-list.
 450      direction: one of :horiz or :vert
 451      placement: same argument as with-placement macro
 452      modules: list of modules: a list of module name, position in percent and arguments.
 453               0%=left/up   <->   100%=right/down.
 454               Example: '((clock 1) (label 50 \"My label\") (clickable-clock 90))
 455      size: toolbar size in percent of root size
 456      thickness: toolbar height for horizontal toolbar or width for vertical one
 457      autohide: one of nil, :click, or :motion
 458      refresh-delay: refresh delay for toolbar in seconds
 459      border-size: toolbar window border size"
 460   (let ((toolbar (make-toolbar :root-x root-x :root-y root-y
 461                                :direction direction :size size
 462                                :thickness thickness
 463                                :placement placement
 464                                :autohide autohide
 465                                :refresh-delay refresh-delay
 466                                :border-size border-size
 467                                :modules (create-toolbar-modules modules))))
 468     (push toolbar *toolbar-list*)
 469     toolbar))
 470
 471
 472 (add-hook *init-hook* 'open-all-toolbars)
 473 (add-hook *close-hook* 'close-all-toolbars)
 474
 475
 476 (defun set-toolbar-module-rectangle (module x y width height)
 477   (unless (toolbar-module-rect module)
 478     (setf (toolbar-module-rect module) (make-rectangle)))
 479   (setf (rectangle-x (toolbar-module-rect module)) x
 480         (rectangle-y (toolbar-module-rect module)) y
 481         (rectangle-width (toolbar-module-rect module)) width
 482         (rectangle-height (toolbar-module-rect module)) height))
 483
 484 (defmacro with-set-toolbar-module-rectangle ((module) &body body)
 485   (let ((x (gensym)) (y (gensym)) (width (gensym)) (height (gensym)))
 486     `(multiple-value-bind (,x ,y ,width ,height)
 487          ,@body
 488        (set-toolbar-module-rectangle ,module ,x ,y ,width ,height))))
 489
 490
 491
 492 (defmacro define-toolbar-module ((name &rest args) &body body)
 493   (let ((symbol-fun (toolbar-symbol-fun name)))
 494     `(progn
 495        (pushnew ',name *toolbar-module-list*)
 496        (defun ,symbol-fun (toolbar module ,@(when args `(&optional ,@args)))
 497            ,@body))))
 498
 499 (defmacro define-toolbar-module-click ((name &rest args) &body body)
 500   (let ((symbol-fun (toolbar-symbol-fun name 'click)))
 501     `(progn
 502        (pushnew ',name *toolbar-module-list*)
 503        (defun ,symbol-fun (toolbar module code state root-x root-y ,@(when args `(&optional ,@args)))
 504            ,@body))))
 505
 506
 507 (defun list-toolbar-modules (&optional (stream t))
 508   "List all toolbar modules"
 509   (format stream "Toolbar modules availables:~%")
 510   (dolist (module (reverse *toolbar-module-list*))
 511     (format stream "  Module: ~A~%" module)
 512     (when (fboundp (toolbar-symbol-fun module))
 513       (format stream "    ~A~%" (documentation (toolbar-symbol-fun module) 'function)))
 514     (when (fboundp (toolbar-symbol-fun module 'click))
 515       (format stream "    On click: ~A~%" (documentation (toolbar-symbol-fun module 'click) 'function)))))
 516
 517
 518 (defmacro define-toolbar-color (name doc-string &optional (value *toolbar-window-foreground*))
 519   (let ((symbol-name (create-symbol '*toolbar- name '-color*)))
 520     `(defconfig ,symbol-name ,value 'Toolbar ,doc-string)))
 521
 522 (defmacro tb-color (name)
 523   (let ((symbol-name (create-symbol '*toolbar- name '-color*)))
 524     symbol-name))
 525
 526
 527 ;;;
 528 ;;; Module subdivisions functions
 529 ;;;
 530 (defun toolbar-module-subdiv-horiz (module root-x N)
 531   (truncate (* N  (/ (- root-x (rectangle-x (toolbar-module-rect module)))
 532                      (rectangle-width (toolbar-module-rect module))))))
 533
 534 (defun toolbar-module-subdiv-vert (module root-y N)
 535   (truncate (* N  (/ (- root-y (rectangle-y (toolbar-module-rect module)))
 536                      (rectangle-height (toolbar-module-rect module))))))
 537
 538 (defun toolbar-module-subdiv (toolbar module root-x root-y N)
 539   (case (toolbar-direction toolbar)
 540     (:horiz (toolbar-module-subdiv-horiz module root-x N))
 541     (:vert (toolbar-module-subdiv-vert module root-y N))))
 542
 543
 544 ;;;
 545 ;;; Modules definitions
 546 ;;;
 547
 548 ;;;
 549 ;;; Clock module
 550 ;;;
 551 (define-toolbar-color clock "Clock color")
 552
 553 (define-toolbar-module (clock)
 554   "A clock module"
 555   (multiple-value-bind (s m h)
 556       (get-decoded-time)
 557     (declare (ignore s))
 558     (toolbar-module-text toolbar module (tb-color clock) "~2,'0D:~2,'0D" h m)))
 559
 560 ;;;
 561 ;;; Clock module with seconds
 562 ;;;
 563 (define-toolbar-module (clock-second)
 564   "A clock module with seconds"
 565   (multiple-value-bind (s m h)
 566       (get-decoded-time)
 567     (toolbar-module-text toolbar module (tb-color clock) "~2,'0D:~2,'0D:~2,'0D" h m s)))
 568
 569
 570 ;;;
 571 ;;; Label module
 572 ;;;
 573 (define-toolbar-color label "Label color")
 574
 575 (define-toolbar-module (label text)
 576   "(text) - Display a text in toolbar"
 577   (toolbar-module-text toolbar module (tb-color label) (or text "Empty")))
 578
 579 ;;;
 580 ;;; Clickable label module
 581 ;;;
 582 (define-toolbar-color clickable-label "Clickable label color")
 583
 584 (define-toolbar-module (clickable-label text action)
 585   "(text action) - Display a clickable text in toolbar"
 586   (declare (ignore action))
 587   (with-set-toolbar-module-rectangle (module)
 588     (toolbar-module-text toolbar module (tb-color clickable-label) (or text "Empty"))))
 589
 590 (define-toolbar-module-click (clickable-label text action)
 591   "Call the function 'action'"
 592   (declare (ignore text root-x root-y))
 593   (when action
 594     (funcall action toolbar module code state )))
 595
 596 ;;;
 597 ;;;  Clickable clock module
 598 ;;;
 599 (define-toolbar-color clickable-clock "Clickable clock color")
 600
 601 (define-toolbar-module (clickable-clock)
 602   "A clickable clock module"
 603   (multiple-value-bind (s m h)
 604       (get-decoded-time)
 605     (declare (ignore s))
 606     (with-set-toolbar-module-rectangle (module)
 607       (toolbar-module-text toolbar module (tb-color clickable-clock) "~2,'0D:~2,'0D" h m))))
 608
 609
 610 (defconfig *toolbar-clock-action* "xclock -analog"
 611   'toolbar "Toolbar clickable clock module action on click")
 612
 613 (define-toolbar-module-click (clickable-clock)
 614   "Start an external clock"
 615   (declare (ignore toolbar module state root-x root-y))
 616   (when (= code 1)
 617     (do-shell *toolbar-clock-action*)))
 618
 619
 620 ;;;
 621 ;;; CLFSWM menu module
 622 ;;;
 623 (define-toolbar-color clfswm-menu "CLFSWM menu color")
 624
 625 (define-toolbar-module (clfswm-menu text placement)
 626   "(text placement) - Display an entry for the CLFSWM menu"
 627   (declare (ignore placement))
 628   (with-set-toolbar-module-rectangle (module)
 629     (toolbar-module-text toolbar module (tb-color clfswm-menu) (or text "CLFSWM"))))
 630
 631 (define-toolbar-module-click (clfswm-menu text placement)
 632   "Open the CLFSWM main menu"
 633   (declare (ignore text code state toolbar module root-x root-y))
 634   (let ((*info-mode-placement* (or placement *info-mode-placement*)))
 635     (open-menu)))
 636
 637 ;;;
 638 ;;; CPU usage
 639 ;;;
 640 (define-toolbar-color cpu "CPU color")
 641
 642 (define-toolbar-module (cpu)
 643   "Display the CPU usage (slow methode)"
 644   (toolbar-module-text toolbar module (tb-color cpu) "CPU:~A%" (cpu-usage)))
 645
 646
 647 ;;;
 648 ;;; Memory usage
 649 ;;;
 650 (define-toolbar-color mem "Memory color")
 651
 652 (define-toolbar-module (mem)
 653   "Display the memory usage (slow methode)"
 654   (multiple-value-bind (used total)
 655       (memory-usage)
 656     (toolbar-module-text toolbar module (tb-color mem) "Mem:~A%" (round (* (/ used total) 100.0)))))
 657
 658
 659
 660 ;;;
 661 ;;; Battery usage
 662 ;;;
 663 (define-toolbar-color system-info "System information colors (CPU+Mem+Battery)")
 664 (define-toolbar-color system-info-low "System information colors (CPU+Mem+Battery)" "Yellow")
 665 (define-toolbar-color system-info-alert "System information colors (CPU+Mem+Battery)" "Magenta")
 666 (define-toolbar-color system-info-urgent "System information colors (CPU+Mem+Battery)" "Red")
 667
 668 (defun toolbar-battery-color (bat)
 669   (if (numberp bat)
 670       (cond ((<= bat 5) (tb-color system-info-urgent))
 671             ((<= bat 10) (tb-color system-info-alert))
 672             ((<= bat 25) (tb-color system-info-low))
 673             (t (tb-color system-info)))
 674       (tb-color system-info)))
 675
 676 (define-toolbar-module (bat)
 677   "Display the battery usage (slow methode)"
 678   (let* ((bat (battery-usage)))
 679     (toolbar-module-text toolbar module
 680                          (toolbar-battery-color bat)
 681                          "Bat:~A%" bat)))
 682
 683
 684
 685 ;;;
 686 ;;; System usage - Battery, CPU and Memory usage all in one
 687 ;;;
 688 (define-toolbar-module (system-usage (poll-delay 10))
 689   "Display system usage: CPU, Memory and Battery (poll methode)"
 690   (multiple-value-bind (cpu used total bat)
 691       (system-usage-poll poll-delay)
 692     (toolbar-module-text toolbar module (toolbar-battery-color bat)
 693                          "Bat:~A% CPU:~A% Mem:~A%"
 694                          bat cpu
 695                          (round (* (/ used total) 100)))))
 696
 697 ;;;
 698 ;;; CPU and Memory usage - CPU and Memory usage
 699 ;;;
 700 (define-toolbar-module (system-cpu-mem (poll-delay 10))
 701   "Display system usage: CPU and Memory (poll methode)"
 702   (multiple-value-bind (cpu used total)
 703       (system-usage-poll poll-delay)
 704     (toolbar-module-text toolbar module (tb-color cpu)
 705                          "CPU:~A% Mem:~A%"
 706                          cpu
 707                          (round (* (/ used total) 100)))))
 708
 709 ;;;
 710 ;;; Expose-mode-button
 711 ;;;
 712 (define-toolbar-color expose-mode-button "Expose-mode button")
 713
 714 (define-toolbar-module (expose-mode-button text)
 715   "On click, switch to expose-mode"
 716   (with-set-toolbar-module-rectangle (module)
 717     (toolbar-module-text toolbar module (tb-color expose-mode-button) (or text "Xpo"))))
 718
 719 (define-toolbar-module-click (expose-mode-button)
 720   "left click=Show only current frames ; Right click=show all roots frames"
 721   (declare (ignore state toolbar module root-x root-y))
 722   (if (= code 1)
 723       (expose-windows-mode)
 724       (expose-all-windows-mode)))
 725
 726
 727 ;;;
 728 ;;; End of code
 729 ;;;
 730 (format t "done~%")
 731