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