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
  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 get-root-list ()
 625     root-list)
 626
 627   (let ((save-root-list nil))
 628     (defun save-root-list ()
 629       (setf save-root-list nil)
 630       (dolist (root root-list)
 631         (push (copy-root root) save-root-list)))
 632     (defun restore-root-list ()
 633       (setf root-list nil)
 634       (dolist (root save-root-list)
 635         (push (copy-root root) root-list))))
 636
 637   (defmacro with-saved-root-list (() &body body)
 638     `(progn
 639        (save-root-list)
 640        ,@body
 641        (restore-root-list)))
 642
 643   (defun reset-root-list ()
 644     (setf root-list nil
 645           current-child nil))
 646
 647   (defun define-as-root (child x y width height)
 648     (push (make-root :child child :original child :current-child nil :x x :y y :w width :h height) root-list))
 649
 650   (defun unsure-at-least-one-root ()
 651     (unless root-list
 652       (define-as-root *root-frame* 0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*))))
 653
 654   (defun find-root-by-coordinates (x y)
 655     (dolist (root root-list)
 656       (when (in-rect x y (root-x root) (root-y root) (root-w root) (root-h root))
 657         (return root))))
 658
 659   (defun all-root-child ()
 660     (loop for root in root-list
 661        collect (root-child root)))
 662
 663   (defmacro with-all-root-child ((root) &body body)
 664     (let ((root-symb (gensym)))
 665       `(dolist (,root-symb (get-root-list))
 666          (let ((,root (root-child ,root-symb)))
 667            ,@body))))
 668
 669   (labels ((generic-child-root-p (child function)
 670              (dolist (root root-list)
 671                (when (child-equal-p child (funcall function root))
 672                  (return root)))))
 673     (defun child-root-p (child)
 674       (generic-child-root-p child #'root-child))
 675
 676     (defun child-original-root-p (child)
 677       (generic-child-root-p child #'root-original)))
 678
 679   (defun change-root (old-root new-child)
 680     (when (and old-root new-child)
 681       (setf (root-child old-root) new-child)))
 682
 683   (defun find-root (child)
 684     (aif (child-original-root-p child)
 685          it
 686          (awhen (find-parent-frame child)
 687            (find-root it))))
 688
 689   (defun find-child-in-all-root (child)
 690     (dolist (root root-list)
 691       (when (find-child child (root-child root))
 692         (return-from find-child-in-all-root root))))
 693
 694   (defun find-current-root ()
 695     (root-child (find-root (current-child))))
 696
 697   (defun exchange-root-geometry (root-1 root-2)
 698     (when (and root-1 root-2)
 699       (rotatef (root-x root-1) (root-x root-2))
 700       (rotatef (root-y root-1) (root-y root-2))
 701       (rotatef (root-w root-1) (root-w root-2))
 702       (rotatef (root-h root-1) (root-h root-2))))
 703
 704   (defun rotate-root-geometry ()
 705     (let* ((current (first root-list))
 706            (orig-x (root-x current))
 707            (orig-y (root-y current))
 708            (orig-w (root-w current))
 709            (orig-h (root-h current)))
 710       (dolist (elem (rest root-list))
 711         (setf (root-x current) (root-x elem)
 712               (root-y current) (root-y elem)
 713               (root-w current) (root-w elem)
 714               (root-h current) (root-h elem)
 715               current elem))
 716       (let ((last (car (last root-list))))
 717         (setf (root-x last) orig-x
 718               (root-y last) orig-y
 719               (root-w last) orig-w
 720               (root-h last) orig-h))))
 721
 722   (defun anti-rotate-root-geometry ()
 723     (setf root-list (nreverse root-list))
 724     (rotate-root-geometry)
 725     (setf root-list (nreverse root-list)))
 726
 727   ;;; Current child functions
 728   (defun current-child ()
 729     current-child)
 730
 731   (defun current-child-setter (value)
 732     (awhen (find-root value)
 733       (setf (root-current-child it) value))
 734     (setf current-child value))
 735
 736   (defmacro with-current-child ((new-child) &body body)
 737     "Temporarly change the current child"
 738     (let ((old-child (gensym))
 739           (ret (gensym)))
 740       `(let ((,old-child (current-child)))
 741          (setf (current-child) ,new-child)
 742          (let ((,ret (multiple-value-list (progn ,@body))))
 743            (setf (current-child) ,old-child)
 744            (values-list ,ret)))))
 745
 746   (defun child-is-a-current-child-p (child)
 747     (find child root-list :test #'child-equal-p :key #'root-current-child)))
 748
 749 (defsetf current-child current-child-setter)
 750
 751
 752 (defun is-in-current-child-p (child)
 753   (and (frame-p (current-child))
 754        (child-member child (frame-child (current-child)))))
 755
 756
 757
 758 (defun fixe-real-size (frame parent)
 759   "Fixe real (pixel) coordinates in float coordinates"
 760   (when (frame-p frame)
 761     (with-slots (x y w h rx ry rw rh) frame
 762       (setf x (x-px->fl rx parent)
 763             y (y-px->fl ry parent)
 764             w (w-px->fl (anti-adj-border-wh rw parent) parent)
 765             h (h-px->fl (anti-adj-border-wh rh parent) parent)))))
 766
 767 (defun fixe-real-size-current-child ()
 768   "Fixe real (pixel) coordinates in float coordinates for children in the current child"
 769   (when (frame-p (current-child))
 770     (dolist (child (frame-child (current-child)))
 771       (fixe-real-size child (current-child)))))
 772
 773
 774
 775 ;;; Multiple physical screen helper
 776 (defun add-placed-frame-tmp (frame n)   ;; For test
 777   (add-frame (create-frame :x 0.01 :y 0.01 :w 0.4 :h 0.4) frame)
 778   (add-frame (create-frame :x 0.55 :y 0.01 :w 0.4 :h 0.4) frame)
 779   (add-frame (create-frame :x 0.03 :y 0.5 :w 0.64 :h 0.44) frame)
 780   (when (plusp n)
 781     (add-placed-frame-tmp (first (frame-child frame)) (1- n))))
 782
 783 (defun parse-xinerama-info (line)
 784   (remove nil
 785           (mapcar (lambda (string)
 786                     (parse-integer string :junk-allowed t))
 787                   (split-string (substitute #\space #\x (substitute #\space #\, line))))))
 788
 789 (defun get-connected-heads-size (&optional (fake (string= (getenv "DISPLAY") ":1")))
 790   (labels ((heads-info ()
 791              (if (not fake)
 792                  (do-shell "xdpyinfo -ext XINERAMA")
 793                  (progn
 794                    (setf *show-root-frame-p* t)
 795                    (do-shell "echo '    available colormap entries:    256 per subfield
 796     red, green, blue masks:    0xff0000, 0xff00, 0xff
 797     significant bits in color specification:    8 bits
 798
 799 XINERAMA version 1.1 opcode: 150
 800   head #0: 500x300 @ 10,10
 801   head #1: 480x300 @ 520,20
 802   head #2: 600x250 @ 310,330'")))))
 803     (when (xlib:query-extension *display* "XINERAMA")
 804       (let ((output (heads-info))
 805             (sizes nil))
 806         (loop for line = (read-line output nil nil)
 807            while line
 808            do (when (search " head " line)
 809                 (destructuring-bind (w h x y)
 810                     (parse-xinerama-info line)
 811                   (push (list x y w h) sizes))))
 812         ;;(remove-duplicates sizes :test #'equal)))))
 813         ;;'((10 10 500 300) (550 50 400 400) (100 320 400 270))))))
 814         '((10 10 500 580) (540 50 470 500))))))
 815
 816
 817 (defun place-frames-from-xinerama-infos ()
 818   "Place frames according to xdpyinfo/xinerama informations"
 819   (let ((sizes (get-connected-heads-size))
 820         (width (xlib:screen-width *screen*))
 821         (height (xlib:screen-height *screen*)))
 822     (dbg sizes)
 823     (loop while (< (length (frame-child *root-frame*)) (length sizes))
 824        do (let ((frame (create-frame)))
 825             (add-frame frame *root-frame*)))
 826     (loop for size in sizes
 827        for frame in (frame-child *root-frame*)
 828        do (destructuring-bind (x y w h) size
 829             (setf (frame-x frame) (float (/ x width))
 830                   (frame-y frame) (float (/ y height))
 831                   (frame-w frame) (float (/ w width))
 832                   (frame-h frame) (float (/ h height)))
 833             ;;(add-placed-frame-tmp frame 2)  ;; For tests
 834             (add-frame (create-frame) frame)
 835             (define-as-root frame x y w h)))
 836     (setf (current-child) (first (frame-child (first (frame-child *root-frame*)))))))
 837
 838
 839
 840
 841 (defun get-all-windows (&optional (root *root-frame*))
 842   "Return all windows in root and in its children"
 843   (let ((acc nil))
 844     (with-all-windows (root window)
 845       (push window acc))
 846     acc))
 847
 848
 849 (defun get-hidden-windows ()
 850   "Return all hiddens windows"
 851   (let ((all-windows (get-all-windows))
 852         (hidden-windows (remove-if-not #'window-hidden-p
 853                                        (copy-list (xlib:query-tree *root*)))))
 854     (set-difference hidden-windows all-windows)))
 855
 856
 857
 858 ;;; Current window utilities
 859 (defun get-current-window ()
 860   (typecase (current-child)
 861     (xlib:window  (current-child))
 862     (frame (frame-selected-child (current-child)))))
 863
 864 (defmacro with-current-window (&body body)
 865   "Bind 'window' to the current window"
 866   `(let ((window (get-current-window)))
 867       (when (xlib:window-p window)
 868         ,@body)))
 869
 870 (defun get-first-window ()
 871   (typecase (current-child)
 872     (xlib:window  (current-child))
 873     (frame (or (first (frame-child (current-child)))
 874                (current-child)))))
 875
 876
 877
 878
 879
 880 (defun display-frame-info (frame)
 881   (when (frame-p frame)
 882     (let ((dy (+ (xlib:max-char-ascent *default-font*) (xlib:max-char-descent *default-font*))))
 883       (with-slots (name number gc window child hidden-children) frame
 884         (setf (xlib:gcontext-background gc) (get-color *frame-background*)
 885               (xlib:window-background window) (get-color *frame-background*))
 886         (clear-pixmap-buffer window gc)
 887         (setf (xlib:gcontext-foreground gc) (get-color (if (and (child-root-p frame)
 888                                                                 (child-equal-p frame (current-child)))
 889                                                            *frame-foreground-root* *frame-foreground*)))
 890         (xlib:draw-glyphs *pixmap-buffer* gc 5 dy
 891                           (format nil "Frame: ~A~A"
 892                                   number
 893                                   (if name  (format nil " - ~A" name) "")))
 894         (let ((pos dy))
 895           (when (child-root-p frame)
 896             (when *child-selection*
 897               (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 898                                 (with-output-to-string (str)
 899                                   (format str "  Selection: ")
 900                                   (dolist (child *child-selection*)
 901                                     (typecase child
 902                                       (xlib:window (format str "  ~A " (xlib:wm-name child)))
 903                                       (frame (format str "  frame:~A[~A] " (frame-number child)
 904                                                      (aif (frame-name child) it "")))))))))
 905           (dolist (ch child)
 906             (xlib:draw-glyphs *pixmap-buffer* gc 5 (incf pos dy)
 907                               (format nil "  ~A" (ensure-printable (child-fullname ch))))))
 908         (copy-pixmap-buffer window gc)
 909         (values t t)))))
 910
 911
 912 (defun display-all-frame-info ()
 913   (with-all-frames (*root-frame* frame)
 914     (display-frame-info frame)))
 915
 916 (defun display-all-root-frame-info ()
 917   (with-all-root-child (root)
 918     (display-frame-info root)))
 919
 920
 921 (defgeneric rename-child (child name))
 922
 923 (defmethod rename-child ((child frame) name)
 924   (setf (frame-name child) name)
 925   (display-frame-info child))
 926
 927 (defmethod rename-child ((child xlib:window) name)
 928   (setf (xlib:wm-name child) name))
 929
 930 (defmethod rename-child (child name)
 931   (declare (ignore child name)))
 932
 933
 934 (defun get-parent-layout (child parent)
 935   (aif (child-root-p child)
 936        (values (- (root-x it) (child-border-size child)) (- (root-y it) (child-border-size child))
 937                (root-w it) (root-h it))
 938        (if (or (frame-p child) (managed-window-p child parent))
 939            (if (frame-p parent)
 940                (aif (frame-layout parent)
 941                     (funcall it child parent)
 942                     (no-layout child parent))
 943                (values (- (child-border-size child)) (- (child-border-size child))
 944                        (xlib:screen-width *screen*)
 945                        (xlib:screen-height *screen*)))
 946            (values (x-drawable-x child) (x-drawable-y child)
 947                    (x-drawable-width child) (x-drawable-height child)))))
 948
 949
 950
 951
 952
 953 (defgeneric adapt-child-to-parent (child parent))
 954
 955 (defmethod adapt-child-to-parent ((window xlib:window) parent)
 956   (when (managed-window-p window parent)
 957     (multiple-value-bind (nx ny nw nh)
 958         (get-parent-layout window parent)
 959       (setf nw (max nw 1)  nh (max nh 1))
 960       (let ((change (or (/= (x-drawable-x window) nx)
 961                         (/= (x-drawable-y window) ny)
 962                         (/= (x-drawable-width window) nw)
 963                         (/= (x-drawable-height window) nh))))
 964         (when change
 965           (setf (x-drawable-x window) nx
 966                 (x-drawable-y window) ny
 967                 (x-drawable-width window) nw
 968                 (x-drawable-height window) nh))
 969         change))))
 970
 971
 972 (defmethod adapt-child-to-parent ((frame frame) parent)
 973   (declare (ignore parent))
 974     (with-slots (rx ry rw rh window) frame
 975       (let ((change (or (/= (x-drawable-x window) rx)
 976                         (/= (x-drawable-y window) ry)
 977                         (/= (x-drawable-width window) rw)
 978                         (/= (x-drawable-height window) rh))))
 979         (when change
 980           (setf (x-drawable-x window) rx
 981                 (x-drawable-y window) ry
 982                 (x-drawable-width window) rw
 983                 (x-drawable-height window) rh))
 984         change)))
 985
 986 (defmethod adapt-child-to-parent (child parent)
 987   (declare (ignore child parent))
 988   nil)
 989
 990
 991 (defgeneric set-child-stack-order (window child)
 992   (:documentation "Raise window if child is NIL else put window just below child"))
 993
 994 (defmethod set-child-stack-order (window (child xlib:window))
 995   (lower-window window child))
 996
 997 (defmethod set-child-stack-order (window (child frame))
 998   (lower-window window (frame-window child)))
 999
1000 (defmethod set-child-stack-order (window child)
1001   (declare (ignore child))
1002   (raise-window window))
1003
1004
1005
1006 (defgeneric show-child (child parent previous))
1007
1008 (defmethod show-child ((frame frame) parent previous)
1009   (declare (ignore parent))
1010   (with-slots (window show-window-p) frame
1011     (if (and show-window-p
1012              (or *show-root-frame-p* (not (child-root-p frame))))
1013         (progn
1014           (map-window window)
1015           (set-child-stack-order window previous)
1016           (display-frame-info frame))
1017         (hide-window window))))
1018
1019
1020
1021 (defun hide-unmanaged-window-p (parent)
1022   (let ((action (frame-data-slot parent :unmanaged-window-action)))
1023     (case action
1024       (:hide t)
1025       (:show nil)
1026       (t *hide-unmanaged-window*))))
1027
1028
1029 (defmethod show-child ((window xlib:window) parent previous)
1030   (if (or (managed-window-p window parent)
1031           (child-equal-p window (current-child))
1032           (not (hide-unmanaged-window-p parent))
1033           (child-is-a-current-child-p parent))
1034       (progn
1035         (map-window window)
1036         (set-child-stack-order window previous))
1037       (hide-window window)))
1038
1039 (defmethod show-child (child parent raise-p)
1040   (declare (ignore child parent raise-p))
1041   ())
1042
1043
1044 (defgeneric hide-child (child))
1045
1046 (defmethod hide-child ((frame frame))
1047   (with-slots (window) frame
1048     (xlib:unmap-window window)))
1049
1050 (defmethod hide-child ((window xlib:window))
1051   (hide-window window))
1052
1053 (defmethod hide-child (child)
1054   (declare (ignore child))
1055   ())
1056
1057
1058 (defgeneric select-child (child selected))
1059
1060 (labels ((get-selected-color (child selected-p)
1061            (get-color (cond ((child-equal-p child (current-child)) *color-selected*)
1062                             (selected-p *color-maybe-selected*)
1063                             (t *color-unselected*)))))
1064   (defmethod select-child ((frame frame) selected-p)
1065     (when (and (frame-p frame) (frame-window frame))
1066       (setf (xlib:window-border (frame-window frame))
1067             (get-selected-color frame selected-p))))
1068
1069   (defmethod select-child ((window xlib:window) selected-p)
1070     (setf (xlib:window-border window)
1071           (get-selected-color window selected-p)))
1072
1073   (defmethod select-child (child selected)
1074     (declare (ignore child selected))
1075     ()))
1076
1077 (defun select-current-frame (selected)
1078   (select-child (current-child) selected))
1079
1080 (defun unselect-all-frames ()
1081   (with-all-children (*root-frame* child)
1082     (select-child child nil)))
1083
1084
1085
1086 (defun set-focus-to-current-child ()
1087   (labels ((rec (child)
1088              (typecase child
1089                (xlib:window (focus-window child))
1090                (frame (rec (frame-selected-child child))))))
1091     (no-focus)
1092     (rec (current-child))))
1093
1094
1095
1096
1097 (defun adapt-frame-to-parent (frame parent)
1098   (multiple-value-bind (nx ny nw nh)
1099       (get-parent-layout frame parent)
1100     (with-slots (rx ry rw rh window) frame
1101       (setf rx nx  ry ny
1102             rw (max nw 1)
1103             rh (max nh 1)))))
1104
1105
1106 (defun adapt-child-to-rect (rect)
1107   (let ((window (typecase (child-rect-child rect)
1108                   (xlib:window (when (managed-window-p (child-rect-child rect) (child-rect-parent rect))
1109                                  (child-rect-child rect)))
1110                   (frame (frame-window (child-rect-child rect))))))
1111     (when window
1112       (let ((change (or (/= (x-drawable-x window) (child-rect-x rect))
1113                         (/= (x-drawable-y window) (child-rect-y rect))
1114                         (/= (x-drawable-width window) (child-rect-w rect))
1115                         (/= (x-drawable-height window) (child-rect-h rect)))))
1116         (when change
1117           (setf (x-drawable-x window) (child-rect-x rect)
1118                 (x-drawable-y window) (child-rect-y rect)
1119                 (x-drawable-width window) (child-rect-w rect)
1120                 (x-drawable-height window) (child-rect-h rect)))
1121         change))))
1122
1123
1124
1125
1126 (defun show-all-children (&optional (from-root-frame nil))
1127   "Show all children and hide those not in a root frame"
1128   (let ((geometry-change nil)
1129         (displayed-child nil)
1130         (hidden-child nil))
1131     (labels ((in-displayed-list (child)
1132                (member child displayed-child :test (lambda (c rect)
1133                                                      (child-equal-p c (child-rect-child rect)))))
1134
1135              (add-in-hidden-list (child)
1136                (pushnew child hidden-child :test #'child-equal-p))
1137
1138              (set-geometry (child parent in-current-root child-current-root-p)
1139                (if (or in-current-root child-current-root-p)
1140                    (when (frame-p child)
1141                      (adapt-frame-to-parent child (if child-current-root-p nil parent)))
1142                    (add-in-hidden-list child)))
1143
1144              (recurse-on-frame-child (child in-current-root child-current-root-p selected-p)
1145                (let ((selected-child (frame-selected-child child)))
1146                  (dolist (sub-child (frame-child child))
1147                    (rec sub-child child
1148                         (and selected-p (child-equal-p sub-child selected-child))
1149                         (or in-current-root child-current-root-p)))))
1150
1151              (hidden-child-p (rect)
1152                (dolist (r displayed-child)
1153                  (when (rect-hidden-p r rect)
1154                    (return t))))
1155
1156              (select-and-display (child parent selected-p)
1157                (multiple-value-bind (nx ny nw nh)
1158                    (get-parent-layout child parent)
1159                  (let ((rect (make-child-rect :child child :parent parent
1160                                               :selected-p selected-p
1161                                               :x nx :y ny :w nw :h nh)))
1162                    (if (hidden-child-p rect)
1163                        (add-in-hidden-list child)
1164                        (push rect displayed-child)))))
1165
1166              (display-displayed-child ()
1167                (let ((previous nil))
1168                  (dolist (rect (nreverse displayed-child))
1169                    (when (adapt-child-to-rect rect)
1170                      (setf geometry-change t))
1171                    (select-child (child-rect-child rect) (child-rect-selected-p rect))
1172                    (show-child (child-rect-child rect)
1173                                (child-rect-parent rect)
1174                                previous)
1175                    (setf previous (child-rect-child rect)))))
1176
1177              (rec (child parent selected-p in-current-root)
1178                (let ((child-current-root-p (child-root-p child)))
1179                  (unless (in-displayed-list child)
1180                    (set-geometry child parent in-current-root child-current-root-p))
1181                  (when (frame-p child)
1182                    (recurse-on-frame-child child in-current-root child-current-root-p selected-p))
1183                  (when (and (or in-current-root child-current-root-p)
1184                             (not (in-displayed-list child)))
1185                    (select-and-display child parent selected-p)))))
1186
1187       (rec *root-frame* nil t (child-root-p *root-frame*))
1188       (display-displayed-child)
1189       (dolist (child hidden-child)
1190         (hide-child child))
1191       (set-focus-to-current-child)
1192       (xlib:display-finish-output *display*)
1193       geometry-change)))
1194
1195
1196
1197
1198 (defun hide-all-children (root &optional except)
1199   "Hide all root children"
1200   (when (and (frame-p root) (not (child-equal-p root except)))
1201     (dolist (child (frame-child root))
1202       (hide-all child except))))
1203
1204 (defun hide-all (root &optional except)
1205   "Hide root and all its children"
1206   (unless (child-equal-p root except)
1207     (hide-child root))
1208   (hide-all-children root except))
1209
1210
1211
1212
1213
1214 (defun focus-child (child parent)
1215   "Focus child - Return true if something has change"
1216   (when (and (frame-p parent)
1217              (child-member child (frame-child parent)))
1218     (when (not (child-equal-p child (frame-selected-child parent)))
1219       (with-slots ((parent-child child) selected-pos) parent
1220         (setf parent-child (nth-insert selected-pos child (child-remove child parent-child))))
1221       t)))
1222
1223 (defun focus-child-rec (child parent)
1224   "Focus child and its parents - Return true if something has change"
1225   (let ((change nil))
1226     (labels ((rec (child parent)
1227                (when (focus-child child parent)
1228                  (setf change t))
1229                (when parent
1230                  (rec parent (find-parent-frame parent)))))
1231       (rec child parent))
1232     change))
1233
1234
1235 (defun set-current-child-generic (child)
1236   (unless (child-equal-p (current-child) child)
1237     (setf (current-child) child)
1238     t))
1239
1240 (defgeneric set-current-child (child parent window-parent))
1241
1242 (defmethod set-current-child ((child xlib:window) parent window-parent)
1243   (set-current-child-generic (if window-parent parent child)))
1244
1245 (defmethod set-current-child ((child frame) parent window-parent)
1246   (declare (ignore parent window-parent))
1247   (set-current-child-generic child))
1248
1249 (defmethod set-current-child (child parent window-parent)
1250   (declare (ignore child parent window-parent))
1251   ())
1252
1253
1254 (defun set-current-root (child parent window-parent)
1255   "Set current root if parent is not in current root"
1256   (let ((root (find-root child)))
1257     (when (and root window-parent
1258                (not (child-root-p child))
1259                (not (find-child parent (root-child root))))
1260       (change-root root parent)
1261       t)))
1262
1263 (defun focus-all-children (child parent &optional (window-parent t))
1264   "Focus child and its parents -
1265 For window: set current child to window or its parent according to window-parent"
1266   (let ((new-focus (focus-child-rec child parent))
1267         (new-current-child (set-current-child child parent window-parent))
1268         (new-root (set-current-root child parent window-parent)))
1269     (or new-focus new-current-child new-root)))
1270
1271
1272
1273
1274 (defun select-next-level ()
1275   "Select the next level in frame"
1276   (select-current-frame :maybe)
1277   (when (frame-p (current-child))
1278     (awhen (frame-selected-child (current-child))
1279       (setf (current-child) it)))
1280   (show-all-children))
1281
1282 (defun select-previous-level ()
1283   "Select the previous level in frame"
1284   (unless (child-root-p (current-child))
1285     (select-current-frame :maybe)
1286     (awhen (find-parent-frame (current-child))
1287       (setf (current-child) it))
1288     (show-all-children)))
1289
1290
1291 (defun enter-frame ()
1292   "Enter in the selected frame - ie make it the root frame"
1293   (let ((root (find-root (current-child))))
1294     (when (and root (not (child-equal-p (root-child root) (current-child))))
1295       (change-root root (current-child)))
1296     (show-all-children t)))
1297
1298 (defun leave-frame ()
1299   "Leave the selected frame - ie make its parent the root frame"
1300   (let ((root (find-root (current-child))))
1301     (unless (or (child-equal-p (root-child root) *root-frame*)
1302                 (child-original-root-p (root-child root)))
1303       (awhen (and root (find-parent-frame (root-child root)))
1304         (when (frame-p it)
1305           (change-root root it)))
1306       (show-all-children))))
1307
1308
1309 ;;; Other actions (select-next-child, select-next-brother...) are in
1310 ;;; clfswm-circulate-mode.lisp
1311
1312
1313
1314 (defun frame-lower-child ()
1315   "Lower the child in the current frame"
1316   (when (frame-p (current-child))
1317     (with-slots (child selected-pos) (current-child)
1318       (unless (>= selected-pos (length child))
1319         (when (nth (1+ selected-pos) child)
1320           (rotatef (nth selected-pos child)
1321                    (nth (1+ selected-pos) child)))
1322         (incf selected-pos)))
1323     (show-all-children)))
1324
1325
1326 (defun frame-raise-child ()
1327   "Raise the child in the current frame"
1328   (when (frame-p (current-child))
1329     (with-slots (child selected-pos) (current-child)
1330       (unless (< selected-pos 1)
1331         (when (nth (1- selected-pos) child)
1332           (rotatef (nth selected-pos child)
1333                    (nth (1- selected-pos) child)))
1334         (decf selected-pos)))
1335     (show-all-children)))
1336
1337
1338 (defun frame-select-next-child ()
1339   "Select the next child in the current frame"
1340   (when (frame-p (current-child))
1341     (with-slots (child selected-pos) (current-child)
1342       (unless (>= selected-pos (length child))
1343         (incf selected-pos)))
1344     (show-all-children)))
1345
1346
1347 (defun frame-select-previous-child ()
1348   "Select the previous child in the current frame"
1349   (when (frame-p (current-child))
1350     (with-slots (child selected-pos) (current-child)
1351       (unless (< selected-pos 1)
1352         (decf selected-pos)))
1353     (show-all-children)))
1354
1355
1356
1357 (defun switch-to-root-frame (&key (show-later nil))
1358   "Switch to the root frame"
1359   (let ((root (find-root (current-child))))
1360     (when root
1361       (change-root root (root-original root)))
1362     (unless show-later
1363       (show-all-children t))))
1364
1365 (defun switch-and-select-root-frame (&key (show-later nil))
1366   "Switch and select the root frame"
1367   (let ((root (find-root (current-child))))
1368     (when root
1369       (change-root root (root-original root))
1370       (setf (current-child) (root-original root)))
1371     (unless show-later
1372       (show-all-children t))))
1373
1374
1375 (defun toggle-show-root-frame ()
1376   "Show/Hide the root frame"
1377   (setf *show-root-frame-p* (not *show-root-frame-p*))
1378   (show-all-children))
1379
1380
1381
1382 (defun prevent-current-*-equal-child (child)
1383   " Prevent current-root and current-child equal to child"
1384   (if (child-original-root-p child)
1385       nil
1386       (progn
1387         (awhen (child-root-p child)
1388           (change-root it (find-parent-frame child)))
1389         (when (child-equal-p child (current-child))
1390           (awhen (find-root child)
1391             (setf (current-child) (root-child it))))
1392         t)))
1393
1394
1395
1396 (defun remove-child-in-frame (child frame)
1397   "Remove the child in frame"
1398   (when (frame-p frame)
1399     (setf (frame-child frame) (child-remove child (frame-child frame)))))
1400
1401 (defun remove-child-in-frames (child root)
1402   "Remove child in the frame root and in all its children"
1403   (with-all-frames (root frame)
1404     (remove-child-in-frame child frame)))
1405
1406
1407 (defun remove-child-in-all-frames (child)
1408   "Remove child in all frames from *root-frame*"
1409   (when (prevent-current-*-equal-child child)
1410     (remove-child-in-frames child *root-frame*)))
1411
1412
1413 (defun delete-child-in-frames (child root)
1414   "Delete child in the frame root and in all its children
1415 Warning:frame window and gc are freeed."
1416   (with-all-frames (root frame)
1417     (remove-child-in-frame child frame)
1418     (unless (find-frame-window (frame-window frame))
1419       (awhen (frame-gc frame) (xlib:free-gcontext it) (setf it nil))
1420       (awhen (frame-window frame) (xlib:destroy-window it) (setf it nil))))
1421   (when (xlib:window-p child)
1422     (netwm-remove-in-client-list child)))
1423
1424
1425 (defun delete-child-in-all-frames (child)
1426   "Delete child in all frames from *root-frame*"
1427   (when (prevent-current-*-equal-child child)
1428     (delete-child-in-frames child *root-frame*)))
1429
1430 (defun delete-child-and-children-in-frames (child root)
1431   "Delete child and its children in the frame root and in all its children
1432 Warning:frame window and gc are freeed."
1433   (when (and (frame-p child) (frame-child child))
1434     (dolist (ch (frame-child child))
1435       (delete-child-and-children-in-frames ch root)))
1436   (delete-child-in-frames child root))
1437
1438 (defun delete-child-and-children-in-all-frames (child &optional (close-methode 'delete-window))
1439   "Delete child and its children in all frames from *root-frame*"
1440   (when (prevent-current-*-equal-child child)
1441     (delete-child-and-children-in-frames child *root-frame*)
1442     (when (xlib:window-p child)
1443       (funcall close-methode child))
1444     (show-all-children)))
1445
1446
1447 (defun clean-windows-in-all-frames ()
1448   "Remove all xlib:windows present in *root-frame* and not in the xlib tree"
1449   (let ((x-tree (xlib:query-tree *root*)))
1450     (with-all-frames (*root-frame* frame)
1451       (dolist (child (frame-child frame))
1452         (when (xlib:window-p child)
1453           (unless (member child x-tree :test #'xlib:window-equal)
1454             (when (prevent-current-*-equal-child child)
1455               (setf (frame-child frame)
1456                     (child-remove child (frame-child frame))))))))))
1457
1458
1459
1460 (defun do-all-frames-nw-hook (window)
1461   "Call nw-hook of each frame."
1462   (catch 'nw-hook-loop
1463     (let ((found nil))
1464       (with-all-frames (*root-frame* frame)
1465         (awhen (frame-nw-hook frame)
1466           (setf found (call-hook it frame window))))
1467       found)))
1468
1469
1470
1471 (defun process-new-window (window)
1472   "When a new window is created (or when we are scanning initial
1473 windows), this function dresses the window up and gets it ready to be
1474 managed."
1475   (setf (xlib:window-event-mask window) *window-events*)
1476   (set-window-state window +normal-state+)
1477   (setf (x-drawable-border-width window) (case (window-type window)
1478                                               (:normal *border-size*)
1479                                               (:maxsize *border-size*)
1480                                               (:transient *border-size*)
1481                                               (t *border-size*)))
1482   (grab-all-buttons window)
1483   (unless (never-managed-window-p window)
1484     (unless (do-all-frames-nw-hook window)
1485       (call-hook *default-nw-hook* *root-frame* window)))
1486   (netwm-add-in-client-list window))
1487
1488
1489
1490
1491 (defun with-all-mapped-windows (screen fun)
1492   (let ((all-windows (get-all-windows)))
1493     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1494       (unless (child-member win all-windows)
1495         (let ((map-state (xlib:window-map-state win))
1496               (wm-state (window-state win)))
1497           (unless (or (eql (xlib:window-override-redirect win) :on)
1498                       (eql win *no-focus-window*)
1499                       (is-notify-window-p win))
1500             (when (or (eql map-state :viewable)
1501                       (eql wm-state +iconic-state+))
1502               (funcall fun win))))))))
1503
1504 (defun store-root-background ()
1505   (with-all-mapped-windows *screen* #'hide-window)
1506   (setf *background-image* (xlib:create-pixmap :width (xlib:screen-width *screen*)
1507                                                :height (xlib:screen-height *screen*)
1508                                                :depth (xlib:screen-root-depth *screen*)
1509                                                :drawable *root*)
1510         *background-gc* (xlib:create-gcontext :drawable *background-image*
1511                                               :foreground (get-color *frame-foreground*)
1512                                               :background (get-color *frame-background*)
1513                                               :font *default-font*
1514                                               :line-style :solid))
1515   (xlib:copy-area *root* *background-gc*
1516                   0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*)
1517                   *background-image* 0 0)
1518   (with-all-mapped-windows *screen* #'unhide-window))
1519
1520
1521
1522
1523 (defun hide-existing-windows (screen)
1524   "Hide all existing windows in screen"
1525   (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1526     (hide-window win)))
1527
1528
1529
1530 (defun process-existing-windows (screen)
1531   "Windows present when clfswm starts up must be absorbed by clfswm."
1532   (setf *in-process-existing-windows* t)
1533   (let ((id-list nil)
1534         (all-windows (get-all-windows)))
1535     (dolist (win (xlib:query-tree (xlib:screen-root screen)))
1536       (unless (child-member win all-windows)
1537         (let ((map-state (xlib:window-map-state win))
1538               (wm-state (window-state win)))
1539           (unless (or (eql (xlib:window-override-redirect win) :on)
1540                       (eql win *no-focus-window*)
1541                       (is-notify-window-p win)
1542                       (never-managed-window-p win))
1543             (when (or (eql map-state :viewable)
1544                       (eql wm-state +iconic-state+))
1545               (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win)
1546               (unhide-window win)
1547               (process-new-window win)
1548               (map-window win)
1549               (raise-window win)
1550               (pushnew (xlib:window-id win) id-list))))))
1551     (netwm-set-client-list id-list))
1552   (setf *in-process-existing-windows* nil))
1553
1554
1555 ;;; Child order manipulation functions
1556 (defun put-child-on-top (child parent)
1557   "Put the child on top of its parent children"
1558   (when (frame-p parent)
1559     (setf (frame-child parent) (cons child (child-remove child (frame-child parent)))
1560           (frame-selected-pos parent) 0)))
1561
1562 (defun put-child-on-bottom (child parent)
1563   "Put the child at the bottom of its parent children"
1564   (when (frame-p parent)
1565     (setf (frame-child parent) (append (child-remove child (frame-child parent)) (list child))
1566           (frame-selected-pos parent) 0)))
1567
1568