contrib/blank-window-mode.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Blank window mode to place blank window on screen and manage
   6 ;;;  them with the keyboard or the mouse.
   7 ;;;  This is useful when you want to hide some part of the screen (for example
   8 ;;;  in school class for interactive presentation).
   9 ;;; --------------------------------------------------------------------------
  10 ;;;
  11 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
  12 ;;;
  13 ;;; This program is free software; you can redistribute it and/or modify
  14 ;;; it under the terms of the GNU General Public License as published by
  15 ;;; the Free Software Foundation; either version 3 of the License, or
  16 ;;; (at your option) any later version.
  17 ;;;
  18 ;;; This program is distributed in the hope that it will be useful,
  19 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 ;;; GNU General Public License for more details.
  22 ;;;
  23 ;;; You should have received a copy of the GNU General Public License
  24 ;;; along with this program; if not, write to the Free Software
  25 ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  26 ;;;
  27 ;;; Documentation: Blank window mode to place blank window on screen.
  28 ;;;   If you want to use this file, just add this line in your configuration
  29 ;;;   file:
  30 ;;;
  31 ;;;   (load-contrib "blank-window-mode.lisp")
  32 ;;;
  33 ;;; --------------------------------------------------------------------------
  34
  35 (in-package :clfswm)
  36
  37 (format t "Loading Blank Window Mode code... ")
  38
  39 (defconfig *blank-window-width* 50 'blank-window "Blank window width")
  40 (defconfig *blank-window-height* 20 'blank-window "Blank window height")
  41 (defconfig *blank-window-color* "white" 'blank-window "Blank window color")
  42 (defconfig *blank-window-border* "magenta" 'blank-window "Blank window border color")
  43
  44
  45 (defparameter *blank-window-list* nil)
  46 (defparameter *in-blank-window-mode* nil)
  47 (defparameter *blank-window-show-current* nil)
  48
  49 (defparameter *blank-window-keys* nil)
  50 (defparameter *blank-window-mouse* nil)
  51
  52
  53 (define-init-hash-table-key *blank-window-keys* "Blank-Window mode keys")
  54 (define-init-hash-table-key *blank-window-mouse* "Blank-Window mode mouse button")
  55
  56 (define-define-key "blank-window" *blank-window-keys*)
  57 (define-define-mouse "blank-window-mouse" *blank-window-mouse*)
  58
  59 (add-hook *binding-hook* 'init-*blank-window-keys*)
  60
  61
  62 (defun leave-blank-window-mode (&optional window root-x root-y)
  63   "Leave the blank-window mode"
  64   (declare (ignore window root-x root-y))
  65   (when *in-blank-window-mode*
  66     (throw 'exit-blank-window-loop nil)))
  67
  68
  69
  70 (defun bwm-enter-function ()
  71   (setf *in-blank-window-mode* t)
  72   (ungrab-main-keys)
  73   (xgrab-keyboard *root*)
  74   (xgrab-pointer *root* 66 67)
  75   (dolist (window *blank-window-list*)
  76     (raise-window window)))
  77
  78
  79 (defun bwm-leave-function ()
  80   (setf *in-blank-window-mode* nil)
  81   (xungrab-keyboard)
  82   (xungrab-pointer)
  83   (grab-main-keys)
  84   (wait-no-key-or-button-press))
  85
  86
  87
  88 (define-handler blank-window-mode :key-press (code state)
  89   (funcall-key-from-code *blank-window-keys* code state))
  90
  91 (define-handler blank-window-mode :button-press (code state window root-x root-y)
  92   (funcall-button-from-code *blank-window-mouse* code state window root-x root-y *fun-press*))
  93
  94
  95
  96 (defun blank-window-mode ()
  97   "Blank window mode"
  98   (generic-mode 'blank-window-mode
  99                 'exit-blank-window-loop
 100                 :enter-function #'bwm-enter-function
 101                 ;;:loop-function #'bwm-loop-function
 102                 :leave-function #'bwm-leave-function
 103                 :original-mode 'main-mode))
 104
 105
 106
 107
 108 (defun create-new-blank-window (&rest args)
 109   "Create a new blank window"
 110   (declare (ignore args))
 111   (with-x-pointer
 112     (push (xlib:create-window :parent *root*
 113                               :x (- x 50) :y y
 114                               :width *blank-window-width* :height *blank-window-height*
 115                               :background (get-color *blank-window-color*)
 116                               :border-width 0
 117                               :border (get-color *blank-window-border*)
 118                               :colormap (xlib:screen-default-colormap *screen*)
 119                               :event-mask '(:exposure))
 120           *blank-window-list*))
 121   (map-window (first *blank-window-list*)))
 122
 123 (defun clear-all-blank-window ()
 124   "Clear all blank window"
 125   (dolist (window *blank-window-list*)
 126     (hide-window window)
 127     (xlib:destroy-window window))
 128   (setf *blank-window-list* nil))
 129
 130 (defmacro with-current-blank-window ((window) &body body)
 131   `(let ((,window (first *blank-window-list*)))
 132      (when ,window
 133        ,@body)))
 134
 135 (defun blank-window-fill-width ()
 136   "Current blank window fill all width screen"
 137   (with-current-blank-window (window)
 138     (setf (xlib:drawable-x window) 0
 139           (xlib:drawable-width window) (xlib:drawable-width *root*))))
 140
 141 (defun blank-window-fill-height ()
 142   "Current blank window fill all height screen"
 143   (with-current-blank-window (window)
 144     (setf (xlib:drawable-y window) 0
 145           (xlib:drawable-height window) (xlib:drawable-height *root*))))
 146
 147 (defun blank-window-down (dy)
 148   "Move current blank window down"
 149   (with-current-blank-window (window)
 150     (incf (xlib:drawable-y window) dy)))
 151
 152 (defun blank-window-right (dx)
 153   "Move current blank window right"
 154   (with-current-blank-window (window)
 155     (incf (xlib:drawable-x window) dx)))
 156
 157 (defun blank-window-inc-width (dw)
 158   "Change current blank window width"
 159   (with-current-blank-window (window)
 160     (decf (xlib:drawable-x window) dw)
 161     (incf (xlib:drawable-width window) (* dw 2))))
 162
 163 (defun blank-window-inc-height (dh)
 164   "Change current blank window height"
 165   (with-current-blank-window (window)
 166     (decf (xlib:drawable-y window) dh)
 167     (incf (xlib:drawable-height window) (* dh 2))))
 168
 169
 170 (defun select-next-blank-window ()
 171   "Select next blank window"
 172   (with-current-blank-window (window)
 173     (setf (xlib:drawable-border-width window) 0))
 174   (setf *blank-window-list* (rotate-list *blank-window-list*))
 175   (when *blank-window-show-current*
 176     (with-current-blank-window (window)
 177       (setf (xlib:drawable-border-width window) 1))))
 178
 179 (defun toggle-show-current-blank-window ()
 180   (setf *blank-window-show-current* (not *blank-window-show-current*))
 181   (with-current-blank-window (window)
 182     (setf (xlib:drawable-border-width window) (if *blank-window-show-current* 1 0))))
 183
 184 (defun remove-current-blank-window ()
 185   (let ((window (pop *blank-window-list*)))
 186     (when window
 187       (hide-window window)
 188       (xlib:destroy-window window)))
 189   (with-current-blank-window (window)
 190     (setf (xlib:drawable-border-width window) (if *blank-window-show-current* 1 0))))
 191
 192 (defun find-blank-window-under-mouse ()
 193   "Return the blank window under the mouse pointer if any"
 194   (with-x-pointer
 195     (dolist (win *blank-window-list*)
 196       (when (in-window win x y)
 197         (with-current-blank-window (window)
 198           (setf (xlib:drawable-border-width window) 0))
 199         (setf *blank-window-list* (remove win *blank-window-list* :test #'xlib:window-equal))
 200         (push win *blank-window-list*)
 201         (when *blank-window-show-current*
 202           (with-current-blank-window (window)
 203             (setf (xlib:drawable-border-width window) 1)))
 204         (return-from find-blank-window-under-mouse win)))))
 205
 206 (defun move-blank-window (window root-x root-y)
 207   "Move blank window with the mouse"
 208   (declare (ignore window))
 209   (let ((window (find-blank-window-under-mouse)))
 210     (when window
 211       (move-window window root-x root-y))))
 212
 213 (defun resize-blank-window (window root-x root-y)
 214   "Resize blank window with the mouse"
 215   (declare (ignore window))
 216   (let ((window (find-blank-window-under-mouse)))
 217     (when window
 218       (resize-window window root-x root-y))))
 219
 220 (defun hide-unhide-current-blank-window ()
 221   "Hide or unhide the current blank window"
 222   (with-current-blank-window (window)
 223     (if (window-hidden-p window)
 224         (unhide-window window)
 225         (hide-window window))))
 226
 227
 228 (defun blank-black-window ()
 229   "Open a black window. ie light of the screen"
 230   (let ((black-win (xlib:create-window :parent *root*
 231                                        :x 0 :y 0
 232                                        :width (xlib:drawable-width *root*)
 233                                        :height (xlib:drawable-height *root*)
 234                                        :background (get-color "black")
 235                                        :border-width 0
 236                                        :border (get-color "black")
 237                                        :colormap (xlib:screen-default-colormap *screen*)
 238                                        :event-mask '(:exposure))))
 239     (map-window black-win)
 240     (wait-no-key-or-button-press)
 241     (wait-a-key-or-button-press)
 242     (xlib:destroy-window black-win)
 243     (wait-no-key-or-button-press)))
 244
 245
 246
 247 (defun set-default-blank-window-keys ()
 248   ;;(define-blank-window-key ("Return") 'leave-blank-window-mode)
 249   (define-blank-window-key ("Escape") 'leave-blank-window-mode)
 250   (define-blank-window-key ("twosuperior") 'leave-blank-window-mode)
 251   (define-blank-window-key ("Return") 'create-new-blank-window)
 252   (define-blank-window-key ("BackSpace" :control) 'clear-all-blank-window)
 253   (define-blank-window-key ("Tab") 'select-next-blank-window)
 254   (define-blank-window-key ("w") 'blank-window-fill-width)
 255   (define-blank-window-key ("h") 'blank-window-fill-height)
 256   (define-blank-window-key ("Down") 'blank-window-down 5)
 257   (define-blank-window-key ("Down" :shift) 'blank-window-down 1)
 258   (define-blank-window-key ("Down" :control) 'blank-window-down 20)
 259   (define-blank-window-key ("Up") 'blank-window-down -5)
 260   (define-blank-window-key ("Up" :shift) 'blank-window-down -1)
 261   (define-blank-window-key ("Up" :control) 'blank-window-down -20)
 262   (define-blank-window-key ("Right") 'blank-window-right 5)
 263   (define-blank-window-key ("Right" :shift) 'blank-window-right 1)
 264   (define-blank-window-key ("Right" :control) 'blank-window-right 20)
 265   (define-blank-window-key ("Left") 'blank-window-right -5)
 266   (define-blank-window-key ("Left" :shift) 'blank-window-right -1)
 267   (define-blank-window-key ("Left" :control) 'blank-window-right -20)
 268   (define-blank-window-key ("c") 'toggle-show-current-blank-window)
 269   (define-blank-window-key ("p") 'blank-window-inc-width 1)
 270   (define-blank-window-key ("o") 'blank-window-inc-height 1)
 271   (define-blank-window-key ("m") 'blank-window-inc-width -1)
 272   (define-blank-window-key ("l") 'blank-window-inc-height -1)
 273   (define-blank-window-key ("Delete") 'remove-current-blank-window)
 274   (define-blank-window-key ("t") 'hide-unhide-current-blank-window)
 275   (define-blank-window-key ("Control_R") 'banish-pointer)
 276   (define-blank-window-key ("b") 'banish-pointer)
 277   (define-blank-window-key ("x") 'blank-black-window)
 278
 279   (define-blank-window-mouse (1) 'move-blank-window)
 280   (define-blank-window-mouse (2) 'create-new-blank-window)
 281   (define-blank-window-mouse (3) 'resize-blank-window))
 282
 283
 284
 285 (add-hook *binding-hook* 'set-default-blank-window-keys)
 286
 287
 288
 289 (format t "done~%")