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