src/clfswm-internal.lisp

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