src/clfswm-internal.lisp

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