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 ()
 109   "Create a new blank window"
 110   (with-x-pointer
 111     (push (xlib:create-window :parent *root*
 112                               :x (- x 50) :y y
 113                               :width *blank-window-width* :height *blank-window-height*
 114                               :background (get-color *blank-window-color*)
 115                               :border-width 0
 116                               :border (get-color *blank-window-border*)
 117                               :colormap (xlib:screen-default-colormap *screen*)
 118                               :event-mask '(:exposure))
 119           *blank-window-list*))
 120   (map-window (first *blank-window-list*)))
 121
 122 (defun clear-all-blank-window ()
 123   "Clear all blank window"
 124   (dolist (window *blank-window-list*)
 125     (hide-window window)
 126     (xlib:destroy-window window))
 127   (setf *blank-window-list* nil))
 128
 129 (defmacro with-current-blank-window ((window) &body body)
 130   `(let ((,window (first *blank-window-list*)))
 131      (when ,window
 132        ,@body)))
 133
 134 (defun blank-window-fill-width ()
 135   "Current blank window fill all width screen"
 136   (with-current-blank-window (window)
 137     (setf (xlib:drawable-x window) 0
 138           (xlib:drawable-width window) (xlib:drawable-width *root*))))
 139
 140 (defun blank-window-fill-height ()
 141   "Current blank window fill all height screen"
 142   (with-current-blank-window (window)
 143     (setf (xlib:drawable-y window) 0
 144           (xlib:drawable-height window) (xlib:drawable-height *root*))))
 145
 146 (defun blank-window-down (dy)
 147   "Move current blank window down"
 148   (with-current-blank-window (window)
 149     (incf (xlib:drawable-y window) dy)))
 150
 151 (defun blank-window-right (dx)
 152   "Move current blank window right"
 153   (with-current-blank-window (window)
 154     (incf (xlib:drawable-x window) dx)))
 155
 156 (defun blank-window-inc-width (dw)
 157   "Change current blank window width"
 158   (with-current-blank-window (window)
 159     (decf (xlib:drawable-x window) dw)
 160     (incf (xlib:drawable-width window) (* dw 2))))
 161
 162 (defun blank-window-inc-height (dh)
 163   "Change current blank window height"
 164   (with-current-blank-window (window)
 165     (decf (xlib:drawable-y window) dh)
 166     (incf (xlib:drawable-height window) (* dh 2))))
 167
 168
 169 (defun select-next-blank-window ()
 170   "Select next blank window"
 171   (with-current-blank-window (window)
 172     (setf (xlib:drawable-border-width window) 0))
 173   (setf *blank-window-list* (rotate-list *blank-window-list*))
 174   (when *blank-window-show-current*
 175     (with-current-blank-window (window)
 176       (setf (xlib:drawable-border-width window) 1))))
 177
 178 (defun toggle-show-current-blank-window ()
 179   (setf *blank-window-show-current* (not *blank-window-show-current*))
 180   (with-current-blank-window (window)
 181     (setf (xlib:drawable-border-width window) (if *blank-window-show-current* 1 0))))
 182
 183 (defun remove-current-blank-window ()
 184   (let ((window (pop *blank-window-list*)))
 185     (when window
 186       (hide-window window)
 187       (xlib:destroy-window window)))
 188   (with-current-blank-window (window)
 189     (setf (xlib:drawable-border-width window) (if *blank-window-show-current* 1 0))))
 190
 191 (defun place-current-blank-window (window root-x root-y)
 192   "Place the current blank window with the mouse"
 193   (declare (ignore window))
 194   (with-current-blank-window (window)
 195     (setf (xlib:drawable-x window) root-x
 196           (xlib:drawable-y window) root-y)))
 197
 198 (defun blank-black-window ()
 199   "Open a black window. ie light of the screen"
 200   (let ((black-win (xlib:create-window :parent *root*
 201                                        :x 0 :y 0
 202                                        :width (xlib:drawable-width *root*)
 203                                        :height (xlib:drawable-height *root*)
 204                                        :background (get-color "black")
 205                                        :border-width 0
 206                                        :border (get-color "black")
 207                                        :colormap (xlib:screen-default-colormap *screen*)
 208                                        :event-mask '(:exposure))))
 209     (map-window black-win)
 210     (wait-no-key-or-button-press)
 211     (wait-a-key-or-button-press)
 212     (xlib:destroy-window black-win)
 213     (wait-no-key-or-button-press)))
 214
 215
 216
 217 (defun set-default-blank-window-keys ()
 218   ;;(define-blank-window-key ("Return") 'leave-blank-window-mode)
 219   (define-blank-window-key ("Escape") 'leave-blank-window-mode)
 220   (define-blank-window-key ("twosuperior") 'leave-blank-window-mode)
 221   (define-blank-window-key ("Return") 'create-new-blank-window)
 222   (define-blank-window-key ("BackSpace" :control) 'clear-all-blank-window)
 223   (define-blank-window-key ("Tab") 'select-next-blank-window)
 224   (define-blank-window-key ("w") 'blank-window-fill-width)
 225   (define-blank-window-key ("h") 'blank-window-fill-height)
 226   (define-blank-window-key ("Down") 'blank-window-down 5)
 227   (define-blank-window-key ("Down" :shift) 'blank-window-down 1)
 228   (define-blank-window-key ("Down" :control) 'blank-window-down 20)
 229   (define-blank-window-key ("Up") 'blank-window-down -5)
 230   (define-blank-window-key ("Up" :shift) 'blank-window-down -1)
 231   (define-blank-window-key ("Up" :control) 'blank-window-down -20)
 232   (define-blank-window-key ("Right") 'blank-window-right 5)
 233   (define-blank-window-key ("Right" :shift) 'blank-window-right 1)
 234   (define-blank-window-key ("Right" :control) 'blank-window-right 20)
 235   (define-blank-window-key ("Left") 'blank-window-right -5)
 236   (define-blank-window-key ("Left" :shift) 'blank-window-right -1)
 237   (define-blank-window-key ("Left" :control) 'blank-window-right -20)
 238   (define-blank-window-key ("c") 'toggle-show-current-blank-window)
 239   (define-blank-window-key ("p") 'blank-window-inc-width 1)
 240   (define-blank-window-key ("o") 'blank-window-inc-height 1)
 241   (define-blank-window-key ("m") 'blank-window-inc-width -1)
 242   (define-blank-window-key ("l") 'blank-window-inc-height -1)
 243   (define-blank-window-key ("Delete") 'remove-current-blank-window)
 244   (define-blank-window-key ("Control_R") 'banish-pointer)
 245   (define-blank-window-key ("b") 'banish-pointer)
 246   (define-blank-window-key ("x") 'blank-black-window)
 247
 248   (define-blank-window-mouse (1) 'place-current-blank-window))
 249
 250
 251
 252 (add-hook *binding-hook* 'set-default-blank-window-keys)
 253
 254
 255
 256 (format t "done~%")