src/clfswm-internal.lisp

   1 ;; --------------------------------------------------------------------------
   2 ;;; CLFSWM - FullScreen Window Manager
   3 ;;;
   4 ;;; --------------------------------------------------------------------------
   5 ;;; Documentation: Main functions
   6 ;;; --------------------------------------------------------------------------
   7 ;;;
   8 ;;; (C) 2012 Philippe Brochard <pbrochard@common-lisp.net>
   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 (defgeneric child-border-size (child))
  29
  30 (defmethod child-border-size ((child frame))
  31   (x-drawable-border-width (frame-window child)))
  32
  33 (defmethod child-border-size ((child xlib:window))
  34   (x-drawable-border-width child))
  35
  36 (defmethod child-border-size (child)
  37   (declare (ignore child))
  38   0)
  39
  40 (defgeneric set-child-border-size (child value))
  41
  42 (defmethod set-child-border-size ((child frame) value)
  43   (setf (x-drawable-border-width (frame-window child)) value))
  44
  45 (defmethod set-child-border-size ((child xlib:window) value)
  46   (setf (x-drawable-border-width child) value))
  47
  48 (defmethod set-child-border-size (child value)
  49   (declare (ignore child value)))
  50
  51 (defsetf child-border-size set-child-border-size)
  52
  53
  54
  55 ;;; Conversion functions
  56 ;;; Float -> Pixel conversion
  57 (defun x-fl->px (x parent)
  58   "Convert float X coordinate to pixel"
  59   (round (+ (* x (frame-rw parent)) (frame-rx parent))))
  60
  61 (defun y-fl->px (y parent)
  62   "Convert float Y coordinate to pixel"
  63   (round (+ (* y (frame-rh parent)) (frame-ry parent))))
  64
  65 (defun w-fl->px (w parent)
  66   "Convert float Width coordinate to pixel"
  67   (round (* w (frame-rw parent))))
  68
  69 (defun h-fl->px (h parent)
  70   "Convert float Height coordinate to pixel"
  71   (round (* h (frame-rh parent))))
  72
  73 ;;; Pixel -> Float conversion
  74 (defun x-px->fl (x parent)
  75   "Convert pixel X coordinate to float"
  76   (/ (- x (frame-rx parent) (child-border-size parent)) (frame-rw parent)))
  77
  78 (defun y-px->fl (y parent)
  79   "Convert pixel Y coordinate to float"
  80   (/ (- y (frame-ry parent) (child-border-size parent)) (frame-rh parent)))
  81
  82 (defun w-px->fl (w parent)
  83   "Convert pixel Width coordinate to float"
  84   (/ w (frame-rw parent)))
  85
  86 (defun h-px->fl (h parent)
  87   "Convert pixel Height coordinate to float"
  88   (/ h (frame-rh parent)))
  89
  90
  91
  92 (defun rect-hidden-p (rect1 rect2)
  93   "Return T if child-rect1 hide child-rect2"
  94   (and *show-hide-policy*
  95        (funcall *show-hide-policy* (child-rect-x rect1) (child-rect-x rect2))
  96        (funcall *show-hide-policy* (child-rect-y rect1) (child-rect-y rect2))
  97        (funcall *show-hide-policy* (+ (child-rect-x rect2) (child-rect-w rect2))
  98                 (+ (child-rect-x rect1) (child-rect-w rect1)))
  99        (funcall *show-hide-policy* (+ (child-rect-y rect2) (child-rect-h rect2))
 100                 (+ (child-rect-y rect1) (child-rect-h rect1)))))
 101
 102
 103
 104 (defgeneric frame-p (frame))
 105 (defmethod frame-p ((frame frame))
 106   (declare (ignore frame))
 107   t)
 108 (defmethod frame-p (frame)
 109   (declare (ignore frame))
 110   nil)
 111
 112
 113
 114 ;;; in-*: Find if point (x,y) is in frame, window or child
 115 (defun in-rect (x y xr yr wr hr)
 116   (and (<= xr x (+ xr wr))
 117        (<= yr y (+ yr hr))))
 118
 119 (defun in-frame (frame x y)
 120   (and (frame-p frame)
 121        (in-rect x y (frame-rx frame) (frame-ry frame) (frame-rw frame) (frame-rh frame))))
 122
 123 (defun in-window (window x y)
 124   (and (xlib:window-p window)
 125        (in-rect x y
 126                 (x-drawable-x window) (x-drawable-y window)
 127                 (x-drawable-width window) (x-drawable-height window))))
 128
 129 (defgeneric in-child (child x y))
 130
 131 (defmethod in-child ((child frame) x y)
 132   (in-frame child x y))
 133 (defmethod in-child ((child xlib:window) x y)
 134   (in-window child x y))
 135 (defmethod in-child (child x y)
 136   (declare (ignore child x y))
 137   nil)
 138
 139
 140
 141
 142 (defun frame-selected-child (frame)
 143   (when (frame-p frame)
 144     (with-slots (child selected-pos) frame
 145       (let ((len (length child)))
 146         (cond ((minusp selected-pos) (setf selected-pos 0))
 147               ((>= selected-pos len) (setf selected-pos (max (1- len) 0)))))
 148       (nth selected-pos child))))
 149
 150
 151
 152
 153
 154 (defgeneric child-equal-p (child-1 child-2))
 155
 156 (defmethod child-equal-p ((child-1 xlib:window) (child-2 xlib:window))
 157   (xlib:window-equal child-1 child-2))
 158
 159 (defmethod child-equal-p ((child-1 frame) (child-2 frame))
 160   (equal child-1 child-2))
 161
 162 (defmethod child-equal-p (child-1 child-2)
 163   (declare (ignore child-1 child-2))
 164   nil)
 165
 166
 167
 168
 169 (declaim (inline child-member child-remove child-position))
 170
 171 (defun child-member (child list)
 172   (member child list :test #'child-equal-p))
 173
 174 (defun child-remove (child list)
 175   (remove child list :test #'child-equal-p))
 176
 177 (defun child-position (child list)
 178   (position child list :test #'child-equal-p))
 179
 180
 181
 182 ;;; Frame data manipulation functions
 183 (defun frame-data-slot (frame slot)
 184   "Return the value associated to data slot"
 185   (when (frame-p frame)
 186     (second (assoc slot (frame-data frame)))))
 187
 188 (defun set-frame-data-slot (frame slot value)
 189   "Set the value associated to data slot"
 190   (when (frame-p frame)
 191     (with-slots (data) frame
 192       (setf data (remove (assoc slot data) data))
 193       (push (list slot value) data))
 194     value))
 195
 196 (defsetf frame-data-slot set-frame-data-slot)
 197
 198
 199 (defun remove-frame-data-slot (frame slot)
 200   "Remove a slot in frame data slots"
 201   (when (frame-p frame)
 202     (with-slots (data) frame
 203       (setf data (remove (assoc slot data) data)))))
 204
 205
 206
 207 (defun managed-window-p (window frame)
 208   "Return t only if window is managed by frame"
 209   (if (frame-p frame)
 210       (with-slots ((managed forced-managed-window)
 211                    (unmanaged forced-unmanaged-window)) frame
 212         (and (xlib:window-p window)
 213              (not (child-member window unmanaged))
 214              (not (member (xlib:wm-name window) unmanaged :test #'string-equal-p))
 215              (or (member :all (frame-managed-type frame))
 216                  (member (window-type window) (frame-managed-type frame))
 217                  (child-member window managed)
 218                  (member (xlib:wm-name window) managed :test #'string-equal-p))))
 219       t))
 220
 221
 222 (defun add-in-never-managed-window-list (value)
 223   (pushnew value *never-managed-window-list* :test #'equal))
 224
 225 (defun never-managed-window-p (window)
 226   (when (xlib:window-p window)
 227     (dolist (type *never-managed-window-list*)
 228       (when (funcall (first type) window)
 229         (return (values t (second type)))))))
 230
 231
 232
 233 (defgeneric child-name (child))
 234
 235 (defmethod child-name ((child xlib:window))
 236   (xlib:wm-name child))
 237
 238 (defmethod child-name ((child frame))
 239   (frame-name child))
 240
 241 (defmethod child-name (child)
 242   (declare (ignore child))
 243   "???")
 244
 245
 246 (defgeneric set-child-name (child name))
 247
 248 (defmethod set-child-name ((child xlib:window) name)
 249   (setf (xlib:wm-name child) name))
 250
 251 (defmethod set-child-name ((child frame) name)
 252   (setf (frame-name child) name))
 253
 254 (defmethod set-child-name (child name)
 255   (declare (ignore child name)))
 256
 257 (defsetf child-name set-child-name)
 258
 259
 260
 261
 262 (defgeneric child-fullname (child))
 263
 264 (defmethod child-fullname ((child xlib:window))
 265   (format nil "~A (~A)" (or (xlib:wm-name child) "?") (or (xlib:get-wm-class child) "?")))
 266
 267 (defmethod child-fullname ((child frame))
 268   (aif (frame-name child)
 269        (format nil "~A (Frame ~A)" it (frame-number child))
 270        (format nil "Frame ~A" (frame-number child))))
 271
 272 (defmethod child-fullname (child)
 273   (declare (ignore child))
 274   "???")
 275
 276
 277 (defgeneric child-transparency (child))
 278
 279 (defmethod child-transparency ((child xlib:window))
 280   (window-transparency child))
 281
 282 (defmethod child-transparency ((child frame))
 283   (window-transparency (frame-window child)))
 284
 285 (defmethod child-transparency (child)
 286   (declare (ignore child))
 287   1)
 288
 289 (defgeneric set-child-transparency (child value))
 290
 291 (defmethod set-child-transparency ((child xlib:window) value)
 292   (setf (window-transparency child) value))
 293
 294 (defmethod set-child-transparency ((child frame) value)
 295   (setf (window-transparency (frame-window child)) value))
 296
 297 (defmethod set-child-transparency (child value)
 298   (declare (ignore child value)))
 299
 300 (defsetf child-transparency set-child-transparency)
 301
 302
 303
 304 (defgeneric child-x (child))
 305 (defmethod child-x ((child xlib:window))
 306   (x-drawable-x child))
 307 (defmethod child-x ((child frame))
 308   (frame-rx child))
 309
 310 (defgeneric child-y (child))
 311 (defmethod child-y ((child xlib:window))
 312   (x-drawable-y child))
 313 (defmethod child-y ((child frame))
 314   (frame-ry child))
 315
 316 (defgeneric child-width (child))
 317 (defmethod child-width ((child xlib:window))
 318   (x-drawable-width child))
 319 (defmethod child-width ((child frame))
 320   (frame-rw child))
 321
 322 (defgeneric child-height (child))
 323 (defmethod child-height ((child xlib:window))
 324   (x-drawable-height child))
 325 (defmethod child-height ((child frame))
 326   (frame-rh child))
 327
 328 (defgeneric child-x2 (child))
 329 (defmethod child-x2 ((child xlib:window))
 330   (+ (x-drawable-x child) (x-drawable-width child)))
 331 (defmethod child-x2 ((child frame))
 332   (+ (frame-rx child) (frame-rw child)))
 333
 334 (defgeneric child-y2 (child))
 335 (defmethod child-y2 ((child xlib:window))
 336   (+ (x-drawable-y child) (x-drawable-height child)))
 337 (defmethod child-y2 ((child frame))
 338   (+ (frame-ry child) (frame-rh child)))
 339
 340
 341
 342 (defgeneric child-center (child))
 343
 344 (defmethod child-center ((child xlib:window))
 345   (values (+ (x-drawable-x child) (/ (x-drawable-width child) 2))
 346           (+ (x-drawable-y child) (/ (x-drawable-height child) 2))))
 347
 348 (defmethod child-center ((child frame))
 349   (values (+ (frame-rx child) (/ (frame-rw child) 2))
 350           (+ (frame-ry child) (/ (frame-rh child) 2))))
 351
 352 (defun child-distance (child1 child2)
 353   (multiple-value-bind (x1 y1) (child-center child1)
 354     (multiple-value-bind (x2 y2) (child-center child2)
 355       (values (+ (abs (- x2 x1)) (abs (- y2 y1)))
 356               (- x2 x1)
 357               (- y2 y1)))))
 358
 359 (defun middle-child-x (child)
 360   (+ (child-x child) (/ (child-width child) 2)))
 361
 362 (defun middle-child-y (child)
 363   (+ (child-y child) (/ (child-height child) 2)))
 364
 365 (declaim (inline adj-border-xy adj-border-wh))
 366 (defgeneric adj-border-xy (value child))
 367 (defgeneric adj-border-wh (value child))
 368
 369 (defmethod adj-border-xy (v (child xlib:window))
 370   (+ v (x-drawable-border-width child)))
 371
 372 (defmethod adj-border-xy (v (child frame))
 373   (+ v (x-drawable-border-width (frame-window child))))
 374
 375 (defmethod adj-border-wh (v (child xlib:window))
 376   (- v (* (x-drawable-border-width child) 2)))
 377
 378 (defmethod adj-border-wh (v (child frame))
 379   (- v (* (x-drawable-border-width (frame-window child)) 2)))
 380
 381
 382 (declaim (inline anti-adj-border-xy anti-adj-border-wh))
 383 (defgeneric anti-adj-border-xy (value child))
 384 (defgeneric anti-adj-border-wh (value child))
 385
 386 (defmethod anti-adj-border-xy (v (child xlib:window))
 387   (- v (x-drawable-border-width child)))
 388
 389 (defmethod anti-adj-border-xy (v (child frame))
 390   (- v (x-drawable-border-width (frame-window child))))
 391
 392 (defmethod anti-adj-border-wh (v (child xlib:window))
 393   (+ v (* (x-drawable-border-width child) 2)))
 394
 395 (defmethod anti-adj-border-wh (v (child frame))
 396   (+ v (* (x-drawable-border-width (frame-window child)) 2)))
 397
 398
 399
 400
 401 (defmacro with-focus-window ((window) &body body)
 402   `(let ((,window (xlib:input-focus *display*)))
 403      (when (and ,window (not (xlib:window-equal ,window *no-focus-window*)))
 404        ,@body)))
 405
 406
 407
 408 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
 409 (defmacro with-all-children ((root child) &body body)
 410   (let ((rec (gensym))
 411         (sub-child (gensym)))
 412     `(block nil
 413        (labels ((,rec (,child)
 414                   ,@body
 415                   (when (frame-p ,child)
 416                     (dolist (,sub-child (reverse (frame-child ,child)))
 417                       (,rec ,sub-child)))))
 418          (,rec ,root)))))
 419
 420
 421 ;; (with-all-children (*root-frame* child) (typecase child (xlib:window (print child)) (frame (print (frame-number child)))))
 422 (defmacro with-all-children-reversed ((root child) &body body)
 423   (let ((rec (gensym))
 424         (sub-child (gensym)))
 425     `(block nil
 426        (labels ((,rec (,child)
 427                   ,@body
 428                   (when (frame-p ,child)
 429                     (dolist (,sub-child (frame-child ,child))
 430                       (,rec ,sub-child)))))
 431          (,rec ,root)))))
 432
 433
 434
 435
 436
 437 ;; (with-all-frames (*root-frame* frame) (print (frame-number frame)))
 438 (defmacro with-all-frames ((root frame) &body body)
 439   (let ((rec (gensym))
 440         (child (gensym)))
 441     `(block nil
 442        (labels ((,rec (,frame)
 443                   (when (frame-p ,frame)
 444                     ,@body
 445                     (dolist (,child (reverse (frame-child ,frame)))
 446                       (,rec ,child)))))
 447          (,rec ,root)))))
 448
 449
 450 ;; (with-all-windows (*root-frame* window) (print window))
 451 (defmacro with-all-windows ((root window) &body body)
 452   (let ((rec (gensym))
 453         (child (gensym)))
 454     `(block nil
 455        (labels ((,rec (,window)
 456                   (when (xlib:window-p ,window)
 457                     ,@body)
 458                   (when (frame-p ,window)
 459                     (dolist (,child (reverse (frame-child ,window)))
 460                       (,rec ,child)))))
 461          (,rec ,root)))))
 462
 463
 464
 465 ;; (with-all-frames-windows (*root-frame* child) (print child) (print (frame-number child)))
 466 (defmacro with-all-windows-frames ((root child) body-window body-frame)
 467   (let ((rec (gensym))
 468         (sub-child (gensym)))
 469     `(block nil
 470        (labels ((,rec (,child)
 471                   (typecase ,child
 472                     (xlib:window ,body-window)
 473                     (frame ,body-frame
 474                            (dolist (,sub-child (reverse (frame-child ,child)))
 475                              (,rec ,sub-child))))))
 476          (,rec ,root)))))
 477
 478 (defmacro with-all-windows-frames-and-parent ((root child parent) body-window body-frame)
 479   (let ((rec (gensym))
 480         (sub-child (gensym)))
 481     `(block nil
 482        (labels ((,rec (,child ,parent)
 483                   (typecase ,child
 484                     (xlib:window ,body-window)
 485                     (frame ,body-frame
 486                            (dolist (,sub-child (reverse (frame-child ,child)))
 487                              (,rec ,sub-child ,child))))))
 488          (,rec ,root nil)))))
 489
 490
 491
 492
 493 (defun null-size-window-in-frame (frame)
 494   (let ((null-size-window-p nil))
 495     (with-all-windows (frame window)
 496       (when (null-size-window-p window)
 497         (setf null-size-window-p t)))
 498     null-size-window-p))
 499
 500
 501
 502 (defun create-frame-window ()
 503   (let ((win (xlib:create-window :parent *root*
 504                                  :x 0
 505                                  :y 0
 506                                  :width 200
 507                                  :height 200
 508                                  :background (get-color *frame-background*)
 509                                  :colormap (xlib:screen-default-colormap *screen*)
 510                                  :border-width *border-size*
 511                                  :border (get-color *color-selected*)
 512                                  :event-mask '(:exposure :button-press :button-release :pointer-motion :enter-window))))
 513     (setf (window-transparency win) *frame-transparency*)
 514     win))
 515
 516 (defun create-frame-gc (window)
 517   (xlib:create-gcontext :drawable window
 518                         :foreground (get-color *frame-foreground*)
 519                         :background (get-color *frame-background*)
 520                         :font *default-font*
 521                         :line-style :solid))
 522
 523
 524 (defun destroy-all-frames-window ()
 525   (with-all-frames (*root-frame* frame)
 526     (when (frame-gc frame)
 527       (xlib:free-gcontext (frame-gc frame))
 528       (setf (frame-gc frame) nil))
 529     (when (frame-window frame)
 530       (xlib:destroy-window (frame-window frame))
 531       (setf (frame-window frame) nil))))
 532
 533 (defun create-all-frames-window ()
 534   (with-all-frames (*root-frame* frame)
 535     (unless (frame-window frame)
 536       (setf (frame-window frame) (create-frame-window)))
 537     (unless (frame-gc frame)
 538       (setf (frame-gc frame) (create-frame-gc (frame-window frame)))))
 539   (with-all-frames (*root-frame* frame)
 540     (dolist (child (frame-child frame))
 541       (handler-case
 542           (dbg (child-fullname child))
 543         (error (c)
 544           (setf (frame-child frame) (remove child (frame-child frame) :test #'child-equal-p))
 545           (dbg c child))))))
 546
 547
 548
 549
 550 (defun frame-find-free-number ()
 551   (let ((all-numbers nil))
 552     (with-all-frames (*root-frame* frame)
 553       (pushnew (frame-number frame) all-numbers))
 554     (find-free-number all-numbers)))
 555
 556
 557 (defun create-frame (&rest args &key (number (frame-find-free-number)) &allow-other-keys)
 558   (let* ((window (create-frame-window))
 559          (gc (create-frame-gc window)))
 560     (apply #'make-instance 'frame :number number :window window :gc gc args)))
 561
 562
 563 (defun add-frame (frame parent)
 564   (push frame (frame-child parent))
 565   frame)
 566
 567
 568 (defun place-frame (frame parent prx pry prw prh)
 569   "Place a frame from real (pixel) coordinates"
 570   (when (and (frame-p frame) (frame-p parent))
 571     (with-slots (window x y w h) frame
 572       (setf (x-drawable-x window) prx
 573             (x-drawable-y window) pry
 574             (x-drawable-width window) prw
 575             (x-drawable-height window) prh
 576             x (x-px->fl prx parent)
 577             y (y-px->fl pry parent)
 578             w (w-px->fl prw parent)
 579             h (h-px->fl prh parent))
 580       (xlib:display-finish-output *display*))))
 581
 582
 583
 584 (defun find-child (to-find root)
 585   "Find to-find in root or in its children"
 586   (with-all-children (root child)
 587     (when (child-equal-p child to-find)
 588       (return-from find-child t))))
 589
 590
 591
 592 (defmacro with-find-in-all-frames (test &optional return-value)
 593   `(let (ret)
 594      (block return-block
 595        (with-all-frames (root frame)
 596          (when ,test
 597            (if first-foundp
 598                (return-from return-block (or ,return-value frame))
 599                (setf ret frame))))
 600        (or ,return-value ret))))
 601
 602 (defun find-parent-frame  (to-find &optional (root *root-frame*) first-foundp)
 603   "Return the parent frame of to-find"
 604   (with-find-in-all-frames
 605       (child-member to-find (frame-child frame))))
 606
 607 (defun find-frame-window (window &optional (root *root-frame*) first-foundp)
 608   "Return the frame with the window window"
 609   (with-find-in-all-frames
 610       (xlib:window-equal window (frame-window frame))))
 611
 612 (defun find-frame-by-name (name &optional (root *root-frame*) first-foundp)
 613   "Find a frame from its name"
 614   (when name
 615     (with-find-in-all-frames
 616         (string-equal name (frame-name frame)))))
 617
 618 (defun find-frame-by-number (number &optional (root *root-frame*) first-foundp)
 619   "Find a frame from its number"
 620   (when (numberp number)
 621     (with-find-in-all-frames
 622         (= number (frame-number frame)))))
 623
 624
 625 (defun find-child-in-parent (child base)
 626   "Return t if child is in base or in its parents"
 627   (labels ((rec (base)
 628              (when (child-equal-p child base)
 629                (return-from find-child-in-parent t))
 630              (let ((parent (find-parent-frame base)))
 631                (when parent
 632                  (rec parent)))))
 633     (rec base)))
 634
 635 ;;; Multiple roots support (replace the old *current-root* variable)
 636 (let ((root-list nil)
 637       (current-child nil))
 638   (defun get-root-list ()
 639     root-list)
 640
 641   (let ((save-root-list nil))
 642     (defun save-root-list ()
 643       (setf save-root-list nil)
 644       (dolist (root root-list)
 645         (push (copy-root root) save-root-list)))
 646     (defun restore-root-list ()
 647       (setf root-list nil)
 648       (dolist (root save-root-list)
 649         (push (copy-root root) root-list))))
 650
 651   (defmacro with-saved-root-list (() &body body)
 652     `(progn
 653        (save-root-list)
 654        ,@body
 655        (restore-root-list)))
 656
 657   (defun reset-root-list ()
 658     (setf root-list nil
 659           current-child nil))
 660
 661   (defun define-as-root (child x y width height)
 662     (push (make-root :child child :original child :current-child nil :x x :y y :w width :h height) root-list))
 663
 664   (defun find-root-by-coordinates (x y)
 665     (dolist (root root-list)
 666       (when (in-rect x y (root-x root) (root-y root) (root-w root) (root-h root))
 667         (return root))))
 668
 669   (defun root (x &optional y)
 670     "Return the root at coordinates (x,y) if y is not nil.
 671      Otherwise, return the x nth root in root-list"
 672     (if y
 673         (find-root-by-coordinates x y)
 674         (nth x root-list)))
 675
 676   (defun all-root-child ()
 677     (loop for root in root-list
 678        collect (root-child root)))
 679
 680   (defmacro with-all-root-child ((root) &body body)
 681     (let ((root-symb (gensym)))
 682       `(dolist (,root-symb (get-root-list))
 683          (let ((,root (root-child ,root-symb)))
 684            ,@body))))
 685
 686   (labels ((generic-child-root-p (child function)
 687              (dolist (root root-list)
 688                (when (child-equal-p child (funcall function root))
 689                  (return root)))))
 690     (defun child-root-p (child)
 691       (generic-child-root-p child #'root-child))
 692
 693     (defun child-original-root-p (child)
 694       (generic-child-root-p child #'root-original)))
 695
 696   (defun change-root (old-root new-child)
 697     (when (and old-root new-child)
 698       (setf (root-child old-root) new-child)))
 699
 700   (defun find-root (child)
 701     (aif (child-original-root-p child)
 702          it
 703          (awhen (find-parent-frame child)
 704            (find-root it))))
 705
 706   (defun find-child-in-all-root (child)
 707     (dolist (root root-list)
 708       (when (find-child child (root-child root))
 709         (return-from find-child-in-all-root root))))
 710
 711   (defun find-current-root ()
 712     (root-child (find-root (current-child))))
 713
 714   (defun exchange-root-geometry (root-1 root-2)
 715     (when (and root-1 root-2)
 716       (rotatef (root-x root-1) (root-x root-2))
 717       (rotatef (root-y root-1) (root-y root-2))
 718       (rotatef (root-w root-1) (root-w root-2))
 719       (rotatef (root-h root-1) (root-h root-2))))
 720
 721   (defun rotate-root-geometry ()
 722     (let* ((current (first root-list))
 723            (orig-x (root-x current))
 724            (orig-y (root-y current))
 725            (orig-w (root-w current))
 726            (orig-h (root-h current)))
 727       (dolist (elem (rest root-list))
 728         (setf (root-x current) (root-x elem)
 729               (root-y current) (root-y elem)
 730               (root-w current) (root-w elem)
 731               (root-h current) (root-h elem)
 732               current elem))
 733       (let ((last (car (last root-list))))
 734         (setf (root-x last) orig-x
 735               (root-y last) orig-y
 736               (root-w last) orig-w
 737               (root-h last) orig-h))))
 738
 739   (defun anti-rotate-root-geometry ()
 740     (setf root-list (nreverse root-list))
 741     (rotate-root-geometry)
 742     (setf root-list (nreverse root-list)))
 743
 744   ;;; Current child functions
 745   (defun current-child ()
 746     current-child)
 747
 748   (defun current-child-setter (value)
 749     (awhen (find-root value)
 750       (setf (root-current-child it) value))
 751     (setf current-child value))
 752
 753   (defmacro with-current-child ((new-child) &body body)
 754     "Temporarly change the current child"
 755     (let ((old-child (gensym))
 756           (ret (gensym)))
 757       `(let ((,old-child (current-child)))
 758          (setf (current-child) ,new-child)
 759          (let ((,ret (multiple-value-list (progn ,@body))))
 760            (setf (current-child) ,old-child)
 761            (values-list ,ret)))))
 762
 763   (defun child-is-a-current-child-p (child)
 764     (find child root-list :test #'child-equal-p :key #'root-current-child)))
 765
 766 (defsetf current-child current-child-setter)
 767
 768 (defun ensure-at-least-one-root ()
 769   (unless (get-root-list)
 770     (let ((frame (create-frame)))
 771       (add-frame frame *root-frame*)
 772       (define-as-root frame 0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*))
 773       (add-frame (create-frame) frame))))
 774
 775
 776
 777
 778
 779
 780 (defun is-in-current-child-p (child)
 781   (and (frame-p (current-child))
 782        (child-member child (frame-child (current-child)))))
 783
 784
 785
 786 (defun fixe-real-size (frame parent)
 787   "Fixe real (pixel) coordinates in float coordinates"
 788   (when (frame-p frame)
 789     (with-slots (x y w h rx ry rw rh) frame
 790       (setf x (x-px->fl rx parent)
 791             y (y-px->fl ry parent)
 792             w (w-px->fl (anti-adj-border-wh rw parent) parent)
 793             h (h-px->fl (anti-adj-border-wh rh parent) parent)))))
 794
 795 (defun fixe-real-size-current-child ()
 796   "Fixe real (pixel) coordinates in float coordinates for children in the current child"
 797   (when (frame-p (current-child))
 798     (dolist (child (frame-child (current-child)))
 799       (fixe-real-size child (current-child)))))
 800
 801
 802
 803 ;;; Multiple physical screen helper
 804 (defun add-placed-frame-tmp (frame n)   ;; For test
 805   (add-frame (create-frame :x 0.01 :y 0.01 :w 0.4 :h 0.4) frame)
 806   (add-frame (create-frame :x 0.55 :y 0.01 :w 0.4 :h 0.4) frame)
 807   (add-frame (create-frame :x 0.03 :y 0.5 :w 0.64 :h 0.44) frame)
 808   (when (plusp n)
 809     (add-placed-frame-tmp (first (frame-child frame)) (1- n))))
 810
 811 (defun parse-xinerama-info (line)
 812   (remove nil
 813           (mapcar (lambda (string)
 814                     (parse-integer string :junk-allowed t))
 815                   (split-string (substitute #\space #\x (substitute #\space #\, line))))))
 816
 817 (defun get-connected-heads-size (&optional (fake (string= (getenv "DISPLAY") ":1")))
 818   (labels ((heads-info ()
 819              (if (not fake)
 820                  (do-shell "xdpyinfo -ext XINERAMA")
 821                  (progn
 822                    (setf *show-root-frame-p* t)
 823                    (do-shell "echo '    available colormap entries:    256 per subfield
 824     red, green, blue masks:    0xff0000, 0xff00, 0xff
 825     significant bits in color specification:    8 bits
 826
 827 XINERAMA version 1.1 opcode: 150
 828   head #0: 500x300 @ 10,10
 829   head #1: 480x300 @ 520,20
 830   head #2: 600x250 @ 310,330'")))))
 831     (when (xlib:query-extension *display* "XINERAMA")
 832       (let ((output (heads-info))
 833             (sizes nil))
 834         (loop for line = (read-line output nil nil)
 835            while line
 836            do (when (search " head " line)
 837                 (destructuring-bind (w h x y)
 838                     (parse-xinerama-info line)
 839                   (push (list x y w h) sizes))))
 840         (remove-duplicates sizes :test #'equal)))))
 841         ;;'((10 10 500 300) (550 50 400 400) (100 320 400 270))))))
 842         ;;'((10 10 500 580) (540 50 470 500))))))
 843
 844
 845 (let ((last-sizes nil))
 846   (defun place-frames-from-xinerama-infos ()
 847     "Place frames according to xdpyinfo/xinerama informations"
 848     (let ((sizes (get-connected-heads-size))
 849           (width (xlib:screen-width *screen*))
 850           (height (xlib:screen-height *screen*)))
 851       (labels ((update-root-geometry ()
 852                  (loop for size in sizes
 853                     for root in (get-root-list)
 854                     do (destructuring-bind (x y w h) size
 855                          (setf (root-x root) x
 856                                (root-y root) y
 857                                (root-w root) w
 858                                (root-h root) h))))
 859                (create-root-geometry ()
 860                  (reset-root-list)
 861                  ;; Add frames in *root-frame* until we get the same number as screen heads
 862                  (loop while (< (length (frame-child *root-frame*)) (length sizes))
 863                     do (let ((frame (create-frame)))
 864                          (add-frame frame *root-frame*)))
 865                  ;; On the opposite way: remove frames while there is more than screen heads in *root-frame*
 866                  (when (and sizes (> (length (frame-child *root-frame*)) (length sizes)))
 867                    (dotimes (i (- (length (frame-child *root-frame*)) (length sizes)))
 868                      (let ((deleted-child (pop (frame-child *root-frame*))))
 869                        (typecase deleted-child
 870                          (xlib:window (push deleted-child (frame-child (first (frame-child *root-frame*)))))
 871                          (frame (dolist (child (frame-child deleted-child))
 872                                   (push child (frame-child (first (frame-child *root-frame*)))))))
 873                        (setf (frame-layout (first (frame-child *root-frame*))) 'tile-space-layout
 874                              (frame-data-slot (first (frame-child *root-frame*)) :tile-layout-keep-position) :yes))))
 875                  (loop for size in sizes
 876                     for frame in (frame-child *root-frame*)
 877                     do (destructuring-bind (x y w h) size
 878                          (setf (frame-x frame) (float (/ x width))
 879                                (frame-y frame) (float (/ y height))
 880                                (frame-w frame) (float (/ w width))
 881                                (frame-h frame) (float (/ h height)))
 882                          ;;(add-placed-frame-tmp frame 2)  ;; For tests
 883                          (unless (frame-child frame)
 884                            (add-frame (create-frame) frame))
 885                          (define-as-root frame x y w h)))))
 886         (format t "Screen sizes: ~A~%" sizes)
 887         (if (= (length sizes) (length last-sizes))
 888             (update-root-geometry)
 889             (create-root-geometry))
 890         (setf last-sizes sizes)))))
 891
 892
 893
 894 (defun finish-configuring-root ()
 895   (ensure-at-least-one-root)
 896   (setf (current-child) (first (frame-child (first (frame-child *root-frame*))))))
 897
 898
 899
 900 (defun get-all-windows (&optional (root *root-frame*))
 901   "Return all windows in root and in its children"
 902   (let ((acc nil))
 903     (with-all-windows (root window)
 904       (push window acc))
 905     acc))
 906
 907 (defun get-all-frame-windows (&optional (root *root-frame*))
 908   "Return all frame windows in root and in its children"
 909   (let ((acc nil))
 910     (with-all-frames (root frame)
 911       (push (frame-window frame) acc))
 912     acc))
 913
 914
 915 (defun get-hidden-windows ()
 916   "Return all hiddens windows"
 917   (let ((all-windows (get-all-windows))
 918         (hidden-windows (remove-if-not #'window-hidden-p
 919                                        (copy-list (xlib:query-tree *root*)))))
 920     (set-difference hidden-windows all-windows)))
 921
 922
 923
 924 ;;; Current window utilities
 925 (defun get-current-window ()
 926   (typecase (current-child)
 927     (xlib:window  (current-child))
 928     (frame (frame-selected-child (current-child)))))
 929
 930 (defmacro with-current-window (&body body)
 931   "Bind 'window' to the current window"
 932   `(let ((window (get-current-window)))
 933       (when (xlib:window-p window)
 934         ,@body)))
 935
 936 (defun get-first-window ()
 937   (typecase (current-child)
 938     (xlib:window  (current-child))
 939     (frame (or (first (frame-child (current-child)))
 940                (current-child)))))
 941
 942
 943
 944
 945
 946 (defun display-frame-info (frame)
 947   (when (frame-p frame)
 948     (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
 949       (with-slots (name number gc window child hidden-children) frame
 950         (setf (xlib:gcontext-background gc) (get-color *frame-background*)
 951               (xlib:window-background window) (get-color *frame-background*))
 952         (clear-pixmap-buffer window gc)
 953         (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-root-p frame)
 954                                                                 (child-equal-p frame (current-child)))
 955                                                            *frame-foreground-root* *frame-foreground*)))
 956         (xlib:draw-glyphs *pixmap-buffer* gc 5 dy
 957                           (format nil "Frame: ~A~A"
 958                                   number
 959                                   (if name  (format nil " - ~A" name) "")))
 960         (let ((pos dy))
 961           (when (child-root-p frame)
 962             (when *child-selection*
 963               (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 964                                 (with-output-to-string (str)
 965                                   (format str "  Selection: ")
 966                                   (dolist (child *child-selection*)
 967                                     (typecase child
 968                                       (xlib:window (format str "  ~A " (xlib:wm-name child)))
 969                                       (frame (format str "  frame:~A[~A] " (frame-number child)
 970                                                      (aif (frame-name child) it "")))))))))
 971           (dolist (ch child)
 972             (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 973                               (format nil "  ~A" (ensure-printable (child-fullname ch))))))
 974         (copy-pixmap-buffer window gc)
 975         (values t t)))))
 976
 977
 978 (defgeneric rename-child (child name))
 979
 980 (defmethod rename-child ((child frame) name)
 981   (setf (frame-name child) name)
 982   (display-frame-info child))
 983
 984 (defmethod rename-child ((child xlib:window) name)
 985   (setf (xlib:wm-name child) name))
 986
 987 (defmethod rename-child (child name)
 988   (declare (ignore child name)))
 989
 990
 991 (defun get-parent-layout (child parent)
 992   (aif (child-root-p child)
 993        (values (- (root-x it) (child-border-size child)) (- (root-y it) (child-border-size child))
 994                (root-w it) (root-h it))
 995        (if (or (frame-p child) (managed-window-p child parent))
 996            (if (frame-p parent)
 997                (aif (frame-layout parent)
 998                     (funcall it child parent)
 999                     (no-layout child parent))
1000                (values (- (child-border-size child)) (- (child-border-size child))
1001                        (xlib:screen-width *screen*)
1002                        (xlib:screen-height *screen*)))
1003            (values (x-drawable-x child) (x-drawable-y child)
1004                    (x-drawable-width child) (x-drawable-height child)))))
1005
1006
1007
1008
1009
1010 (defgeneric adapt-child-to-parent (child parent))
1011
1012 (defmethod adapt-child-to-parent ((window xlib:window) parent)
1013   (when (managed-window-p window parent)
1014     (multiple-value-bind (nx ny nw nh)
1015         (get-parent-layout window parent)
1016       (setf nw (max nw 1)  nh (max nh 1))
1017       (let ((change nil))
1018         (when (or (/= (x-drawable-x window) nx)
1019                   (/= (x-drawable-y window) ny))
1020           (setf change :moved))
1021         (when (or (/= (x-drawable-width window) nw)
1022                   (/= (x-drawable-height window) nh))
1023           (setf change :resized))
1024         (when change
1025           (xlib:with-state (window)
1026             (setf (x-drawable-x window) nx
1027                   (x-drawable-y window) ny
1028                   (x-drawable-width window) nw
1029                   (x-drawable-height window) nh)))
1030         change))))
1031
1032
1033 (defmethod adapt-child-to-parent ((frame frame) parent)
1034   (declare (ignore parent))
1035     (with-slots (rx ry rw rh window) frame
1036       (let ((change nil))
1037         (when (or (/= (x-drawable-x window) rx)
1038                   (/= (x-drawable-y window) ry))
1039           (setf change :moved))
1040         (when (or (/= (x-drawable-width window) rw)
1041                   (/= (x-drawable-height window) rh))
1042           (setf change :resized))
1043         (when change
1044           (xlib:with-state (window)
1045             (setf (x-drawable-x window) rx
1046                   (x-drawable-y window) ry
1047                   (x-drawable-width window) rw
1048                   (x-drawable-height window) rh)))
1049         change)))
1050
1051 (defmethod adapt-child-to-parent (child parent)
1052   (declare (ignore child parent))
1053   nil)
1054
1055
1056 (defgeneric set-child-stack-order (window child)
1057   (:documentation "Raise window if child is NIL else put window just below child"))
1058
1059 (defmethod set-child-stack-order (window (child xlib:window))
1060   (lower-window window child))
1061
1062 (defmethod set-child-stack-order (window (child frame))
1063   (lower-window window (frame-window child)))
1064
1065 (defmethod set-child-stack-order (window child)
1066   (declare (ignore child))
1067   (raise-window window))
1068
1069
1070
1071 (defgeneric show-child (child parent previous))
1072
1073 (defmethod show-child ((frame frame) parent previous)
1074   (declare (ignore parent))
1075   (with-slots (window show-window-p) frame
1076     (if (and show-window-p
1077              (or *show-root-frame-p* (not (child-root-p frame))))
1078         (progn
1079           (map-window window)
1080           (set-child-stack-order window previous)
1081           (display-frame-info frame))
1082         (hide-window window))))
1083
1084
1085
1086 (defun hide-unmanaged-window-p (parent)
1087   (let ((action (frame-data-slot parent :unmanaged-window-action)))
1088     (case action
1089       (:hide t)
1090       (:show nil)
1091       (t *hide-unmanaged-window*))))
1092
1093
1094 (defmethod show-child ((window xlib:window) parent previous)
1095   (if (or (managed-window-p window parent)
1096           (child-equal-p window (current-child))
1097           (not (hide-unmanaged-window-p parent))
1098           (child-is-a-current-child-p parent))
1099       (progn
1100         (map-window window)
1101         (set-child-stack-order window previous))
1102       (hide-window window)))
1103
1104 (defmethod show-child (child parent raise-p)
1105   (declare (ignore child parent raise-p))
1106   ())
1107
1108
1109 (defgeneric hide-child (child))
1110
1111 (defmethod hide-child ((frame frame))
1112   (with-slots (window) frame
1113     (xlib:unmap-window window)))
1114
1115 (defmethod hide-child ((window xlib:window))
1116   (hide-window window))
1117
1118 (defmethod hide-child (child)
1119   (declare (ignore child))
1120   ())
1121
1122
1123 (defgeneric select-child (child selected))
1124
1125 (labels ((get-selected-color (child selected-p)
1126            (get-color (cond ((child-equal-p child (current-child)) *color-selected*)
1127                             (selected-p *color-maybe-selected*)
1128                             (t *color-unselected*)))))
1129   (defmethod select-child ((frame frame) selected-p)
1130     (when (and (frame-p frame) (frame-window frame))
1131       (setf (xlib:window-border (frame-window frame))
1132             (get-selected-color frame selected-p))))
1133
1134   (defmethod select-child ((window xlib:window) selected-p)
1135     (setf (xlib:window-border window)
1136           (get-selected-color window selected-p)))
1137
1138   (defmethod select-child (child selected)
1139     (declare (ignore child selected))
1140     ()))
1141
1142 (defun select-current-frame (selected)
1143   (select-child (current-child) selected))
1144
1145 (defun unselect-all-frames ()
1146   (with-all-children (*root-frame* child)
1147     (select-child child nil)))
1148
1149
1150
1151 (defun set-focus-to-current-child ()
1152   (labels ((rec (child)
1153              (typecase child
1154                (xlib:window (focus-window child))
1155                (frame (rec (frame-selected-child child))))))
1156     (no-focus)
1157     (rec (current-child))))
1158
1159
1160
1161
1162 (defun adapt-frame-to-parent (frame parent)
1163   (multiple-value-bind (nx ny nw nh)
1164       (get-parent-layout frame parent)
1165     (with-slots (rx ry rw rh window) frame
1166       (setf rx nx  ry ny
1167             rw (max nw 1)
1168             rh (max nh 1)))))
1169
1170
1171 (defun adapt-child-to-rect (rect)
1172   (let ((window (typecase (child-rect-child rect)
1173                   (xlib:window (when (managed-window-p (child-rect-child rect) (child-rect-parent rect))
1174                                  (child-rect-child rect)))
1175                   (frame (frame-window (child-rect-child rect))))))
1176     (when window
1177       (let ((change (or (/= (x-drawable-x window) (child-rect-x rect))
1178                         (/= (x-drawable-y window) (child-rect-y rect))
1179                         (/= (x-drawable-width window) (child-rect-w rect))
1180                         (/= (x-drawable-height window) (child-rect-h rect)))))
1181         (when change
1182           (setf (x-drawable-x window) (child-rect-x rect)
1183                 (x-drawable-y window) (child-rect-y rect)
1184                 (x-drawable-width window) (child-rect-w rect)
1185                 (x-drawable-height window) (child-rect-h rect)))
1186         change))))
1187
1188
1189
1190
1191 (defun show-all-children (&optional (from-root-frame nil))
1192   "Show all children and hide those not in a root frame"
1193   (declare (ignore from-root-frame))
1194   (let ((geometry-change nil)
1195         (displayed-child nil)
1196         (hidden-child nil))
1197     (labels ((in-displayed-list (child)
1198                (member child displayed-child :test (lambda (c rect)
1199                                                      (child-equal-p c (child-rect-child rect)))))
1200
1201              (add-in-hidden-list (child)
1202                (pushnew child hidden-child :test #'child-equal-p))
1203
1204              (set-geometry (child parent in-current-root child-current-root-p)
1205                (if (or in-current-root child-current-root-p)
1206                    (when (frame-p child)
1207                      (adapt-frame-to-parent child (if child-current-root-p nil parent)))
1208                    (add-in-hidden-list child)))
1209
1210              (recurse-on-frame-child (child in-current-root child-current-root-p selected-p)
1211                (let ((selected-child (frame-selected-child child)))
1212                  (dolist (sub-child (frame-child child))
1213                    (rec sub-child child
1214                         (and selected-p (child-equal-p sub-child selected-child))
1215                         (or in-current-root child-current-root-p)))))
1216
1217              (hidden-child-p (rect)
1218                (dolist (r displayed-child)
1219                  (when (and (rect-hidden-p r rect)
1220                             (or (not (xlib:window-p (child-rect-child r)))
1221                                 (eq (window-type (child-rect-child r)) :normal)))
1222                    (return t))))
1223
1224              (select-and-display (child parent selected-p)
1225                (multiple-value-bind (nx ny nw nh)
1226                    (get-parent-layout child parent)
1227                  (let ((rect (make-child-rect :child child :parent parent
1228                                               :selected-p selected-p
1229                                               :x nx :y ny :w nw :h nh)))
1230                    (if (and *show-hide-policy* (hidden-child-p rect))
1231                        (add-in-hidden-list child)
1232                        (push rect displayed-child)))))
1233
1234              (display-displayed-child ()
1235                (let ((previous nil))
1236                  (dolist (rect (nreverse displayed-child))
1237                    (when (adapt-child-to-rect rect)
1238                      (setf geometry-change t))
1239                    (select-child (child-rect-child rect) (child-rect-selected-p rect))
1240                    (show-child (child-rect-child rect)
1241                                (child-rect-parent rect)
1242                                previous)
1243                    (setf previous (child-rect-child rect)))))
1244
1245              (rec (child parent selected-p in-current-root)
1246                (let ((child-current-root-p (child-root-p child)))
1247                  (unless (in-displayed-list child)
1248                    (set-geometry child parent in-current-root child-current-root-p))
1249                  (when (frame-p child)
1250                    (recurse-on-frame-child child in-current-root child-current-root-p selected-p))
1251                  (when (and (or in-current-root child-current-root-p)
1252                             (not (in-displayed-list child)))
1253                    (select-and-display child parent selected-p)))))
1254
1255       (rec *root-frame* nil t (child-root-p *root-frame*))
1256       (display-displayed-child)
1257       (dolist (child hidden-child)
1258         (hide-child child))
1259       (set-focus-to-current-child)
1260       (xlib:display-finish-output *display*)
1261       geometry-change)))
1262
1263
1264
1265
1266 (defun hide-all-children (root &optional except)
1267   "Hide all root children"
1268   (when (and (frame-p root) (not (child-equal-p root except)))
1269     (dolist (child (frame-child root))
1270       (hide-all child except))))
1271
1272 (defun hide-all (root &optional except)
1273   "Hide root and all its children"
1274   (unless (child-equal-p root except)
1275     (hide-child root))
1276   (hide-all-children root except))
1277
1278
1279
1280
1281
1282 (defun focus-child (child parent)
1283   "Focus child - Return true if something has change"
1284   (when (and (frame-p parent)
1285              (child-member child (frame-child parent)))
1286     (when (not (child-equal-p child (frame-selected-child parent)))
1287       (with-slots ((parent-child child) selected-pos) parent
1288         (setf parent-child (nth-insert selected-pos child (child-remove child parent-child))))
1289       t)))
1290
1291 (defun focus-child-rec (child parent)
1292   "Focus child and its parents - Return true if something has change"
1293   (let ((change nil))
1294     (labels ((rec (child parent)
1295                (when (focus-child child parent)
1296                  (setf change t))
1297                (when parent
1298                  (rec parent (find-parent-frame parent)))))
1299       (rec child parent))
1300     change))
1301
1302
1303 (defun set-current-child-generic (child)
1304   (unless (child-equal-p (current-child) child)
1305     (setf (current-child) child)
1306     t))
1307
1308 (defgeneric set-current-child (child parent window-parent))
1309
1310 (defmethod set-current-child ((child xlib:window) parent window-parent)
1311   (set-current-child-generic (if window-parent parent child)))
1312
1313 (defmethod set-current-child ((child frame) parent window-parent)
1314   (declare (ignore parent window-parent))
1315   (set-current-child-generic child))
1316
1317 (defmethod set-current-child (child parent window-parent)
1318   (declare (ignore child parent window-parent))
1319   ())
1320
1321
1322 (defun set-current-root (child parent window-parent)
1323   "Set current root if parent is not in current root"
1324   (let ((root (find-root child)))
1325     (when (and root window-parent
1326                (not (child-root-p child))
1327                (not (find-child parent (root-child root))))
1328       (change-root root parent)
1329       t)))
1330
1331 (defun focus-all-children (child parent &optional (window-parent t))
1332   "Focus child and its parents -
1333 For window: set current child to window or its parent according to window-parent"
1334   (let ((new-focus (focus-child-rec child parent))
1335         (new-current-child (set-current-child child parent window-parent))
1336         (new-root (set-current-root child parent window-parent)))
1337     (or new-focus new-current-child new-root)))
1338
1339
1340
1341
1342 (defun select-next-level ()
1343   "Select the next level in frame"
1344   (select-current-frame :maybe)
1345   (when (frame-p (current-child))
1346     (awhen (frame-selected-child (current-child))
1347       (setf (current-child) it)))
1348   (show-all-children))
1349
1350 (defun select-previous-level ()
1351   "Select the previous level in frame"
1352   (unless (child-root-p (current-child))
1353     (select-current-frame :maybe)
1354     (awhen (find-parent-frame (current-child))
1355       (setf (current-child) it))
1356     (show-all-children)))
1357
1358
1359 (defun enter-frame ()
1360   "Enter in the selected frame - ie make it the root frame"
1361   (let ((root (find-root (current-child))))
1362     (when (and root (not (child-equal-p (root-child root) (current-child))))
1363       (change-root root (current-child)))
1364     (show-all-children t)))
1365
1366 (defun leave-frame ()
1367   "Leave the selected frame - ie make its parent the root frame"
1368   (let ((root (find-root (current-child))))
1369     (unless (or (child-equal-p (root-child root) *root-frame*)
1370                 (child-original-root-p (root-child root)))
1371       (awhen (and root (find-parent-frame (root-child root)))
1372         (when (frame-p it)
1373           (change-root root it)))
1374       (show-all-children))))
1375
1376
1377 ;;; Other actions (select-next-child, select-next-brother...) are in
1378 ;;; clfswm-circulate-mode.lisp
1379
1380
1381
1382 (defun frame-lower-child ()
1383   "Lower the child in the current frame"
1384   (when (frame-p (current-child))
1385     (with-slots (child selected-pos) (current-child)
1386       (unless (>= selected-pos (length child))
1387         (when (nth (1+ selected-pos) child)
1388           (rotatef (nth selected-pos child)
1389                    (nth (1+ selected-pos) child)))
1390         (incf selected-pos)))
1391     (show-all-children)))
1392
1393
1394 (defun frame-raise-child ()
1395   "Raise the child in the current frame"
1396   (when (frame-p (current-child))
1397     (with-slots (child selected-pos) (current-child)
1398       (unless (< selected-pos 1)
1399         (when (nth (1- selected-pos) child)
1400           (rotatef (nth selected-pos child)
1401                    (nth (1- selected-pos) child)))
1402         (decf selected-pos)))
1403     (show-all-children)))
1404
1405
1406 (defun frame-select-next-child ()
1407   "Select the next child in the current frame"
1408   (when (frame-p (current-child))
1409     (with-slots (child selected-pos) (current-child)
1410       (setf selected-pos (mod (1+ selected-pos) (max (length child) 1))))
1411     (show-all-children)))
1412
1413
1414 (defun frame-select-previous-child ()
1415   "Select the previous child in the current frame"
1416   (when (frame-p (current-child))
1417     (with-slots (child selected-pos) (current-child)
1418       (setf selected-pos (mod (1- selected-pos) (max (length child) 1))))
1419     (show-all-children)))
1420
1421
1422
1423 (defun switch-to-root-frame (&key (show-later nil))
1424   "Switch to the root frame"
1425   (let ((root (find-root (current-child))))
1426     (when root
1427       (change-root root (root-original root)))
1428     (unless show-later
1429       (show-all-children t))))
1430
1431 (defun switch-and-select-root-frame (&key (show-later nil))
1432   "Switch and select the root frame"
1433   (let ((root (find-root (current-child))))
1434     (when root
1435       (change-root root (root-original root))
1436       (setf (current-child) (root-original root)))
1437     (unless show-later
1438       (show-all-children t))))
1439
1440
1441 (defun toggle-show-root-frame ()
1442   "Show/Hide the root frame"
1443   (setf *show-root-frame-p* (not *show-root-frame-p*))
1444   (show-all-children))
1445
1446
1447
1448 (defun prevent-current-*-equal-child (child)
1449   " Prevent current-root and current-child equal to child"
1450   (if (child-original-root-p child)
1451       nil
1452       (progn
1453         (awhen (child-root-p child)
1454           (change-root it (find-parent-frame child)))
1455         (when (child-equal-p child (current-child))
1456           (awhen (find-root child)
1457             (setf (current-child) (root-child it))))
1458         t)))
1459
1460
1461
1462 (defun remove-child-in-frame (child frame)
1463   "Remove the child in frame"
1464   (when (frame-p frame)
1465     (setf (frame-child frame) (child-remove child (frame-child frame)))))
1466
1467 (defun remove-child-in-frames (child root)
1468   "Remove child in the frame root and in all its children"
1469   (with-all-frames (root frame)
1470     (remove-child-in-frame child frame)))
1471
1472
1473 (defun remove-child-in-all-frames (child)
1474   "Remove child in all frames from *root-frame*"
1475   (when (prevent-current-*-equal-child child)
1476     (remove-child-in-frames child *root-frame*)))
1477
1478
1479 (defun delete-child-in-frames (child root &optional (close-methode 'delete-window))
1480   "Delete child in the frame root and in all its children
1481 Warning:frame window and gc are freeed."
1482   (with-all-frames (root frame)
1483     (remove-child-in-frame child frame)
1484     (unless (find-frame-window (frame-window frame))
1485       (awhen (frame-gc frame) (xlib:free-gcontext it) (setf it nil))
1486       (awhen (frame-window frame) (xlib:destroy-window it) (setf it nil))))
1487   (when (xlib:window-p child)
1488     (funcall close-methode child)
1489     (netwm-remove-in-client-list child)))
1490
1491
1492
1493 (defun delete-child-in-all-frames (child &optional (close-methode 'delete-window))
1494   "Delete child in all frames from *root-frame*"
1495   (when (prevent-current-*-equal-child child)
1496     (delete-child-in-frames child *root-frame* close-methode)))
1497
1498 (defun delete-child-and-children-in-frames (child root &optional (close-methode 'delete-window))
1499   "Delete child and its children in the frame root and in all its children
1500 Warning:frame window and gc are freeed."
1501   (when (and (frame-p child) (frame-child child))
1502     (dolist (ch (frame-child child))
1503       (delete-child-and-children-in-frames ch root close-methode)))
1504   (delete-child-in-frames child root close-methode))
1505
1506 (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window))
1507   "Delete child and its children in all frames from *root-frame*"
1508   (when (prevent-current-*-equal-child child)
1509     (when (frame-p child)
1510       (delete-child-and-children-in-frames child *root-frame* close-methode))
1511     (when (xlib:window-p child)
1512       (funcall close-methode child))))
1513
1514
1515 (defun clean-windows-in-all-frames ()
1516   "Remove all xlib:windows present in *root-frame* and not in the xlib tree"
1517   (let ((x-tree (xlib:query-tree *root*)))
1518     (with-all-frames (*root-frame* frame)
1519       (dolist (child (frame-child frame))
1520         (when (xlib:window-p child)
1521           (unless (member child x-tree :test #'xlib:window-equal)
1522             (when (prevent-current-*-equal-child child)
1523               (setf (frame-child frame)
1524                     (child-remove child (frame-child frame))))))))))
1525
1526
1527
1528 (defun do-all-frames-nw-hook (window)
1529   "Call nw-hook of each frame."
1530   (catch 'nw-hook-loop
1531     (let ((found nil))
1532       (with-all-frames (*root-frame* frame)
1533         (awhen (frame-nw-hook frame)
1534           (setf found (call-hook it frame window))))
1535       found)))
1536
1537
1538
1539 (defun process-new-window (window)
1540   "When a new window is created (or when we are scanning initial
1541 windows), this function dresses the window up and gets it ready to be
1542 managed."
1543   (setf (xlib:window-event-mask window) *window-events*)
1544   (set-window-state window +normal-state+)
1545   (setf (x-drawable-border-width window) (case (window-type window)
1546                                            (:normal *border-size*)
1547                                            (:maxsize 0)
1548                                            (:transient *border-size*)
1549                                            (:dialog *border-size*)
1550                                            (t *border-size*)))
1551   (grab-all-buttons window)
1552   (unless (never-managed-window-p window)
1553     (unless (do-all-frames-nw-hook window)
1554       (call-hook *default-nw-hook* *root-frame* window)))
1555   (netwm-add-in-client-list window))
1556
1557
1558
1559
1560 (defun with-all-mapped-windows (screen fun)
1561   (let ((all-windows (get-all-windows)))
1562     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1563       (unless (child-member win all-windows)
1564         (let ((map-state (xlib:window-map-state win))
1565               (wm-state (window-state win)))
1566           (unless (or (eql (xlib:window-override-redirect win) :on)
1567                       (eql win *no-focus-window*)
1568                       (is-notify-window-p win))
1569             (when (or (eql map-state :viewable)
1570                       (eql wm-state +iconic-state+))
1571               (funcall fun win))))))))
1572
1573 (defun store-root-background ()
1574   (with-all-mapped-windows *screen* #'hide-window)
1575   (setf *background-image* (xlib:create-pixmap :width (xlib:screen-width *screen*)
1576                                                :height (xlib:screen-height *screen*)
1577                                                :depth (xlib:screen-root-depth *screen*)
1578                                                :drawable *root*)
1579         *background-gc* (xlib:create-gcontext :drawable *background-image*
1580                                               :foreground (get-color *frame-foreground*)
1581                                               :background (get-color *frame-background*)
1582                                               :font *default-font*
1583                                               :line-style :solid))
1584   (xlib:copy-area *root* *background-gc*
1585                   0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*)
1586                   *background-image* 0 0)
1587   (with-all-mapped-windows *screen* #'unhide-window))
1588
1589
1590
1591
1592 (defun hide-existing-windows (screen)
1593   "Hide all existing windows in screen"
1594   (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1595     (hide-window win)))
1596
1597
1598
1599 (defun process-existing-windows (screen)
1600   "Windows present when clfswm starts up must be absorbed by clfswm."
1601   (setf *in-process-existing-windows* t)
1602   (let ((id-list nil)
1603         (all-windows (get-all-windows))
1604         (all-frame-windows (get-all-frame-windows)))
1605     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1606       (unless (or (child-member win all-windows)
1607                   (child-member win all-frame-windows))
1608         (let ((map-state (xlib:window-map-state win))
1609               (wm-state (window-state win)))
1610           (unless (or (eql (xlib:window-override-redirect win) :on)
1611                       (eql win *no-focus-window*)
1612                       (is-notify-window-p win)
1613                       (never-managed-window-p win))
1614             (when (or (eql map-state :viewable)
1615                       (eql wm-state +iconic-state+))
1616               (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win)
1617               (unhide-window win)
1618               (process-new-window win)
1619               (map-window win)
1620               (raise-window win)
1621               (pushnew (xlib:window-id win) id-list))))))
1622     (netwm-set-client-list id-list))
1623   (setf *in-process-existing-windows* nil))
1624
1625
1626 ;;; Child order manipulation functions
1627 (defun put-child-on-top (child parent)
1628   "Put the child on top of its parent children"
1629   (when (frame-p parent)
1630     (setf (frame-child parent) (cons child (child-remove child (frame-child parent)))
1631           (frame-selected-pos parent) 0)))
1632
1633 (defun put-child-on-bottom (child parent)
1634   "Put the child at the bottom of its parent children"
1635   (when (frame-p parent)
1636     (setf (frame-child parent) (append (child-remove child (frame-child parent)) (list child))
1637           (frame-selected-pos parent) 0)))
1638
1639