src/clfswm-internal.lisp

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