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