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