src/clfswm-internal.lisp

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