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