src/clfswm-internal.lisp

   1 ;;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2010 Philippe Brochard <hocwp@free.fr>
   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 ;;; --------------------------------------------------------------------------
  25
  26 (in-package :clfswm)
  27
  28
  29
  30 ;;; Conversion functions
  31 ;;; Float -> Pixel conversion
  32 (defun x-fl->px (x parent)
  33   "Convert float X coordinate to pixel"
  34   (round (+ (* x (frame-rw parent)) (frame-rx parent))))
  35
  36 (defun y-fl->px (y parent)
  37   "Convert float Y coordinate to pixel"
  38   (round (+ (* y (frame-rh parent)) (frame-ry parent))))
  39
  40 (defun w-fl->px (w parent)
  41   "Convert float Width coordinate to pixel"
  42   (round (* w (frame-rw parent))))
  43
  44 (defun h-fl->px (h parent)
  45   "Convert float Height coordinate to pixel"
  46   (round (* h (frame-rh parent))))
  47
  48 ;;; Pixel -> Float conversion
  49 (defun x-px->fl (x parent)
  50   "Convert pixel X coordinate to float"
  51   (/ (- x (frame-rx parent)) (frame-rw parent)))
  52
  53 (defun y-px->fl (y parent)
  54   "Convert pixel Y coordinate to float"
  55   (/ (- y (frame-ry parent)) (frame-rh parent)))
  56
  57 (defun w-px->fl (w parent)
  58   "Convert pixel Width coordinate to float"
  59   (/ w (frame-rw parent)))
  60
  61 (defun h-px->fl (h parent)
  62   "Convert pixel Height coordinate to float"
  63   (/ h (frame-rh parent)))
  64
  65
  66
  67 (defgeneric frame-p (frame))
  68 (defmethod frame-p ((frame frame))
  69   (declare (ignore frame))
  70   t)
  71 (defmethod frame-p (frame)
  72   (declare (ignore frame))
  73   nil)
  74
  75
  76
  77 ;;; in-*: Find if point (x,y) is in frame, window or child
  78 (defun in-frame (frame x y)
  79   (and (frame-p frame)
  80        (<= (frame-rx frame) x (+ (frame-rx frame) (frame-rw frame)))
  81        (<= (frame-ry frame) y (+ (frame-ry frame) (frame-rh frame)))))
  82
  83 (defun in-window (window x y)
  84   (and (xlib:window-p window)
  85        (<= (xlib:drawable-x window) x (+ (xlib:drawable-x window) (xlib:drawable-width window)))
  86        (<= (xlib:drawable-y window) y (+ (xlib:drawable-y window) (xlib:drawable-height window)))))
  87
  88 (defgeneric in-child (child x y))
  89
  90 (defmethod in-child ((child frame) x y)
  91   (in-frame child x y))
  92 (defmethod in-child ((child xlib:window) x y)
  93   (in-window child x y))
  94 (defmethod in-child (child x y)
  95   (declare (ignore child x y))
  96   nil)
  97
  98
  99
 100
 101 (defun frame-selected-child (frame)
 102   (when (frame-p frame)
 103     (with-slots (child selected-pos) frame
 104       (let ((len (length child)))
 105         (cond ((minusp selected-pos) (setf selected-pos 0))
 106               ((>= selected-pos len) (setf selected-pos (max (1- len) 0)))))
 107       (nth selected-pos child))))
 108
 109
 110
 111
 112
 113 (defgeneric child-equal-p (child-1 child-2))
 114
 115 (defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window))
 116   (xlib:window-equal child-1 child-2))
 117
 118 (defmethod child-equal-p ((child-1 frame) (child-2 frame))
 119   (equal child-1 child-2))
 120
 121 (defmethod child-equal-p (child-1 child-2)
 122   (declare (ignore child-1 child-2))
 123   nil)
 124
 125
 126 (declaim (inline child-member child-remove child-position))
 127
 128 (defun child-member (child list)
 129   (member child list :test #'child-equal-p))
 130
 131 (defun child-remove (child list)
 132   (remove child list :test #'child-equal-p))
 133
 134 (defun child-position (child list)
 135   (position child list :test #'child-equal-p))
 136
 137
 138
 139 ;;; Frame data manipulation functions
 140 (defun frame-data-slot (frame slot)
 141   "Return the value associated to data slot"
 142   (when (frame-p frame)
 143     (second (assoc slot (frame-data frame)))))
 144
 145 (defun set-frame-data-slot (frame slot value)
 146   "Set the value associated to data slot"
 147   (when (frame-p frame)
 148     (with-slots (data) frame
 149       (setf data (remove (assoc slot data) data))
 150       (push (list slot value) data))
 151     value))
 152
 153 (defsetf frame-data-slot set-frame-data-slot)
 154
 155
 156 (defun remove-frame-data-slot (frame slot)
 157   "Remove a slot in frame data slots"
 158   (when (frame-p frame)
 159     (with-slots (data) frame
 160       (setf data (remove (assoc slot data) data)))))
 161
 162
 163
 164 (defun managed-window-p (window frame)
 165   "Return t only if window is managed by frame"
 166   (if (frame-p frame)
 167       (with-slots ((managed forced-managed-window)
 168                    (unmanaged forced-unmanaged-window)) frame
 169         (and (xlib:window-p window)
 170              (not (child-member window unmanaged))
 171              (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p))
 172              (or (member :all (frame-managed-type frame))
 173                  (member (window-type window) (frame-managed-type frame))
 174                  (child-member window managed)
 175                  (member (xlib:wm-name window) managed :test #'string-equal-p))))
 176       t))
 177
 178
 179 (defun never-managed-window-p (window)
 180   (when (xlib:window-p window)
 181     (dolist (type *never-managed-window-list*)
 182       (when (funcall (first type) window)
 183         (return (values t (second type)))))))
 184
 185
 186
 187 (defgeneric child-name (child))
 188
 189 (defmethod child-name ((child xlib:window))
 190   (xlib:wm-name child))
 191
 192 (defmethod child-name ((child frame))
 193   (frame-name child))
 194
 195 (defmethod child-name (child)
 196   (declare (ignore child))
 197   "???")
 198
 199
 200 (defgeneric set-child-name (child name))
 201
 202 (defmethod set-child-name ((child xlib:window) name)
 203   (setf (xlib:wm-name child) name))
 204
 205 (defmethod set-child-name ((child frame) name)
 206   (setf (frame-name child) name))
 207
 208 (defmethod set-child-name (child name)
 209   (declare (ignore child name)))
 210
 211 (defsetf child-name set-child-name)
 212
 213
 214
 215
 216 (defgeneric child-fullname (child))
 217
 218 (defmethod child-fullname ((child xlib:window))
 219   (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?")))
 220
 221 (defmethod child-fullname ((child frame))
 222   (aif (frame-name child)
 223        (format nil "~A (Frame ~A)" it (frame-number child))
 224        (format nil "Frame ~A" (frame-number child))))
 225
 226 (defmethod child-fullname (child)
 227   (declare (ignore child))
 228   "???")
 229
 230
 231 (defgeneric child-x (child))
 232 (defmethod child-x ((child xlib:window))
 233   (xlib:drawable-x child))
 234 (defmethod child-x ((child frame))
 235   (frame-rx child))
 236
 237 (defgeneric child-y (child))
 238 (defmethod child-y ((child xlib:window))
 239   (xlib:drawable-y child))
 240 (defmethod child-y ((child frame))
 241   (frame-ry child))
 242
 243 (defgeneric child-width (child))
 244 (defmethod child-width ((child xlib:window))
 245   (xlib:drawable-width child))
 246 (defmethod child-width ((child frame))
 247   (frame-rw child))
 248
 249 (defgeneric child-height (child))
 250 (defmethod child-height ((child xlib:window))
 251   (xlib:drawable-height child))
 252 (defmethod child-height ((child frame))
 253   (frame-rh child))
 254
 255
 256
 257
 258
 259 (defgeneric rename-child (child name))
 260
 261 (defmethod rename-child ((child frame) name)
 262   (setf (frame-name child) name)
 263   (display-frame-info child))
 264
 265 (defmethod rename-child ((child xlib:window) name)
 266   (setf (xlib:wm-name child) name))
 267
 268 (defmethod rename-child (child name)
 269   (declare (ignore child name)))
 270
 271
 272 (defun is-in-current-child-p (child)
 273   (and (frame-p *current-child*)
 274        (child-member child (frame-child *current-child*))))
 275
 276
 277
 278 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
 279 (defmacro with-all-children ((root child) &body body)
 280   (let ((rec (gensym))
 281         (sub-child (gensym)))
 282     `(block nil
 283        (labels ((,rec (,child)
 284                   ,@body
 285                   (when (frame-p ,child)
 286                     (dolist (,sub-child (reverse (frame-child ,child)))
 287                       (,rec ,sub-child)))))
 288          (,rec ,root)))))
 289
 290
 291 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
 292 (defmacro with-all-children-reversed ((root child) &body body)
 293   (let ((rec (gensym))
 294         (sub-child (gensym)))
 295     `(block nil
 296        (labels ((,rec (,child)
 297                   ,@body
 298                   (when (frame-p ,child)
 299                     (dolist (,sub-child (frame-child ,child))
 300                       (,rec ,sub-child)))))
 301          (,rec ,root)))))
 302
 303
 304 ;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
 305 (defmacro with-all-frames ((root frame) &body body)
 306   (let ((rec (gensym))
 307         (child (gensym)))
 308     `(block nil
 309        (labels ((,rec (,frame)
 310                   (when (frame-p ,frame)
 311                     ,@body
 312                     (dolist (,child (reverse (frame-child ,frame)))
 313                       (,rec ,child)))))
 314          (,rec ,root)))))
 315
 316
 317 ;; (with-all-windows (*root-frame* window) (print window))
 318 (defmacro with-all-windows ((root window) &body body)
 319   (let ((rec (gensym))
 320         (child (gensym)))
 321     `(block nil
 322        (labels ((,rec (,window)
 323                   (when (xlib:window-p ,window)
 324                     ,@body)
 325                   (when (frame-p ,window)
 326                     (dolist (,child (reverse (frame-child ,window)))
 327                       (,rec ,child)))))
 328          (,rec ,root)))))
 329
 330
 331
 332 ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
 333 (defmacro with-all-windows-frames ((root child) body-window body-frame)
 334   (let ((rec (gensym))
 335         (sub-child (gensym)))
 336     `(block nil
 337        (labels ((,rec (,child)
 338                   (typecase ,child
 339                     (xlib:window ,body-window)
 340                     (frame ,body-frame
 341                            (dolist (,sub-child (reverse (frame-child ,child)))
 342                              (,rec ,sub-child))))))
 343          (,rec ,root)))))
 344
 345 (defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame)
 346   (let ((rec (gensym))
 347         (sub-child (gensym)))
 348     `(block nil
 349        (labels ((,rec (,child ,parent)
 350                   (typecase ,child
 351                     (xlib:window ,body-window)
 352                     (frame ,body-frame
 353                            (dolist (,sub-child (reverse (frame-child ,child)))
 354                              (,rec ,sub-child ,child))))))
 355          (,rec ,root nil)))))
 356
 357
 358
 359 (defun frame-find-free-number ()
 360   (let ((all-numbers nil))
 361     (with-all-frames (*root-frame* frame)
 362       (pushnew (frame-number frame) all-numbers))
 363     (find-free-number all-numbers)))
 364
 365
 366 (defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys)
 367   (let* ((window (xlib:create-window :parent *root*
 368                                      :x 0
 369                                      :y 0
 370                                      :width 200
 371                                      :height 200
 372                                      :background (get-color *frame-background*)
 373                                      :colormap (xlib:screen-default-colormap *screen*)
 374                                      :border-width 1
 375                                      :border (get-color *color-selected*)
 376                                      :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window)))
 377          (gc (xlib:create-gcontext :drawable window
 378                                    :foreground (get-color *frame-foreground*)
 379                                    :background (get-color *frame-background*)
 380                                    :font *default-font*
 381                                    :line-style :solid)))
 382     (apply #'make-instance 'frame :number number :window window :gc gc args)))
 383
 384
 385
 386
 387
 388 (defun add-frame (frame parent)
 389   (push frame (frame-child parent))
 390   frame)
 391
 392
 393 (defun place-frame (frame parent prx pry prw prh)
 394   "Place a frame from real (pixel) coordinates"
 395   (when (and (frame-p frame) (frame-p parent))
 396     (with-slots (window x y w h) frame
 397       (setf (xlib:drawable-x window) prx
 398             (xlib:drawable-y window) pry
 399             (xlib:drawable-width window) prw
 400             (xlib:drawable-height window) prh
 401             x (x-px->fl prx parent)
 402             y (y-px->fl pry parent)
 403             w (w-px->fl prw parent)
 404             h (h-px->fl prh parent))
 405       (xlib:display-finish-output *display*))))
 406
 407 (defun fixe-real-size (frame parent)
 408   "Fixe real (pixel) coordinates in float coordinates"
 409   (when (frame-p frame)
 410     (with-slots (x y w h rx ry rw rh) frame
 411       (setf x (x-px->fl rx parent)
 412             y (y-px->fl ry parent)
 413             w (w-px->fl rw parent)
 414             h (h-px->fl rh parent)))))
 415
 416 (defun fixe-real-size-current-child ()
 417   "Fixe real (pixel) coordinates in float coordinates for children in the current child"
 418   (when (frame-p *current-child*)
 419     (dolist (child (frame-child *current-child*))
 420       (fixe-real-size child *current-child*))))
 421
 422
 423
 424
 425 (defun find-child (to-find root)
 426   "Find to-find in root or in its children"
 427   (with-all-children (root child)
 428     (when (child-equal-p child to-find)
 429       (return-from find-child t))))
 430
 431
 432
 433 (defmacro with-find-in-all-frames (test &optional return-value)
 434   `(let (ret)
 435      (block return-block
 436        (with-all-frames (root frame)
 437          (when ,test
 438            (if first-foundp
 439                (return-from return-block (or ,return-value frame))
 440                (setf ret frame))))
 441        (or ,return-value ret))))
 442
 443 (defun find-parent-frame  (to-find &optional (root *root-frame*) first-foundp)
 444   "Return the parent frame of to-find"
 445   (with-find-in-all-frames
 446       (child-member to-find (frame-child frame))))
 447
 448 (defun find-frame-window (window &optional (root *root-frame*) first-foundp)
 449   "Return the frame with the window window"
 450   (with-find-in-all-frames
 451       (xlib:window-equal window (frame-window frame))))
 452
 453 (defun find-frame-by-name (name &optional (root *root-frame*) first-foundp)
 454   "Find a frame from its name"
 455   (when name
 456     (with-find-in-all-frames
 457         (string-equal name (frame-name frame)))))
 458
 459 (defun find-frame-by-number (number &optional (root *root-frame*) first-foundp)
 460   "Find a frame from its number"
 461   (when (numberp number)
 462     (with-find-in-all-frames
 463         (= number (frame-number frame)))))
 464
 465
 466 (defun find-child-in-parent (child base)
 467   "Return t if child is in base or in its parents"
 468   (labels ((rec (base)
 469              (when (child-equal-p child base)
 470                (return-from find-child-in-parent t))
 471              (let ((parent (find-parent-frame base)))
 472                (when parent
 473                  (rec parent)))))
 474     (rec base)))
 475
 476
 477
 478
 479 (defun get-all-windows (&optional (root *root-frame*))
 480   "Return all windows in root and in its children"
 481   (let ((acc nil))
 482     (with-all-windows (root window)
 483       (push window acc))
 484     acc))
 485
 486
 487 (defun get-hidden-windows ()
 488   "Return all hiddens windows"
 489   (let ((all-windows (get-all-windows))
 490         (hidden-windows (remove-if-not #'window-hidden-p
 491                                        (copy-list (xlib:query-tree *root*)))))
 492     (set-difference hidden-windows all-windows)))
 493
 494
 495
 496 ;;; Current window utilities
 497 (defun get-current-window ()
 498   (typecase *current-child*
 499     (xlib:window  *current-child*)
 500     (frame (frame-selected-child *current-child*))))
 501
 502 (defmacro with-current-window (&body body)
 503   "Bind 'window' to the current window"
 504   `(let ((window (get-current-window)))
 505       (when (xlib:window-p window)
 506         ,@body)))
 507
 508
 509
 510
 511
 512 (defun display-frame-info (frame)
 513   (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
 514     (with-slots (name number gc window child hidden-children) frame
 515       (setf (xlib:gcontext-background gc) (get-color *frame-background*)
 516             (xlib:window-background window) (get-color *frame-background*))
 517       (clear-pixmap-buffer window gc)
 518       (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-equal-p frame *current-root*)
 519                                                               (child-equal-p frame *current-child*))
 520                                                          *frame-foreground-root* *frame-foreground*)))
 521       (xlib:draw-glyphs *pixmap-buffer* gc 5 dy
 522                         (format nil "Frame: ~A~A"
 523                                 number
 524                                 (if name  (format nil " - ~A" name) "")))
 525       (let ((pos dy))
 526         (when (child-equal-p frame *current-root*)
 527           (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 528                             (format nil "  ~A hidden windows" (length (get-hidden-windows))))
 529           (when *child-selection*
 530             (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 531                               (with-output-to-string (str)
 532                                 (format str "  Selection: ")
 533                                 (dolist (child *child-selection*)
 534                                   (typecase child
 535                                     (xlib:window (format str "  ~A " (xlib:wm-name child)))
 536                                     (frame (format str "  frame:~A[~A] " (frame-number child)
 537                                                    (aif (frame-name child) it "")))))))))
 538         (dolist (ch child)
 539           (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 540                             (format nil "  ~A" (ensure-printable (child-fullname ch)))))
 541         (setf (xlib:gcontext-foreground gc) (get-color *frame-foreground-hidden*))
 542         (dolist (ch hidden-children)
 543           (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 544                             (format nil "  ~A - hidden" (ensure-printable (child-fullname ch))))))
 545       (copy-pixmap-buffer window gc))))
 546
 547
 548 (defun display-all-frame-info (&optional (root *current-root*))
 549   (with-all-frames (root frame)
 550     (display-frame-info frame)))
 551
 552
 553
 554
 555
 556 (defun get-parent-layout (child parent)
 557   (if (frame-p parent)
 558       (aif (frame-layout parent)
 559            (funcall it child parent)
 560            (no-layout child parent))
 561       (get-fullscreen-size)))
 562
 563
 564
 565 (defgeneric adapt-child-to-parent (child parent))
 566
 567 (defmethod adapt-child-to-parent ((window xlib:window) parent)
 568   (when (managed-window-p window parent)
 569     (multiple-value-bind (nx ny nw nh)
 570         (get-parent-layout window parent)
 571       (setf nw (max nw 1)  nh (max nh 1))
 572       (let ((change (or (/= (xlib:drawable-x window) nx)
 573                         (/= (xlib:drawable-y window) ny)
 574                         (/= (xlib:drawable-width window) nw)
 575                         (/= (xlib:drawable-height window) nh))))
 576         (setf (xlib:drawable-x window) nx
 577               (xlib:drawable-y window) ny
 578               (xlib:drawable-width window) nw
 579               (xlib:drawable-height window) nh)
 580         (xlib:display-finish-output *display*)
 581         change))))
 582
 583
 584 (defmethod adapt-child-to-parent ((frame frame) parent)
 585   (multiple-value-bind (nx ny nw nh)
 586       (get-parent-layout frame parent)
 587     (with-slots (rx ry rw rh window) frame
 588       (setf rx nx  ry ny
 589             rw (max nw 1)
 590             rh (max nh 1))
 591       (let ((change (or (/= (xlib:drawable-x window) rx)
 592                         (/= (xlib:drawable-y window) ry)
 593                         (/= (xlib:drawable-width window) rw)
 594                         (/= (xlib:drawable-height window) rh))))
 595         (setf (xlib:drawable-x window) rx
 596               (xlib:drawable-y window) ry
 597               (xlib:drawable-width window) rw
 598               (xlib:drawable-height window) rh)
 599         (xlib:display-finish-output *display*)
 600         change))))
 601
 602 (defmethod adapt-child-to-parent (child parent)
 603   (declare (ignore child parent))
 604   nil)
 605
 606
 607
 608
 609 (defgeneric show-child (child parent raise-p))
 610
 611 (defmethod show-child ((frame frame) parent raise-p)
 612   (declare (ignore parent))
 613   (with-slots (window show-window-p) frame
 614     (if show-window-p
 615         (when (or *show-root-frame-p* (not (child-equal-p frame *current-root*)))
 616           (map-window window)
 617           (when raise-p
 618             (raise-window window))
 619           (display-frame-info frame))
 620         (hide-window window))))
 621
 622
 623
 624 (defun hide-unmanager-window-p (parent)
 625   (let ((action (frame-data-slot parent :unmanaged-window-action)))
 626     (case action
 627       (:hide t)
 628       (:show nil)
 629       (t *hide-unmanaged-window*))))
 630
 631
 632 (defmethod show-child ((window xlib:window) parent raise-p)
 633   (if (or (managed-window-p window parent)
 634           (not (hide-unmanager-window-p parent))
 635           (child-equal-p parent *current-child*))
 636       (progn
 637         (map-window window)
 638         (when raise-p
 639           (raise-window window)))
 640       (hide-window window)))
 641
 642 (defmethod show-child (child parent raise-p)
 643   (declare (ignore child parent raise-p))
 644   ())
 645
 646
 647 (defgeneric hide-child (child))
 648
 649 (defmethod hide-child ((frame frame))
 650   (with-slots (window) frame
 651     (xlib:unmap-window window)))
 652
 653 (defmethod hide-child ((window xlib:window))
 654   (hide-window window))
 655
 656 (defmethod hide-child (child)
 657   (declare (ignore child))
 658   ())
 659
 660
 661
 662
 663 (defgeneric child-coordinates (child))
 664
 665 (defmethod child-coordinates ((frame frame))
 666   (values (frame-rx frame)
 667           (frame-ry frame)
 668           (+ (frame-rx frame) (frame-rw frame))
 669           (+ (frame-ry frame) (frame-rh frame))))
 670
 671 (defmethod child-coordinates ((window xlib:window))
 672   (values (xlib:drawable-x window)
 673           (xlib:drawable-y window)
 674           (+ (xlib:drawable-x window) (xlib:drawable-width window))
 675           (+ (xlib:drawable-y window) (xlib:drawable-height window))))
 676
 677 (defmethod child-coordinates (child)
 678   (declare (ignore child))
 679   (values 0 0 1 1))
 680
 681
 682
 683 (defgeneric select-child (child selected))
 684
 685 (defmethod select-child ((frame frame) selected)
 686   (when (and (frame-p frame) (frame-window frame))
 687     (setf (xlib:window-border (frame-window frame))
 688           (get-color (cond ((equal selected :maybe) *color-maybe-selected*)
 689                            ((equal selected nil) *color-unselected*)
 690                            (selected *color-selected*))))))
 691
 692 (defmethod select-child ((window xlib:window) selected)
 693   (setf (xlib:window-border window)
 694         (get-color (cond ((equal selected :maybe) *color-maybe-selected*)
 695                          ((equal selected nil) *color-unselected*)
 696                          (selected *color-selected*)))))
 697
 698 (defmethod select-child (child selected)
 699   (declare (ignore child selected))
 700   ())
 701
 702 (defun select-current-frame (selected)
 703   (select-child *current-child* selected))
 704
 705 (defun unselect-all-frames ()
 706   (with-all-children (*current-root* child)
 707     (select-child child nil)))
 708
 709
 710
 711 (defun set-focus-to-current-child ()
 712   (labels ((rec (child)
 713              (typecase child
 714                (xlib:window (focus-window child))
 715                (frame (rec (frame-selected-child child))))))
 716     (no-focus)
 717     (rec *current-child*)))
 718
 719
 720
 721
 722 (defun raise-p-list (children)
 723   (let ((acc nil))
 724     (labels ((rec (list)
 725                (when list
 726                  (multiple-value-bind (xo1 yo1 xo2 yo2)
 727                      (child-coordinates (first list))
 728                    (push (dolist (c (rest list) t)
 729                            (multiple-value-bind (x1 y1 x2 y2)
 730                                (child-coordinates c)
 731                              (when (and (<= x1 xo1)
 732                                         (>= x2 xo2)
 733                                         (<= y1 yo1)
 734                                         (>= y2 yo2))
 735                                (return nil))))
 736                          acc))
 737                  (rec (rest list)))))
 738       (rec children)
 739       (nreverse acc))))
 740
 741
 742
 743 (defun show-all-children (&optional (display-child *current-child*))
 744   "Show all children from *current-root*. Start the effective display
 745 only for display-child and its children"
 746   (let ((geometry-change nil))
 747     (labels ((rec-geom (root parent selected-p selected-parent-p)
 748                (when (adapt-child-to-parent root parent)
 749                  (setf geometry-change t))
 750                (select-child root (cond ((child-equal-p root *current-child*) t)
 751                                         ((and selected-p selected-parent-p) :maybe)
 752                                         (t nil)))
 753                (when (frame-p root)
 754                  (let ((selected-child (frame-selected-child root)))
 755                    (dolist (child (reverse (frame-child root)))
 756                      (rec-geom child root (child-equal-p child selected-child) (and selected-p selected-parent-p))))))
 757              (rec (root parent raise-p)
 758                (show-child root parent raise-p)
 759                (when (frame-p root)
 760                  (let ((reversed-children (reverse (frame-child root))))
 761                    (loop for child in reversed-children
 762                       for c-raise-p in (raise-p-list reversed-children)
 763                       do (rec child root (and c-raise-p
 764                                               (or (null parent) raise-p))))))))
 765       (rec-geom *current-root* nil t t)
 766       (rec display-child nil nil)
 767       (set-focus-to-current-child)
 768       geometry-change)))
 769
 770
 771
 772 (defun hide-all-children (root)
 773   "Hide all root children"
 774   (when (frame-p root)
 775     (dolist (child (frame-child root))
 776       (hide-all child))))
 777
 778 (defun hide-all (root)
 779   "Hide root and all its children"
 780   (hide-child root)
 781   (hide-all-children root))
 782
 783
 784
 785
 786
 787 (defun focus-child (child parent)
 788   "Focus child - Return true if something has change"
 789   (when (and (frame-p parent)
 790              (child-member child (frame-child parent)))
 791     (when (not (child-equal-p child (frame-selected-child parent)))
 792       (with-slots ((parent-child child) selected-pos) parent
 793         (setf parent-child (nth-insert selected-pos child (child-remove child parent-child))))
 794       t)))
 795
 796 (defun focus-child-rec (child parent)
 797   "Focus child and its parents - Return true if something has change"
 798   (let ((change nil))
 799     (labels ((rec (child parent)
 800                (when (focus-child child parent)
 801                  (setf change t))
 802                (when parent
 803                  (rec parent (find-parent-frame parent)))))
 804       (rec child parent))
 805     change))
 806
 807
 808 (defun set-current-child-generic (child)
 809   (unless (child-equal-p *current-child* child)
 810     (setf *current-child* child)
 811     t))
 812
 813 (defgeneric set-current-child (child parent window-parent))
 814
 815 (defmethod set-current-child ((child xlib:window) parent window-parent)
 816   (set-current-child-generic (if window-parent parent child)))
 817
 818 (defmethod set-current-child ((child frame) parent window-parent)
 819   (declare (ignore parent window-parent))
 820   (set-current-child-generic child))
 821
 822 (defmethod set-current-child (child parent window-parent)
 823   (declare (ignore child parent window-parent))
 824   ())
 825
 826
 827 (defun set-current-root (parent window-parent)
 828   "Set current root if parent is not in current root"
 829   (when (and window-parent (not (find-child parent *current-root*)))
 830     (setf *current-root* parent)))
 831
 832
 833 (defun focus-all-children (child parent &optional (window-parent t))
 834   "Focus child and its parents -
 835 For window: set current child to window or its parent according to window-parent"
 836   (let ((new-focus (focus-child-rec child parent))
 837         (new-current-child (set-current-child child parent window-parent))
 838         (new-root (set-current-root parent window-parent)))
 839     (or new-focus new-current-child new-root)))
 840
 841
 842
 843
 844 (defun select-next-level ()
 845   "Select the next level in frame"
 846   (select-current-frame :maybe)
 847   (when (frame-p *current-child*)
 848     (awhen (frame-selected-child *current-child*)
 849       (setf *current-child* it)))
 850   (show-all-children))
 851
 852 (defun select-previous-level ()
 853   "Select the previous level in frame"
 854   (unless (child-equal-p *current-child* *current-root*)
 855     (select-current-frame :maybe)
 856     (awhen (find-parent-frame *current-child*)
 857       (setf *current-child* it))
 858     (show-all-children)))
 859
 860
 861
 862 (defun enter-frame ()
 863   "Enter in the selected frame - ie make it the root frame"
 864   (hide-all *current-root*)
 865   (setf *current-root* *current-child*)
 866   (show-all-children *current-root*))
 867
 868 (defun leave-frame ()
 869   "Leave the selected frame - ie make its parent the root frame"
 870   (hide-all *current-root*)
 871   (awhen (find-parent-frame *current-root*)
 872     (when (frame-p it)
 873       (setf *current-root* it)))
 874   (show-all-children *current-root*))
 875
 876
 877 ;;; Other actions (select-next-child, select-next-brother...) are in
 878 ;;; clfswm-circulate-mode.lisp
 879
 880
 881
 882 (defun frame-lower-child ()
 883   "Lower the child in the current frame"
 884   (when (frame-p *current-child*)
 885     (with-slots (child selected-pos) *current-child*
 886       (unless (>= selected-pos (length child))
 887         (when (nth (1+ selected-pos) child)
 888           (rotatef (nth selected-pos child)
 889                    (nth (1+ selected-pos) child)))
 890         (incf selected-pos)))
 891     (show-all-children)))
 892
 893
 894 (defun frame-raise-child ()
 895   "Raise the child in the current frame"
 896   (when (frame-p *current-child*)
 897     (with-slots (child selected-pos) *current-child*
 898       (unless (< selected-pos 1)
 899         (when (nth (1- selected-pos) child)
 900           (rotatef (nth selected-pos child)
 901                    (nth (1- selected-pos) child)))
 902         (decf selected-pos)))
 903     (show-all-children)))
 904
 905
 906 (defun frame-select-next-child ()
 907   "Select the next child in the current frame"
 908   (when (frame-p *current-child*)
 909     (with-slots (child selected-pos) *current-child*
 910       (unless (>= selected-pos (length child))
 911         (incf selected-pos)))
 912     (show-all-children)))
 913
 914
 915 (defun frame-select-previous-child ()
 916   "Select the previous child in the current frame"
 917   (when (frame-p *current-child*)
 918     (with-slots (child selected-pos) *current-child*
 919       (unless (< selected-pos 1)
 920         (decf selected-pos)))
 921     (show-all-children)))
 922
 923
 924
 925 (defun switch-to-root-frame (&key (show-later nil))
 926   "Switch to the root frame"
 927   (hide-all *current-root*)
 928   (setf *current-root* *root-frame*)
 929   (unless show-later
 930     (show-all-children *current-root*)))
 931
 932 (defun switch-and-select-root-frame (&key (show-later nil))
 933   "Switch and select the root frame"
 934   (hide-all *current-root*)
 935   (setf *current-root* *root-frame*)
 936   (setf *current-child* *current-root*)
 937   (unless show-later
 938     (show-all-children *current-root*)))
 939
 940
 941 (defun toggle-show-root-frame ()
 942   "Show/Hide the root frame"
 943   (hide-all *current-root*)
 944   (setf *show-root-frame-p* (not *show-root-frame-p*))
 945   (show-all-children *current-root*))
 946
 947
 948 (defun remove-child-in-frame (child frame)
 949   "Remove the child in frame"
 950   (when (frame-p frame)
 951     (setf (frame-child frame) (child-remove child (frame-child frame)))))
 952
 953 (defun remove-child-in-frames (child root)
 954   "Remove child in the frame root and in all its children"
 955   (with-all-frames (root frame)
 956     (remove-child-in-frame child frame)))
 957
 958
 959 (defun remove-child-in-all-frames (child)
 960   "Remove child in all frames from *root-frame*"
 961   (when (child-equal-p child *current-root*)
 962     (setf *current-root* (find-parent-frame child)))
 963   (when (child-equal-p child *current-child*)
 964     (setf *current-child* *current-root*))
 965   (remove-child-in-frames child *root-frame*))
 966
 967
 968 (defun delete-child-in-frames (child root)
 969   "Delete child in the frame root and in all its children
 970 Warning:frame window and gc are freeed."
 971   (with-all-frames (root frame)
 972     (remove-child-in-frame child frame)
 973     (unless (find-frame-window (frame-window frame))
 974       (awhen (frame-gc frame) (xlib:free-gcontext it) (setf it nil))
 975       (awhen (frame-window frame) (xlib:destroy-window it) (setf it nil))))
 976   (when (xlib:window-p child)
 977     (netwm-remove-in-client-list child)))
 978
 979
 980 (defun delete-child-in-all-frames (child)
 981   "Delete child in all frames from *root-frame*"
 982   (when (child-equal-p child *current-root*)
 983     (setf *current-root* (find-parent-frame child)))
 984   (when (child-equal-p child *current-child*)
 985     (setf *current-child* *current-root*))
 986   (delete-child-in-frames child *root-frame*))
 987
 988
 989 (defun delete-child-and-children-in-frames (child root &optional (close-methode 'delete-window))
 990   "Delete child and its children in the frame root and in all its children
 991 Warning:frame window and gc are freeed."
 992   (when (and (frame-p child) (frame-child child))
 993     (dolist (ch (frame-child child))
 994       (delete-child-and-children-in-frames ch root close-methode)))
 995   (delete-child-in-frames child root)
 996   (when (xlib:window-p child)
 997     (funcall close-methode child)))
 998
 999 (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window))
1000   "Delete child and its children in all frames from *root-frame*"
1001   (when (child-equal-p child *current-root*)
1002     (setf *current-root* (find-parent-frame child)))
1003   (when (child-equal-p child *current-child*)
1004     (setf *current-child* *current-root*))
1005   (delete-child-and-children-in-frames child *root-frame* close-methode))
1006
1007
1008
1009 (defun place-window-from-hints (window)
1010   "Place a window from its hints"
1011   (let* ((hints (xlib:wm-normal-hints window))
1012          (min-width (or (and hints (xlib:wm-size-hints-min-width hints)) 0))
1013          (min-height (or (and hints (xlib:wm-size-hints-min-height hints)) 0))
1014          (max-width (or (and hints (xlib:wm-size-hints-max-width hints)) (xlib:drawable-width *root*)))
1015          (max-height (or (and hints (xlib:wm-size-hints-max-height hints)) (xlib:drawable-height *root*)))
1016          (rwidth (or (and hints (or (xlib:wm-size-hints-width hints) (xlib:wm-size-hints-base-width hints)))
1017                      (xlib:drawable-width window)))
1018          (rheight (or (and hints (or (xlib:wm-size-hints-height hints) (xlib:wm-size-hints-base-height hints)))
1019                       (xlib:drawable-height window))))
1020     (setf (xlib:drawable-width window) (min (max min-width rwidth *default-window-width*) max-width)
1021           (xlib:drawable-height window) (min (max min-height rheight *default-window-height*) max-height))
1022     (setf (xlib:drawable-x window) (truncate (/ (- (xlib:screen-width *screen*) (+ (xlib:drawable-width window) 2)) 2))
1023           (xlib:drawable-y window) (truncate (/ (- (xlib:screen-height *screen*) (+ (xlib:drawable-height window) 2)) 2)))
1024     (xlib:display-finish-output *display*)))
1025
1026
1027
1028 (defun do-all-frames-nw-hook (window)
1029   "Call nw-hook of each frame."
1030   (catch 'nw-hook-loop
1031     (let ((found nil))
1032       (with-all-frames (*root-frame* frame)
1033         (awhen (frame-nw-hook frame)
1034           (setf found (call-hook it (list frame window)))))
1035       found)))
1036
1037
1038
1039 (defun process-new-window (window)
1040   "When a new window is created (or when we are scanning initial
1041 windows), this function dresses the window up and gets it ready to be
1042 managed."
1043   (setf (xlib:window-event-mask window) *window-events*)
1044   (set-window-state window +normal-state+)
1045   (setf (xlib:drawable-border-width window) (case (window-type window)
1046                                               (:normal 1)
1047                                               (:maxsize 1)
1048                                               (:transient 1)
1049                                               (t 1)))
1050   (grab-all-buttons window)
1051   (unless (never-managed-window-p window)
1052     (unless (do-all-frames-nw-hook window)
1053       (call-hook *default-nw-hook* (list *root-frame* window))))
1054   (netwm-add-in-client-list window))
1055
1056
1057
1058
1059 (defun hide-existing-windows (screen)
1060   "Hide all existing windows in screen"
1061   (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1062     (hide-window win)))
1063
1064 (defun process-existing-windows (screen)
1065   "Windows present when clfswm starts up must be absorbed by clfswm."
1066   (setf *in-process-existing-windows* t)
1067   (let ((id-list nil)
1068         (all-windows (get-all-windows)))
1069     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1070       (unless (child-member win all-windows)
1071         (let ((map-state (xlib:window-map-state win))
1072               (wm-state (window-state win)))
1073           (unless (or (eql (xlib:window-override-redirect win) :on)
1074                       (eql win *no-focus-window*))
1075             (when (or (eql map-state :viewable)
1076                       (eql wm-state +iconic-state+))
1077               (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win)
1078               (unhide-window win)
1079               (process-new-window win)
1080               (map-window win)
1081               (raise-window win)
1082               (pushnew (xlib:window-id win) id-list))))))
1083     (netwm-set-client-list id-list))
1084   (setf *in-process-existing-windows* nil))
1085
1086
1087 ;;; Child order manipulation functions
1088 (defun put-child-on-top (child parent)
1089   "Put the child on top of its parent children"
1090   (when (frame-p parent)
1091     (setf (frame-child parent) (cons child (child-remove child (frame-child parent)))
1092           (frame-selected-pos parent) 0)))
1093
1094 (defun put-child-on-bottom (child parent)
1095   "Put the child at the bottom of its parent children"
1096   (when (frame-p parent)
1097     (setf (frame-child parent) (append (child-remove child (frame-child parent)) (list child))
1098           (frame-selected-pos parent) 0)))
1099
1100