src/clfswm-internal.lisp

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