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