merlin-1.3.1/0000755000175000017500000000000010101724003014422 5ustar marillatmarillat00000000000000merlin-1.3.1/clock.jl0000644000175000017500000001443607472223606016100 0ustar marillatmarillat00000000000000;; merlin/clock.jl -- a bad clock ;; version -0.2.1 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv clock.jl ~/.sawfish/lisp/merlin ;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. ;; You're probably best off unpacking the entire merlin.tgz archive. ;; Then add to your .sawfishrc: ;; (require 'merlin.clock) ;; (defclock clock) ;; Then restart sawfish. A clock should appear in the top left corner ;; of your screen. ;; Go to Customize->Matched Windows->Sawlet/clock->Edit... ;; - Here you can specify a position for the window, border type, etc. ;; Also go to Customize->Sawlets->Clock ;; - Here you can customize the behaviour of the clock. ;; You can create multiple clocks and can configure them programatically ;; at creation if you want.. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; one has to ask... why? ;;;; (define-structure merlin.clock (export defclock) (open rep rep.regexp rep.system rep.io.timers sawfish.wm.custom sawfish.wm.fonts sawfish.wm.images sawfish.wm.misc sawfish.wm.ext.tooltips sawfish.wm.util.x merlin.sawlet) ;; (define (dimensions clock) (let ((dim (drawable-dimensions clock))) (if (eq 'vertical (sawlet-config clock 'orientation)) (cons (cdr dim) (car dim)) dim))) (define (drawable-dimensions clock) ; TODO: need XTextExtents... (cons (sawlet-config clock 'breadth) (+ (font-ascent (sawlet-config clock 'font)) 3))) ;; descent (define format-matches ; TODO: ignore %%evil `(("%(c|Ec|r|s|S|OS|T|X|EX|\\+)" . 1) ("%(M|OM|R)" . 60) ("%(H|OH|I|OI|k|l)" . 3600))) (define (clock-granularity clock) (let ((format (sawlet-config clock 'format)) (cache (sawlet-get clock 'granularity))) (cdr (or (and (equal (car cache) format) cache) (sawlet-put clock 'granularity (cons format (catch 'out (mapc (lambda (match) (when (string-match (car match) format) (throw 'out (cdr match)))) format-matches) 86400))))))) (define (start clock) (sawlet-put clock 'drawable (x-create-pixmap (drawable-dimensions clock)) x-destroy-drawable) (timeout clock)) (define (stop clock) (sawlet-put clock 'timer nil delete-timer) (sawlet-put clock 'drawable nil x-destroy-drawable) (sawlet-put clock 'image nil)) (define (expose-handler clock event) (let ((image (sawlet-get clock 'image)) (window (sawlet-get clock 'window))) (and image (x-draw-image image window (cons 0 0)))) nil) (define (button-press-handler clock event) nil) (define (enter-notify-handler clock event) (let ((tooltips-enabled t)) (display-tooltip-after-delay (current-time-string) (sawlet-frame clock))) nil) (define (timeout clock) (let* ((window (sawlet-get clock 'window)) (drawable (sawlet-get clock 'drawable)) (gc (sawlet-get clock 'gc)) (font (sawlet-config clock 'font)) (dims (drawable-dimensions clock)) (background (sawlet-config clock 'background)) (foreground (sawlet-config clock 'foreground)) (time (current-time-string nil (sawlet-config clock 'format))) (x (quotient (- (car dims) (text-width time font)) 2)) (y (font-ascent font)) (granularity (clock-granularity clock)) image) (x-change-gc gc `((foreground . ,background))) (x-fill-rectangle drawable gc (cons 0 0) dims) (x-change-gc gc `((foreground . ,foreground))) (x-draw-string drawable gc (cons x y) time font) (setq image (make-image-from-x-drawable (x-window-id drawable))) (when (eq 'vertical (sawlet-config clock 'orientation)) (flip-image-vertically image) (flip-image-diagonally image)) (sawlet-put clock 'image image) (expose-handler clock nil) ; TODO: figure out finer grained now to catch second change more accurately (sawlet-put clock 'timer (make-timer (lambda () (timeout clock)) (- granularity (% (cdr (current-time)) granularity)) 0) delete-timer))) ;; (defmacro defclock (clock . keys) `(progn (require 'merlin.sawlet) ,(append `(defsawlet ,clock) keys ; allow override `(:start ,start :stop ,stop :pre-configure ,stop :post-configure ,start :dimensions ,dimensions :expose-handler ,expose-handler :button-press-handler ,button-press-handler :enter-notify-handler ,enter-notify-handler :defcustom (orientation 'vertical "Orientation." :type (choice vertical horizontal) :after-set sawlet-reconfigure) :defcustom (breadth 64 "Breadth." :type (number 1 1024) :after-set sawlet-reconfigure) :defcustom (format "%H:%M:%S" "Display format." :tooltip "Format (a text string containing escapes):\n %H = hour (00..23)\n %l = hour ( 1..12)\n %M = minute (00..59)\n %S = second (00..60)\n %y = year (00..99)\n %m = month (01..12)\n %d = day of month (01..31)\netc. (man 3 strftime)" :type string :after-set sawlet-reconfigure)))))) merlin-1.3.1/fishbowl.jl0000644000175000017500000002317507472223771016625 0ustar marillatmarillat00000000000000;; merlin/fishbowl.jl -- a bad fishbowl ;; version -0.4.4 ;; Copyright (C) 2000 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv fishbowl.jl ~/.sawfish/lisp/merlin ;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. ;; You're probably best off unpacking the entire merlin.tgz archive. ;; Then add to your .sawfishrc: ;; (require 'merlin.fishbowl) ;; (deffishbowl fishbowl) ;; Then restart sawfish. A fishbowl should appear in the top right corner ;; of your screen (or wherever you have configured your sawlets). ;; Go to Customize->Sawlets->Fishpond ;; - Here you can customize the behaviour of the fishbowl. In particuar, ;; use Shrinkage to configure that the the fishbowl should treat ;; fish as being smaller than they claim to be. This is useful ;; because most dockapps have transparent border space. ;; Next, go to Customize->Matched Windows ;; - Here you must add a matched window setting for any fish that you ;; want captured to have Place mode fishbowl. You can also set ;; Placement weight to assert an order on the fish in the bolw; ;; currently they are ordered left-to-right, least weight first. ;; Now, restart your apps. Hopefully they'll swim in the fishbowl. ;; You can create multiple fishbowls and can configure them programatically ;; at creation if you want.. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; This is PRE-ALPHA INCOMPLETE SOFTWARE! ;; this is a bit hacky! ;; allow left/right/up/down placement, N columns/rows. ;; I don't restore fish border width. ;; the popup fishbowl window capture item seems to always capture ;; into 'fishbowl, not subsequent fishbowls that I define.. ;; TODO: lots of config stuff possible... ;; put fish in subwindows so their borders do not stick out ;;;; (define-structure merlin.fishbowl (export deffishbowl fishbowl-eject popup-fishbowl-menu) (open rep rep.regexp rep.system rep.io.timers sawfish.wm.colors sawfish.wm.commands sawfish.wm.events sawfish.wm.fonts sawfish.wm.frames sawfish.wm.menus sawfish.wm.placement sawfish.wm.misc sawfish.wm.stacking sawfish.wm.windows sawfish.wm.util.x merlin.sawlet merlin.util merlin.x-util) ;; (define (dimensions fishbowl) (let* ((fishes (sawlet-get fishbowl 'fish)) (shrinkage (sawlet-config fishbowl 'shrinkage)) (spacing (sawlet-config fishbowl 'spacing)) (dim (cons (- spacing) 0))) (mapc (lambda (fish) (let ((d (cons- (cadr fish) (cons* shrinkage 2)))) (rplaca dim (+ (car dim) (car d) spacing)) (rplacd dim (max (cdr dim) (cdr d))))) fishes) (cons-max dim 4))) (define fishbowls nil) (define (start fishbowl) (setq fishbowls (nconc fishbowls (list fishbowl))) (mapc (lambda (window) (when (eq fishbowl (window-get window 'place-mode)) (after-add-window-eye window))) (managed-windows))) (define (mapfish thunk fishbowl) (let* ((shrinkage (sawlet-config fishbowl 'shrinkage)) (spacing (sawlet-config fishbowl 'spacing)) (pos (cons- shrinkage)) (fishes (sawlet-get fishbowl 'fish))) (mapc (lambda (fish) (thunk fish pos) (rplaca pos (- (+ (car pos) spacing (caadr fish)) (* 2 (car shrinkage))))) fishes))) (define (stop fishbowl) (let* ((base (window-position (sawlet-frame fishbowl)))) (setq fishbowls (delq fishbowl fishbowls)) (mapfish (lambda (fish pos) ;; (x-reparent-window (car fish) nil (cons+ base pos)) - doesn't work (x-map-request (car fish))) fishbowl) (sawlet-put fishbowl 'fish nil))) (define (capture fishbowl) (let* ((window (select-window))) (when (and window (not (eq window (sawlet-frame fishbowl)))) (window-put window 'place-mode fishbowl) (after-add-window-eye window)))) (define (eject fishbowl id) (let* ((base (window-position (sawlet-frame fishbowl)))) (mapfish (lambda (fish pos) (when (eq id (car fish)) (sawlet-put fishbowl 'suspend t) ;; (x-reparent-window id nil (cons+ base pos)) - doesn't work (x-map-request id) (sawlet-put fishbowl 'suspend nil))) fishbowl) (sawlet-put fishbowl 'fish (delete-if (lambda (fish) (eq id (car fish))) (sawlet-get fishbowl 'fish))) (sawlet-reconfigure fishbowl))) (require 'rep.io.files) (define (log a . rest) (let ((file (open-file "/tmp/log" 'append))) (format file "%s %s\n" a rest) (close-file file))) (define (replace fishbowl) (mapfish (lambda (fish pos) (x-configure-window (car fish) `((x . ,(car pos)) (y . ,(cdr pos))))) fishbowl)) (define (place window)) (define (after-add-window-eye window) (let* ((fishbowl (window-get window 'place-mode))) (when (and (memq fishbowl fishbowls) (not (sawlet-get fishbowl 'suspend))) (let* ((id (window-id window)) (dim (window-dimensions window)) (weight (or (window-get window 'placement-weight) -1)) (fishes (cons nil (sawlet-get fishbowl 'fish)))) (x-change-window-attributes id `((override-redirect . ,t))) (x-map-notify id) ; this removes it from window-manager (x-change-window-attributes id `((override-redirect . ,nil))) (x-configure-window id `((border-width . 0))) (x-reparent-window id (sawlet-get fishbowl 'window) (cons 0 0)) (let loop ((rest fishes)) (if (or (null (cdr rest)) (> (nth 2 (cadr rest)) weight)) (rplacd rest (cons (list id dim weight) (cdr rest))) (loop (cdr rest)))) (sawlet-put fishbowl 'fish (cdr fishes)) (sawlet-reconfigure fishbowl) (x-x-map-window id))))) (add-hook 'after-add-window-hook after-add-window-eye) ;; (define (popup-fishbowl-menu window) (let* ((fishbowl (sawlet-from-frame window))) (when (memq fishbowl fishbowls) (popup-menu `((,(_ "_Capture") ,(lambda () (capture fishbowl))) (,(_ "_Eject") . ,(mapcar (lambda (fish) (list (aref (x-get-text-property (car fish) 'WM_NAME) 0) (lambda () (eject fishbowl (car fish))))) (sawlet-get fishbowl 'fish)))))))) (define-command 'popup-fishbowl-menu popup-fishbowl-menu #:spec "%W") ;; (define (configure-request-handler fishbowl event) (let ((id (cdr (assq 'window event))) (width (cdr (assq 'width event))) (height (cdr (assq 'height event))) (fishes (sawlet-get fishbowl 'fish))) (mapc (lambda (fish) (when (and (equal id (nth 0 fish)) (not (and (equal width (caadr fish)) (equal height (cdadr fish))))) (x-configure-window id `((width . ,width) (height . ,height))) (rplaca (cdr fish) (cons width height)) (sawlet-reconfigure fishbowl))) fishes)) t) ;; configure subwindows?? other attrs - border-width sibling stack-mode (define (destroy-notify-handler fishbowl event) (let* ((id (cdr (assq 'window event))) (fishes (sawlet-get fishbowl 'fish))) (sawlet-put fishbowl 'fish (delete-if (lambda (fish) (eq id (car fish))) fishes)) (sawlet-reconfigure fishbowl)) nil) (define (expose-handler fishbowl event) ;; todo: draw tiles + internal bars (x-clear-window (sawlet-get fishbowl 'window)) nil) (define (button-press-handler fishbowl event) (popup-fishbowl-menu (sawlet-frame fishbowl)) nil) (define (pre fishbowl) (define-placement-mode fishbowl place)) (defmacro deffishbowl (fishbowl . keys) `(progn (require 'merlin.sawlet) ,(append `(defsawlet ,fishbowl :pre ,pre) keys ; allow override `(:start ,start :stop ,stop :post-configure ,replace :dimensions ,dimensions :expose-handler ,expose-handler :button-press-handler ,button-press-handler :destroy-notify-handler ,destroy-notify-handler :configure-request-handler ,configure-request-handler :font ,nil :foreground ,nil :background ,(get-color-rgb 0 0 0) :defcustom (shrinkage (cons 0 0) "Shrinkage." :type (pair (number 0 8) (number 0 8)) :after-set sawlet-reconfigure) :defcustom (spacing 4 "Spacing." :type (number 0 8) :after-set sawlet-reconfigure) ))))) merlin-1.3.1/iconbox.jl0000644000175000017500000004105407472223527016444 0ustar marillatmarillat00000000000000;; merlin/iconbox.jl -- a bad icon manager ;; version -0.98.1 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv iconbox.jl ~/.sawfish/lisp/merlin ;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. ;; You're probably best off unpacking the entire merlin.tgz archive. ;; Then add to your .sawfishrc: ;; (require 'merlin.iconbox) ;; (deficonbox iconbox) ;; Then restart sawfish. An icon box should appear in the top right corner ;; of your screen. ;; Go to Customize->Sawlets->Iconbox ;; - Here you can customize the behaviour of the icon box ;; Also go to Customize->Matched Windows->^Sawlet/iconbox$->Edit... ;; - Here you can specify a border type for the window, etc. ;; You can create multiple icon boxes and can configure them programatically ;; at creation if you want.. but you probably don't.. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; TODO: Orientation, ... hover delay ..., tooltips, ... use icon name ;; TODO: only display windows iconified on current viewport/workspace. ;; TODO: support dragging into iconbox? ; BUG: I don't understand why, but if you click then drag a fraction ; (preferably, but not necessarily to outside of the icon) then wait ; a while then containue the drag, nothing happens. but if you ; only wait a short while before continuing then it works. ; I don't get the events?? ; Events are lost. But it is not me (I think). ;;;; (define-structure merlin.iconbox (export deficonbox) (open rep rep.system rep.io.timers sawfish.wm.colors sawfish.wm.events sawfish.wm.fonts sawfish.wm.menus sawfish.wm.misc sawfish.wm.stacking sawfish.wm.viewport sawfish.wm.windows sawfish.wm.workspace sawfish.wm.commands.move-resize sawfish.wm.ext.tooltips sawfish.wm.state.iconify sawfish.wm.util.display-window sawfish.wm.util.x merlin.sawlet merlin.util merlin.x-util) ;;;; (define (schedule iconbox window) (sawlet-put iconbox 'hover-pending window) (if (eq window (sawlet-get iconbox 'hover-window)) (sawlet-put iconbox 'hover-timer nil delete-timer) (sawlet-put iconbox 'hover-timer (make-timer (lambda () (timeout iconbox)) 0 333) delete-timer))) (define (timeout iconbox) (let ((hover (sawlet-get iconbox 'hover-window)) (pending (sawlet-get iconbox 'hover-pending))) (when hover (when (equal (sawlet-get iconbox 'hover-new-position) (window-position hover)) (move-window-to hover (sawlet-get iconbox 'hover-old-x) (sawlet-get iconbox 'hover-old-y))) (restack-windows (sawlet-get iconbox 'hover-stacking)) ;; TODO: only really want to replace hover (hide-window hover)) (when (sawlet-put iconbox 'hover-window pending) (sawlet-put iconbox 'hover-pending nil) (sawlet-put iconbox 'hover-stacking (stacking-order)) (let ((pos (window-position pending))) (sawlet-put iconbox 'hover-old-x (car pos)) (sawlet-put iconbox 'hover-old-y (cdr pos))) (show-window pending) (raise-window pending) (when (window-outside-viewport-p pending) (move-window-to-current-viewport pending)) (sawlet-put iconbox 'hover-new-position (window-position pending)) (call-hook 'enter-notify-hook (list pending 'normal))))) ;;;; (define (dimensions iconbox) (let* ((columns (sawlet-config iconbox 'icon-columns))) (cons (* columns (sawlet-config iconbox 'icon-width)) (if (sawlet-config iconbox 'fixed-height) (sawlet-config iconbox 'height) (* (max 1 (ceil (length (sawlet-get iconbox 'icons)) columns)) (+ (font-height (sawlet-config iconbox 'icon-font)) (* 2 (car (sawlet-config iconbox 'icon-border))))))))) (define (icon-foo iconbox icon foo) (sawlet-config iconbox (if (eq icon (sawlet-get iconbox 'focused-icon)) (intern (format nil "focused-%s" foo)) foo))) (define (icon-position iconbox icon) (let ((columns (sawlet-config iconbox 'icon-columns)) (index (index-of icon (sawlet-get iconbox 'icons)))) (cons (* (% index columns) (sawlet-config iconbox 'icon-width)) (* (quotient index columns) (+ (font-height (sawlet-config iconbox 'icon-font)) (* 2 (car (sawlet-config iconbox 'icon-border)))))))) (define (icon-dimensions iconbox icon) ; ? use max heights ? (cons- (cons (sawlet-config iconbox 'icon-width) (+ (font-height (sawlet-config iconbox 'icon-font)) (* 2 (car (sawlet-config iconbox 'icon-border))))) (* 2 (car (icon-foo iconbox icon 'icon-border))))) (define (icon-reconfigure iconbox icon) (let* ((pos (icon-position iconbox icon)) (dim (icon-dimensions iconbox icon)) (border (icon-foo iconbox icon 'icon-border))) (x-configure-window icon `((x . ,(car pos)) (y . ,(cdr pos)) (width . ,(car dim)) (height . ,(cdr dim)) (border-width . ,(car border)))) (x-change-window-attributes icon `((background . ,(cdr (icon-foo iconbox icon 'icon-color))) (border-color . ,(cdr border)))) (icon-repaint iconbox icon))) (define (icon-repaint iconbox icon) (let* ((window (x-window-get icon 'window)) (gc (sawlet-get iconbox 'gc)) (title (window-name window)) (font (icon-foo iconbox icon 'icon-font))) (x-clear-window icon) (x-change-gc gc `((foreground . ,(car (icon-foo iconbox icon 'icon-color))))) (x-draw-string icon gc (cons 1 (font-ascent font)) title font))) (define (icon-button-press-handler iconbox event) (let* ((icon (cdr (assq 'window event))) (window (x-window-get icon 'window)) (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event)))) (button (cdr (assq 'button event)))) (cond ((eq button 'button-1) (sawlet-put iconbox 'click-xy xy) (sawlet-put iconbox 'click-window window)) ((eq button 'button-3) (current-event-window window) (popup-window-menu window)))) nil) (define (icon-motion-notify-handler iconbox event) (let* ((icon (cdr (assq 'window event))) (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event)))) (oxy (or (sawlet-get 'iconbox 'click-xy) xy)) (delta (cons- xy oxy)) (bd (car (icon-foo iconbox icon 'icon-border))) (nxy (cons- (query-pointer) oxy bd))) (when (> (+cons (cons* delta delta)) 36) (sawlet-put iconbox 'click-window nil (lambda (w) (when (eq w (sawlet-get iconbox 'hover-window)) (sawlet-put iconbox 'hover-window nil)) (when (eq w (sawlet-get iconbox 'hover-pending)) (sawlet-put iconbox 'hover-pending nil) (sawlet-put iconbox 'hover-timer nil delete-timer)) (unless (window-appears-in-workspace-p w current-workspace) (move-window-to-workspace w (nearest-workspace-with-window w current-workspace) current-workspace)) (move-window-to w (car nxy) (cdr nxy)) (uniconify-window w) (setq move-window-initial-pointer-offset (cons+ oxy bd)) (move-window-interactively w))))) nil) (define (icon-button-release-handler iconbox event) (let* ((button (cdr (assq 'button event)))) (cond ((eq button 'button-1) (sawlet-put iconbox 'click-window nil display-window)))) nil) (define (icon-enter-notify-handler iconbox event) (let* ((icon (cdr (assq 'window event))) (window (x-window-get icon 'window))) (sawlet-put iconbox 'focused-icon icon) (icon-reconfigure iconbox icon) (when (sawlet-config iconbox 'hover-show) (schedule iconbox window) (when (eq window (sawlet-get iconbox 'hover-window)) (call-hook 'enter-notify-hook (list window 'normal))))) nil) (define (icon-leave-notify-handler iconbox event) (let* ((icon (cdr (assq 'window event))) (window (x-window-get icon 'window))) (sawlet-put iconbox 'focused-icon nil) (icon-reconfigure iconbox icon) (schedule iconbox nil) (when (eq window (sawlet-get iconbox 'hover-window)) (call-hook 'leave-notify-hook (list window 'normal)))) nil) (define (icon-expose-handler iconbox event) (icon-repaint iconbox (cdr (assq 'window event))) nil) (define icon-event-handlers `((button-press . ,icon-button-press-handler) (motion-notify . ,icon-motion-notify-handler) (button-release . ,icon-button-release-handler) (enter-notify . ,icon-enter-notify-handler) (leave-notify . ,icon-leave-notify-handler) (expose . ,icon-expose-handler))) (define (icon-event-handler type window event) (let ((handler (assq type icon-event-handlers))) (when handler ((cdr handler) (x-window-get window 'sawlet) event)))) ;;;; (define (after-add-window-eye iconbox window) (when (window-get window 'iconified) (iconify-window-eye iconbox window))) (define (iconify-window-eye iconbox window) (unless (not (window-mapped-p window)) (let* ((icon (x-create-window (cons 1024 1024) (cons 16 16) 0 `((parent . ,(sawlet-get iconbox 'window)) (override-redirect . t) (event-mask . (button-press button-motion button-release enter-window leave-window exposure))) icon-event-handler))) (x-window-put icon 'sawlet iconbox) (x-window-put icon 'window window) (window-put window (sawlet-symbol iconbox 'icon) icon) (sawlet-put iconbox 'icons (nconc (sawlet-get iconbox 'icons) (list icon))) (x-x-map-window icon) (sawlet-reconfigure iconbox)))) (define (uniconify-window-eye iconbox window) (when (or (eq window (sawlet-get iconbox 'hover-window)) (eq window (sawlet-get iconbox 'hover-pending))) (sawlet-put iconbox 'hover-timer nil delete-timer)) (when (eq window (sawlet-get iconbox 'hover-window)) (sawlet-put iconbox 'hover-window nil) (unless (or (window-get window 'sticky) (window-in-workspace-p window current-workspace)) (hide-window window)) (unless raise-windows-on-uniconify (restack-windows (sawlet-get iconbox 'hover-stacking))) (unless uniconify-to-current-viewport ;; todo: or was moved (move-window-to window (sawlet-get iconbox 'hover-old-x) (sawlet-get iconbox 'hover-old-y)))) (let* ((icon (window-get window (sawlet-symbol iconbox 'icon)))) (when icon (window-put window (sawlet-symbol iconbox 'icon) nil) (sawlet-put iconbox 'icons (delq icon (sawlet-get iconbox 'icons))) (x-destroy-window icon) (sawlet-reconfigure iconbox)))) (define (hover-window-or-a-transient-p iconbox window) (let ((shown (sawlet-get iconbox 'hover-window)) (transient (and (windowp window) (window-transient-p window)))) (or (eq window shown) (and shown (eq transient (window-id shown)))))) (define (enter-notify-eye iconbox window) (when (hover-window-or-a-transient-p iconbox window) (schedule iconbox window))) (define (leave-notify-eye iconbox window) (when (hover-window-or-a-transient-p iconbox window) (schedule iconbox nil))) (define (property-notify-eye iconbox window property state) (let* ((icon (window-get window (sawlet-symbol iconbox 'icon)))) (when (and icon (eq property 'WM_NAME)) (icon-repaint iconbox icon)))) ;;;; (define iconboxes nil) (mapc (lambda (hook) (add-hook (car hook) (lambda (#!rest args) (mapc (lambda (iconbox) (apply (cdr hook) (list* iconbox args))) iconboxes)))) `((after-add-window-hook . ,after-add-window-eye) (iconify-window-hook . ,iconify-window-eye) (uniconify-window-hook . ,uniconify-window-eye) (enter-notify-hook . ,enter-notify-eye) (leave-notify-hook . ,leave-notify-eye) (property-notify-hook . ,property-notify-eye) (unmap-notify-hook . ,uniconify-window-eye) (destroy-notify-hook . ,uniconify-window-eye))) (define (start iconbox) (mapc (lambda (window) (after-add-window-eye iconbox window)) (managed-windows)) (setq iconboxes (nconc iconboxes (list iconbox)))) (define (stop iconbox) (setq iconboxes (delq iconbox iconboxes)) (mapc (lambda (window) (uniconify-window-eye iconbox window)) (managed-windows))) (define (post-configure iconbox) (mapc (lambda (icon) (icon-reconfigure iconbox icon)) (sawlet-get iconbox 'icons))) (define (window-expose-handler iconbox event) (x-clear-window (cdr (assq 'window event))) nil) (define (window-enter-notify-handler iconbox event) (let ((frame (sawlet-frame iconbox))) (call-hook 'enter-notify-hook (list frame 'normal))) nil) (defmacro deficonbox (iconbox . keys) `(progn (require 'merlin.sawlet) ,(append `(defsawlet ,iconbox) keys ; allow override `(:start ,start :stop ,stop :post-configure ,post-configure :dimensions ,dimensions :expose-handler ,window-expose-handler :enter-notify-handler ,window-enter-notify-handler :font ,nil :foreground ,nil :defcustom (icon-columns 2 "Number of icon columns." :type (number 1 20) :after-set sawlet-reconfigure) :defcustom (fixed-height nil "Fixed height." :type boolean :after-set sawlet-reconfigure) :defcustom (height 64 "Height." :type (number 1 1024) :depends fixed-height :after-set sawlet-reconfigure) :defcustom (hover-show t "Temporarily show iconified windows on mouse hover." :type boolean) :defgroup (icons "Icons") :defcustom (icon-width 48 "Icon width." :type (number 1 256) :group (icons) :after-set sawlet-reconfigure) :defcustom (icon-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") "Icon font." :type font :group (icons) :after-set sawlet-reconfigure) :defcustom (icon-color (cons (get-color-rgb 40960 40960 40960) (get-color-rgb 16384 0 0)) "Icon color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (icons) :after-set sawlet-reconfigure) :defcustom (icon-border (cons 1 (get-color-rgb 24576 0 0)) "Icon border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (icons) :after-set sawlet-reconfigure) :defcustom (focused-icon-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") "Focused icon font." :type font :group (icons) :after-set sawlet-reconfigure) :defcustom (focused-icon-color (cons (get-color-rgb 65535 65535 65535) (get-color-rgb 28672 0 0)) "Focused icon color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (icons) :after-set sawlet-reconfigure) :defcustom (focused-icon-border (cons 1 (get-color-rgb 36864 0 0)) "Focused icon border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (icons) :after-set sawlet-reconfigure)))))) merlin-1.3.1/icons.jl0000644000175000017500000003610307472223527016115 0ustar marillatmarillat00000000000000;; merlin/icons.jl -- another bad icon manager ;; version -0.5.3 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv icons.jl ~/.sawfish/lisp/merlin ;; You also need merlin/util.jl, merlin/x-util.jl and merlin/uglicon.jl. ;; Then add to your .sawfishrc: ;; (require 'merlin.icons) ;; Then restart sawfish. Iconified windows should now get little icons. ;; Go to Customize->Icons ;; - Here you can customize the behaviour of the icons. ;; Go to Customize->Icons->Icon keymap ;; - Here you can configure the keymap that is active for icons. ;; - By default, mouse-1 moves the window, double-clicking mouse-1 ;; uniconifies it and mouse 3 brings up the window menu. ;; - In particular you will want to use the "Icon window commands" ;; command, which applies a sequence of commands to the iconified ;; window (as opposed to the icon itself). ;; Go to Customize->Icons->Icon matchers ;; - Here you can configure matched properties for the icons; for ;; example, you can force them all to a low depth or to use a ;; special icon placement mode. You might want to look at ;; merlin.sawlet-placement for an appropriate placement mode. ;; - Icons inherit the name of their parent, so if you want to ;; customize the icons of particular windows you can, to a ;; certain extent. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; TODO: can I share a gc? ;; TODO: does this cope at all well with multiple workspaces? ;; I guess I should inherit workspaces from a parent... and ;; keep up with changes thereto. ;;;; (define-structure merlin.icons (export icons-start icons-stop) (open rep rep.system rep.io.timers sawfish.wm.colors sawfish.wm.commands sawfish.wm.custom sawfish.wm.events sawfish.wm.fonts sawfish.wm.frames sawfish.wm.images sawfish.wm.keymaps sawfish.wm.menus sawfish.wm.misc sawfish.wm.placement sawfish.wm.stacking sawfish.wm.windows sawfish.wm.ext.match-window sawfish.wm.ext.tooltips sawfish.wm.state.iconify sawfish.wm.util.decode-events sawfish.wm.util.keymap sawfish.wm.util.x merlin.uglicon merlin.util merlin.x-util) (defgroup icons "Icons") (defgroup icons-keymap "Icon keymap" :group icons :layout single) (defgroup icons-matchers "Icon matchers" :group icons :layout single :require sawfish.wm.ext.match-window) (defcustom icons-enabled t "Enable icons for iconified windows." :type boolean :group (icons) :after-set (lambda () (icons-go))) (defcustom icons-tooltips t "Show iconified window titles using tooltips." :type boolean :group (icons)) (defcustom icons-background (get-color-rgb 65535 65535 65535) "Icon background color." :type color :group (icons) :after-set (lambda () (icons-reconfigure))) (defcustom icons-show-text t "Show icon names." :type boolean :group (icons) :after-set (lambda () (icons-reconfigure))) (defcustom icons-text-from 'window-name "Source of icon name." :type (choice window-name window-icon-name) :group (icons) :depends icons-show-text :after-set (lambda () (icons-reconfigure))) (defcustom icons-text (cons (get-color-rgb 0 0 0) (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*")) "Appearance of icon names." :type (pair (labelled "Color:" color) (labelled "Font:" font)) :group (icons) :depends icons-show-text :after-set (lambda () (icons-reconfigure))) (defcustom icons-padding (cons 8 8) "Padding around icon." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (icons) :after-set (lambda () (icons-reconfigure))) (defcustom icons-border (cons 1 (get-color-rgb 65535 0 0)) "Internal border around icon." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (icons) :after-set (lambda () (icons-reconfigure))) (defcustom icons-keymap (make-keymap) "" :group (icons icons-keymap) :user-level expert :type keymap) (defcustom icons-match-profile `((((WM_CLASS . "icon/Merlin")) (cycle-skip . t) (window-list-skip . t) (skip-tasklist . t) (never-iconify . t) (frame-type . border-only) (place-mode . none))) nil :group (icons icons-matchers) :type match-window) ;;;; (define (icons-get-icon w) (let ((icon (window-get w 'merlin.icon))) (and icon (get-window-by-id (x-window-id icon))))) (define (icons-get-icon-window w) ;; oh so inefficient, want get-x-window-by-id (let ((id (window-id w))) (catch 'out (mapc (lambda (w) (let ((icon (window-get w 'merlin.icon))) (when (and icon (eq id (x-window-id icon))) (throw 'out w)))) (managed-windows)) nil))) (define (icons-get-text w) (let ((text ((if (eq icons-text-from 'window-name) window-name window-icon-name) w)) (width (+ uglicon-width (* 2 (car icons-padding))))) (trim text (cdr icons-text) width))) ;;;; (define (icon-reconfigure w) (let* ((window (window-get w 'merlin.icon)) (background (x-window-get window 'background)) (gc (x-window-get window 'gc)) (bg-dim (cons+ (cons uglicon-width (+ uglicon-height (if icons-show-text (font-height (cdr icons-text)) 0))) (cons* icons-padding 2))) (win-dim (cons+ bg-dim (* 2 (car icons-border)))) (caption (icons-get-text w))) (x-set-wm-size-hints window win-dim win-dim) (x-window-put window 'caption caption) (x-change-gc gc `((foreground . ,(car icons-text)))) ((x-configure-fn) window `((width . ,(car win-dim)) (height . ,(cdr win-dim)))) (x-change-window-attributes background `((background . ,icons-background) (border-color . ,(cdr icons-border)))) (x-configure-window background `((width . ,(car bg-dim)) (height . ,(cdr bg-dim)) (border-width . ,(car icons-border)))) (icons-repaint w))) ;; could reapply the match-window settings (define (icons-reconfigure) (mapc (lambda (w) (when (window-get w 'merlin.icon) (icon-reconfigure w))) (managed-windows))) ;;;; (define (icons-repaint w) (let* ((window (window-get w 'merlin.icon)) (background (x-window-get window 'background)) (gc (x-window-get window 'gc)) (icon (x-window-get window 'icon)) (icon-pos (cons+ (cons-quotient (cons- (cons uglicon-width uglicon-height) (image-dimensions icon)) 2) icons-padding))) (x-clear-window background) (x-draw-image icon background icon-pos) (when icons-show-text (let* ((caption (x-window-get window 'caption)) (caption-pos (cons (quotient (- (+ uglicon-width (* 2 (car icons-padding))) (text-width caption (cdr icons-text))) 2) (+ uglicon-height (cdr icons-padding) (- (font-height (cdr icons-text)) (font-descent (cdr icons-text))))))) (x-draw-string background gc caption-pos caption (cdr icons-text)))))) ;;;; (define (expose-handler window event) (let ((w (x-window-get window 'parent))) (icons-repaint w)) nil) (define (enter-notify-handler window event) (let ((w (x-window-get window 'parent))) (when icons-tooltips (let ((tooltips-enabled t)) (display-tooltip-after-delay (window-name w) (icons-get-icon w))))) nil) (define (leave-notify-handler window event) (when icons-tooltips (remove-tooltip)) nil) (define (client-message-handler window event) (let* ((message-type (cdr (assq 'message-type event))) (format (cdr (assq 'format event))) (data (cdr (assq 'data event))) (w (x-window-get window 'parent))) (when (and (eq message-type 'WM_PROTOCOLS) (eq format 32) (eq (aref data 0) (x-atom 'WM_DELETE_WINDOW))) (uniconify-window w))) nil) ;; or do I just delete the icon? (define background-event-handlers `((expose . ,expose-handler) (enter-notify . ,enter-notify-handler) (leave-notify . ,leave-notify-handler))) (define window-event-handlers `((client-message . ,client-message-handler))) (define (event-handler type window event handlers) (let ((handler (assq type handlers))) (when handler ((cdr handler) window event)))) ;;;; (define (icons-hook-iconify-window w) (unless (window-get w 'merlin.icon) (let* ((win-pos (or (window-get w 'merlin.icon.position) (window-position w))) (bg-dim (cons+ (cons uglicon-width (+ uglicon-height (if icons-show-text (font-height (cdr icons-text)) 0))) (cons* icons-padding 2))) (win-dim (cons+ bg-dim (* 2 (car icons-border)))) (caption (icons-get-text w)) (icon (get-window-icon w)) (window (x-create-window win-pos win-dim 0 `((override-redirect . ,nil) (event-mask . ,'())) (lambda (type window event) (event-handler type window event window-event-handlers)))) (background (x-create-window (cons 0 0) bg-dim (car icons-border) `((parent . ,window) (background . ,icons-background) (border-color . ,(cdr icons-border)) (override-redirect . ,t) (event-mask . ,'(exposure enter-window leave-window))) (lambda (type window event) (event-handler type window event background-event-handlers)))) (gc (x-create-gc window `((foreground . ,(car icons-text)))))) (x-set-wm-name window (window-name w)) (x-set-wm-icon-name window (window-icon-name w)) (x-set-wm-class window "Merlin" "icon") (x-set-wm-protocols window '(delete-window)) (x-set-wm-size-hints window win-dim win-dim) (x-window-put background 'parent w) (x-window-put window 'parent w) (x-window-put window 'background background) (x-window-put window 'gc gc) (x-window-put window 'icon icon) (x-window-put window 'caption caption) (x-window-put window 'merlin.icons.is-icon t) (window-put w 'merlin.icon window) ((x-map-fn) window) (x-x-map-window background) (icons-repaint w)))) (define (icons-hook-uniconify-window w) (when (window-get w 'merlin.icon) (let* ((window (window-get w 'merlin.icon)) (background (x-window-get window 'background)) (gc (x-window-get window 'gc)) (icon (get-window-by-id (x-window-id window)))) (window-put w 'merlin.icon.position (window-position icon)) (window-put w 'merlin.icon nil) (x-free-gc gc) (x-destroy-window background) (x-destroy-window window)))) (define (icons-hook-after-add-window w) (when (window-get w 'iconified) (icons-hook-iconify-window w))) (define (icons-hook-before-add-window w) (let* ((parent (icons-get-icon-window w)) (match-window-profile icons-match-profile)) (when parent ; it is an icon window (match-window w) (window-put w 'parent parent) (window-put w 'keymap icons-keymap) (when (window-get parent 'sticky) (window-put w 'sticky t)) (when (window-get parent 'sticky-viewport) (window-put w 'sticky-viewport t))))) ; should I note the change? (define (icons-hook-unmap-notify w) (icons-hook-uniconify-window w)) (define (icons-hook-destroy-notify w) (icons-hook-uniconify-window w)) (define (icons-hook-property-notify w property state) (when (eq property (if (eq icons-text-from 'window-name) 'WM_NAME 'WM_ICON_NAME)) (when (and icons-show-text (window-get w 'merlin.icon)) (icon-reconfigure w)))) ;; a bit brutal ;; sawfish doesn't really differentiate sticky and sticky-viewport ;; at this level. (define (window-state-change-eye w state) (let* ((icon (icons-get-icon w))) (when (and icon (memq 'sticky state)) (if (window-sticky-p w) (make-window-sticky icon) (make-window-unsticky icon))))) ;;;; (define icons-hooks `((iconify-window-hook . ,icons-hook-iconify-window) (uniconify-window-hook . ,icons-hook-uniconify-window) (before-add-window-hook . ,icons-hook-before-add-window) (after-add-window-hook . ,icons-hook-after-add-window) (unmap-notify-hook . ,icons-hook-unmap-notify) (destroy-notify-hook . ,icons-hook-destroy-notify) (property-notify-hook . ,icons-hook-property-notify) (window-state-change-hook . ,window-state-change-eye))) (define (icons-add-hooks) (mapc (lambda (hookfun) (unless (in-hook-p (car hookfun) (cdr hookfun)) (add-hook (car hookfun) (cdr hookfun)))) icons-hooks)) (define (icons-remove-hooks) (mapc (lambda (hookfun) (when (in-hook-p (car hookfun) (cdr hookfun)) (remove-hook (car hookfun) (cdr hookfun)))) icons-hooks)) (define (icons-start) (icons-stop) (mapc icons-hook-after-add-window (managed-windows)) (icons-add-hooks)) (define (icons-stop) (icons-remove-hooks) (mapc icons-hook-uniconify-window (managed-windows))) (define (icons-go) ((if icons-enabled icons-start icons-stop))) ;;;; commands (define (icon-window-commands commands) "Invoke commands on an icon's parent window." (let* ((icon (current-event-window)) (parent (and icon (icons-get-icon-window icon)))) (unless parent (error "icon-window-commands invoked on non icon window: %s" icon)) (current-event-window parent) (mapc call-command commands))) (define-command 'icon-window-commands icon-window-commands #:type `(and (quoted (list command ,(_ "Command"))))) ;;;; initialization ;; TODO: how do I get the behaviour that these are only defaults??? (define (bind-key-unless key) (unless (search-keymap (cdr key) icons-keymap) (bind-keys icons-keymap (cdr key) (car key)))) (let ((default-keymap (make-keymap))) (bind-keys default-keymap "Button1-Move" 'move-window-interactively "Button1-Click2" `(icon-window-commands '(uniconify-window)) "Button3-Click1" `(icon-window-commands '(popup-window-menu))) (map-keymap bind-key-unless default-keymap) (map-keymap bind-key-unless window-keymap)) (icons-go)) merlin-1.3.1/menu.jl0000644000175000017500000004016407472223527015750 0ustar marillatmarillat00000000000000;; merlin/menu.jl -- a bad raw sawfish menu ;; version -0.1.2 ;; Copyright (C) 2002 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv icons.jl ~/.sawfish/lisp/merlin ;; You also need merlin/util.jl, merlin/x-util.jl and merlin/uglicon.jl. ;; Then add to your .sawfishrc: ;; (require 'merlin.menu) ;; Then restart sawfish. Menus will now be provided directly by sawfish. ;; Go to Customize->Menus ;; - Here you can customize the appearance of the menus ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; doesn't implement checkboxes and radio buttons ;; doesn't implement keyboard shortcuts ;; keyboard/pointer grabbing isn't done right; you have to hit a key, or ;; click on a window part for which sawfish has a pointer binding to ;; dismiss ;; TODO: bounce to leftwards menus when I hit the RHS so it doesn't ;; just run down the right hand side ;; TODO: make merlin-menu-enabled work ;;;; (define-structure merlin.menu (export merlin-popup-menu merlin-popdown-menu) (open rep rep.regexp rep.system rep.io.timers sawfish.wm.colors sawfish.wm.commands sawfish.wm.custom sawfish.wm.events sawfish.wm.fonts sawfish.wm.frames sawfish.wm.menus sawfish.wm.placement sawfish.wm.misc sawfish.wm.stacking sawfish.wm.windows sawfish.wm.workspace sawfish.wm.ext.match-window sawfish.wm.util.decode-events sawfish.wm.util.groups sawfish.wm.util.x merlin.util merlin.x-util) (defgroup merlin-menu "Menus") ; (defcustom merlin-menu-enabled nil ; "Raw menus enabled." ; :type boolean ; :group (merlin-menu)) (defcustom merlin-menu-color (cons (get-color "black") (get-color "white")) "Menu color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (merlin-menu)) (defcustom merlin-menu-border (cons 1 (get-color "red")) "Menu border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (merlin-menu)) (defcustom merlin-menu-padding (cons 2 2) "Menu padding." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (merlin-menu)) (defcustom merlin-menu-item-font default-font "Menu item font." :type font :group (merlin-menu)) (defcustom merlin-menu-item-color (cons (get-color "black") (get-color "white")) "Menu item color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (merlin-menu)) (defcustom merlin-menu-item-border (cons 1 (get-color "red")) "Menu item border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (merlin-menu)) (defcustom merlin-menu-item-padding (cons 2 2) "Menu item padding." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (merlin-menu)) (defcustom merlin-menu-active-item-font default-font "Active menu item font." :type font :group (merlin-menu)) (defcustom merlin-menu-active-item-color (cons (get-color "white") (get-color "black")) "Active menu item color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (merlin-menu)) (defcustom merlin-menu-active-item-border (cons 1 (get-color "white")) "Active menu item border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (merlin-menu)) (define blank-size 3) (define (invoke action) (when (windowp menu-active) (current-event-window menu-active)) (cond ((commandp action) (call-command action)) ((functionp action) (action)) ((consp action) (user-eval action)))) (define (submenu-p spec) (and spec (consp (car spec)) (stringp (caar spec)))) (define (blank-item-size) (cons+ blank-size (cons* 2 merlin-menu-item-padding))) (define (text-item-size item) (let* ((text (car item)) (action (cadr item)) (fonts (list merlin-menu-item-font merlin-menu-active-item-font)) (max-fh (apply max (mapcar font-height fonts))) (max-tw (apply max (mapcar (lambda (font) (text-width text font)) fonts))) (xw (if (submenu-p action) max-fh 0)) (max-bw (max (car merlin-menu-item-border) (car merlin-menu-active-item-border)))) (cons+ (cons max-tw max-fh) (cons xw 0) (cons* 2 (cons+ merlin-menu-item-padding max-bw))))) (define (item-size item) (if (car item) (text-item-size item) (blank-item-size))) (define (menu-size expanded) (let loop ((rest expanded) (size (cons 0 (cdr merlin-menu-padding)))) (if (null rest) size (loop (cdr rest) (cons-op (cons max +) size (cons+ (item-size (car rest)) (cons* (cons 2 1) merlin-menu-padding))))))) (define (win-repaint win) (let* ((text (x-window-get win 'text)) (gc (x-window-get win 'gc)) (dim (x-window-get win 'dim)) (active (x-window-get win 'active)) (pad merlin-menu-item-padding) (max-bw (max (car merlin-menu-item-border) (car merlin-menu-active-item-border))) (bw (car (if active merlin-menu-active-item-border merlin-menu-item-border))) (color (car (if active merlin-menu-active-item-color merlin-menu-item-color)))) (x-clear-window win) (x-change-gc gc `((foreground . ,color))) (if (null text) (let ((y (+ (quotient blank-size 2) (cdr pad)))) (x-draw-line win gc (cons 0 y) (cons (car dim) y))) (let* ((action (x-window-get win 'action)) (fonts (list merlin-menu-item-font merlin-menu-active-item-font)) (fa (apply max (mapcar font-ascent fonts))) (fd (apply max (mapcar font-descent fonts))) (font (if (x-window-get win 'active) merlin-menu-active-item-font merlin-menu-item-font))) (x-draw-string win gc (cons+ pad (cons 0 fa) (- max-bw bw)) text font) (when (submenu-p action) (let* ((val (quotient (- fa fd 2) 2)) (base (cons- dim pad val 1 (cons 0 fd) max-bw bw))) (x-draw-line win gc (cons- base (cons 0 val)) (cons+ base (cons val 0))) (x-draw-line win gc (cons+ base (cons val 0)) (cons+ base (cons 0 val))))))))) (define (win-update win) (let* ((active (x-window-get win 'active)) (dim (x-window-get win 'dim)) (bg (cdr (if active merlin-menu-active-item-color merlin-menu-item-color))) (border (if active merlin-menu-active-item-border merlin-menu-item-border))) (setq dim (cons- dim (* 2 (car border)))) (x-configure-window win `((width . ,(car dim)) (height . ,(cdr dim)) (border-width . ,(car border)))) (x-change-window-attributes win `((background . ,bg) (border-color . ,(cdr border)))) (win-repaint win))) (define (win-activate win) (unless (x-window-get win 'active) (let* ((action (x-window-get win 'action)) (window (x-window-get win 'window))) (win-deactivate (x-window-get window 'active-win)) (when action (x-window-put win 'active t) (x-window-put window 'active-win win) (win-update win) (when (submenu-p action) (let* ((pos (x-window-get win 'pos)) (dim (x-window-get win 'dim)) (x0 (- (+ (car pos) (car dim)) (car merlin-menu-active-item-border))) (x1 (+ (car pos) (car merlin-menu-active-item-border))) (y (- (cdr pos) (car merlin-menu-border) (cdr merlin-menu-padding))) (submenu (create-menu action (cons (cons x0 x1) y)))) (x-window-put win 'submenu submenu) (x-window-put submenu 'win win))))))) (define (win-deactivate win) (when (and win (x-window-get win 'active)) (let* ((window (x-window-get win 'window)) (submenu (x-window-get win 'submenu))) (when (eq win (x-window-get window 'active-win)) (x-window-put window 'active-win nil)) (x-window-put win 'active nil) (win-update win) (when submenu (let ((subactive-win (x-window-get submenu 'active-win))) (when subactive-win (win-deactivate subactive-win)) (destroy-menu submenu) (x-window-put win 'submenu nil)))))) (define (win-button-press-handler win event) t) (define (win-button-release-handler win event) (let ((active (x-window-get win 'active)) (action (x-window-get win 'action))) (when (and active action (not (submenu-p action))) (throw 'merlin-menu-out (car action)))) t) (define (win-enter-notify-handler win event) (let ((parent-win (x-window-get (x-window-get win 'window) 'win))) (when (and menu (or (null parent-win) (x-window-get parent-win 'active))) (win-activate win))) nil) (define (win-leave-notify-handler win event) (unless (x-window-get win 'submenu) (win-deactivate win)) nil) (define (win-expose-handler win event) (win-repaint win) nil) (define (window-expose-handler window event) (x-clear-window window) nil) (define (window-enter-notify-handler window event) (let ((active-win (x-window-get window 'active-win))) (when active-win (win-deactivate active-win))) nil) (define win-event-handlers `((button-press . ,win-button-press-handler) (button-release . ,win-button-release-handler) (enter-notify . ,win-enter-notify-handler) (leave-notify . ,win-leave-notify-handler) (expose . ,win-expose-handler))) (define window-event-handlers `((enter-notify . ,window-enter-notify-handler) (expose . ,window-expose-handler))) (define root-event-handlers `()) (define (event-handler type window event handlers) (let ((handler (assq type handlers))) (when handler ((cdr handler) window event)))) (define gc-inhibit nil) (define (expand-text text) (when (functionp text) (setq text (apply text menu-args))) (string-replace "_" "" (or text ""))) (define (expand-action action) (when (and (symbolp action) (not (null action))) (setq action (symbol-value action))) (if (functionp action) (apply action menu-args) action)) (define (expand spec) (mapcar (lambda (rawitem) (if (null rawitem) nil (list (expand-text (car rawitem)) (expand-action (cdr rawitem))))) spec)) (define (create-menu spec pos) (let* ((expanded (expand spec)) (dims (menu-size expanded)) (bw (car merlin-menu-border)) (pad merlin-menu-padding) (root-dims (cons+ dims (* 2 bw))) (x (max 0 (if (> (+ (or (caar pos) (car pos)) (car root-dims)) (screen-width)) (- (or (cdar pos) (car pos)) (car root-dims)) (or (caar pos) (car pos))))) (y (max 0 (min (cdr pos) (- (screen-height) (cdr root-dims))))) (root (x-create-window (cons x y) root-dims 0 `((override-redirect . ,t) (event-mask . ())) (lambda (type window event) (event-handler type window event root-event-handlers)))) (window (x-create-window (cons 0 0) dims bw `((parent . ,root) (background . ,(cdr merlin-menu-color)) (border-color . ,(cdr merlin-menu-border)) (override-redirect . ,t) (event-mask . (button-press button-release enter-window exposure))) (lambda (type window event) (event-handler type window event window-event-handlers)))) (gc (x-create-gc root `((foreground . ,(car merlin-menu-color))))) (entry-pos (cons+ 0 merlin-menu-padding)) (wins (mapcar (lambda (item) (let* ((text (car item)) (action (cadr item)) (max-bw (if text (max (car merlin-menu-item-border) (car merlin-menu-active-item-border)) 0)) (entry-bw (if text (car merlin-menu-item-border) 0)) (entry-pad merlin-menu-item-padding) (fonts (list merlin-menu-item-font merlin-menu-active-item-font)) (fh (apply max (mapcar font-height fonts))) (entry-width (- (car dims) (* 2 (car pad)))) (entry-height (+ (if text fh blank-size) (* 2 (+ max-bw (cdr entry-pad))))) (entry-dim (cons entry-width entry-height)) (win (x-create-window entry-pos (cons- entry-dim (* 2 entry-bw)) entry-bw `((parent . ,window) (background . ,(cdr merlin-menu-item-color)) (border-color . ,(cdr merlin-menu-item-border)) (override-redirect ., t) (event-mask . (button-press button-release enter-window leave-window exposure))) (lambda (type window event) (event-handler type window event win-event-handlers))))) (x-window-put win 'window window) (x-window-put win 'gc gc) (x-window-put win 'text text) (x-window-put win 'action action) (x-window-put win 'dim entry-dim) (x-window-put win 'pos (cons+ (cons x y) bw entry-pos)) (x-x-map-window win) (rplacd entry-pos (+ (cdr entry-pos) entry-height (cdr pad))) (setq gc-inhibit (cons win gc-inhibit)) ; HACK win)) expanded))) (setq gc-inhibit (cons root (cons window gc-inhibit))) (x-window-put window 'root root) (x-window-put window 'gc gc) (x-window-put window 'menu menu) (x-window-put window 'wins wins) (x-x-map-window window) (x-x-map-window root) window)) (define (destroy-menu menu) (x-destroy-window (x-window-get menu 'root))) (define menu nil) (define menu-active nil) (define menu-args nil) ;; this is horrendous; I can't do a proper pointer-grab so I simulate it ;; with a throw on either a key press or a mouse-click on a known window. ;; clicks on windows without a binding will be ignored; I really need to ;; grab everyone's buttons, but I have a hard time doing this... especially ;; override-redirect windows (define (thrower) (let ((event (and (current-event) (decode-event (current-event))))) (when (or (and (eq (car event) 'key) (not (memq 'release (cadr event)))) (and (eq (car event) 'mouse) (eq 'click-1 (caddr event)))) (throw 'merlin-menu-out nil)))) (define (merlin-popup-menu spec . args) (merlin-popdown-menu) (when (functionp spec) (setq spec (spec))) (or spec (error "No menu given to merlin-popup-menu")) (setq menu-active (or (current-event-window) (input-focus))) (setq menu-args args) (let* ((part (clicked-frame-part)) (class (and part (frame-part-get part 'class))) (pos (if (and class (windowp menu-active) (string-match "-button$" (symbol-name class))) (let ((tmp-pos (cons+ (window-position menu-active) (frame-part-position part))) (tmp-dim (frame-part-dimensions part))) (cons (cons (car tmp-pos) (+ (car tmp-pos) (car tmp-dim))) (+ (cdr tmp-pos) (cdr tmp-dim)))) (query-pointer)))) (ungrab-pointer) (ungrab-keyboard) (sync-server) (invoke (catch 'merlin-menu-out (when (grab-keyboard) (unwind-protect (let ((override-keymap (make-keymap)) (focus-ignore-pointer-events t)) (add-hook 'unbound-key-hook thrower) (setq menu (create-menu spec pos)) (recursive-edit)) (merlin-popdown-menu) (remove-hook 'unbound-key-hook thrower) (ungrab-keyboard) (let ((w (query-pointer-window))) ;; catch up focus (when w (call-hook 'enter-notify-hook (list w 'normal)))))))))) (define (merlin-popdown-menu) (when menu (win-deactivate (x-window-get menu 'active-win)) (destroy-menu menu) (setq gc-inhibit nil) (setq menu nil))) (eval-in `(progn (require 'merlin.menu) (define (popup-menu spec) (apply merlin-popup-menu spec (fluid menu-args)))) 'sawfish.wm.menus)) merlin-1.3.1/message.jl0000644000175000017500000001651307477425330016432 0ustar marillatmarillat00000000000000;; merlin/message.jl -- fancier message display ;; version 0.5.2 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; this is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; this is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;; TODO: click to hide? ;; NB: icon handling willnot remain the ugly same!! (define-structure merlin.message (export fancy-message hide-fancy-message) (open rep sawfish.wm.misc sawfish.wm.colors sawfish.wm.fonts sawfish.wm.images sawfish.wm.windows.subrs sawfish.wm.util.x merlin.util) (define message-window nil) (define message-gc nil) (define message-msg nil) (define message-attrs nil) (define message-pos (cons 0 0)) (define message-dims (cons 0 0)) (define default-message-padding (cons 4 4)) (define default-message-foreground "black") (define default-message-background "white") (define default-message-border-color "black") (define default-message-border-width 1) (define default-message-spacing 1) (define default-message-position (cons-quotient (screen-dimensions) 2)) (define (repaint-message-window id) (when (eq id message-window) (let ((pad (cdr (assqd 'padding message-attrs default-message-padding))) (fg (colorify (cdr (assqd 'foreground message-attrs default-message-foreground)))) (font (fontify (cdr (assq 'font message-attrs)))) (justify (cdr (assqd 'x-justify message-attrs 'left))) (spacing (cdr (assqd 'spacing message-attrs default-message-spacing))) (w (car message-dims)) x y) (setq y (cdr pad)) (x-clear-window message-window) (x-change-gc message-gc `((foreground . ,fg))) (mapcar (lambda (msg) (when (stringp msg) (cond ((eq 'left justify) (setq x (car pad))) ((eq 'center justify) (setq x (quotient (- w (text-width msg font)) 2))) (t ;; (eq 'right justify) (setq x (- w (text-width msg font) (car pad))))) (setq y (+ y (font-ascent font) spacing)) ;; spacing not on first line! (x-draw-string message-window message-gc (cons x y) msg font) (setq y (+ y (font-descent font)))) (when (imagep msg) (setq y (+ y spacing)) ;; spacing not on first line! (x-draw-image msg message-window (cons (quotient (- w (car (image-dimensions msg))) 2) y)) (setq y (+ y (cdr (image-dimensions msg))))) (when (consp msg) (cond ((eq 'font (car msg)) (setq font (fontify (cdr msg)))) ((eq 'foreground (car msg)) (x-change-gc message-gc `((foreground . ,(colorify (cdr msg)))))) ((eq 'x-justify (car msg)) (setq justify (cdr msg))) ((eq 'spacing (car msg)) (setq spacing (cdr msg)))))) message-msg)))) (define (calculate-message-window-dimensions) (let ((pad (cdr (assqd 'padding message-attrs default-message-padding))) (font (fontify (cdr (assq 'font message-attrs)))) (spacing (cdr (assqd 'spacing message-attrs default-message-spacing)))) (setq message-dims (cons (* 2 (car pad)) (* 2 (cdr pad)))) (mapcar (lambda (msg) (when (stringp msg) (rplaca message-dims (max (car message-dims) (+ (* 2 (car pad)) (text-width msg font)))) (rplacd message-dims (+ (cdr message-dims) spacing (font-height font)))) ;; spacing not on first line! (when (imagep msg) (rplacd message-dims (+ (cdr message-dims) spacing (cdr (image-dimensions msg))))) ;; spacing not on first line! (when (consp msg) (cond ((eq 'font (car msg)) (setq font (fontify (cdr msg)))) ((eq 'spacing (car msg)) (setq spacing (cdr msg)))))) message-msg))) (define (calculate-message-window-position) (let* ((pos (cdr (assqd 'position message-attrs default-message-position))) (bw (cdr (assqd 'border-width message-attrs default-message-border-width))) (dim (cons+ message-dims bw bw)) (gravity (cdr (assqd 'gravity message-attrs 'center)))) (setq message-pos (cons-max (cons-min (gravitate pos dim gravity) (cons- (screen-dimensions) dim)) 0)))) (define (expose-handler window event) (repaint-message-window message-window) nil) (define (message-window-event-handler type window #!optional event) (cond ((eq type 'expose) (expose-handler window event)))) (define (create-message-window) (let* ((bw (cdr (assqd 'border-width message-attrs default-message-border-width))) (bg (colorify (cdr (assqd 'background message-attrs default-message-background)))) (bd (colorify (cdr (assqd 'border-color message-attrs default-message-border-color)))) (window-attrs `((background . ,bg) (border-color . ,bd) (override-redirect . ,t) (save-under . ,nil) (event-mask . ,'(exposure)))) (gc-attrs `((background . ,bg)))) (setq message-window (x-create-window message-pos message-dims bw window-attrs message-window-event-handler)) (setq message-gc (x-create-gc message-window gc-attrs)) (x-map-window message-window t))) (define (update-message-window) (let* ((x (car message-pos)) (y (cdr message-pos)) (w (car message-dims)) (h (cdr message-dims)) (bw (cdr (assqd 'border-width message-attrs default-message-border-width))) (bg (colorify (cdr (assqd 'background message-attrs default-message-background)))) (bd (colorify (cdr (assqd 'border-color message-attrs default-message-border-color)))) (window-config `((x . ,x) (y . ,y) (width . ,w) (height . ,h) (border-width . ,bw) (stack-mode . top-if))) (window-attrs `((background . ,bg)6 (border-color . ,bd))) (gc-attrs `((background . ,bg)))) (x-configure-window message-window window-config) (x-change-window-attributes message-window window-attrs) (x-change-gc message-gc gc-attrs))) ;; supported global attributes: ;; ;; 'position - (x . y) position ;; 'gravity - how the window is positioned relative to position ;; 'font - default font ;; 'foreground - default foreground ;; 'background - default background ;; 'border-color - border color ;; 'font - default font ;; 'x-justify - default justification ;; 'spacing - interline spacing ;; 'padding - (x . y) outer padding ;; 'border-width - border width ;; supported inline attributes: ;; ;; 'font - font ;; 'foreground - foreground ;; 'x-justify - justification ;; 'spacing - interline spacing (define (fancy-message message attrs) (setq message-msg message) (setq message-attrs attrs) (calculate-message-window-dimensions) (calculate-message-window-position) (if message-window (update-message-window) (create-message-window)) (repaint-message-window message-window)) (define (hide-fancy-message) (when message-window (x-destroy-window message-window) (setq message-window nil)) (when message-gc (x-destroy-gc message-gc) (setq message-gc nil)))) merlin-1.3.1/mp3.jl0000644000175000017500000001047307472223527015503 0ustar marillatmarillat00000000000000;; merlin/mp3.jl -- an mp3 playlist menu ;; version 0.2 ;; Copyright (C) 2002 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;; ;; PREREQUISITES ;; ;;;;;;;;;;;;;;;;;;; ;; This requires that you use the X Multimedia System (XMMS), that ;; your mp3 collection is indexed by playlists (.m3u files) which are ;; all present in a single directory, and that your playlist filenames ;; have the form Artist-Title.m3u; e.g., Swans-Real Love.m3u. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv mp3.jl ~/.sawfish/lisp/merlin ;; Then add to your .sawfish/rc: ;; (require 'merlin.mp3) ;; (install-mp3-menu (mp3-menu "/space/mp3" "/cdrom")) ;; ;; . You should change "/space/mp3" to the path of a directory ;; containing your MP3 playlists. ;; ;; . You should change "/cdrom" to the mount point of your CD ;; drive, as configured in XMMS, or nil if you have none. ;; ;; . If you don't want the Music menu placed in your root menu, ;; don't use install-mp3-menu. ;; Then restart sawfish. Your root menu will now have a Music submenu ;; containing a list of your artists; each artist will have a submenu ;; containing their titles. There is also a control submenu and an ;; option to start playing the CD in your drive. (define-structure merlin.mp3 (export mp3-menu install-mp3-menu) (open rep rep.regexp rep.system rep.io.files sawfish.wm.menus) ;; Create an XMMS MP3 playlist menu {Artists}->{Titles} from a ;; directory containing playlists and optional CD mount point. (define (mp3-menu dir #!optional cdrom) (lambda () (nconc (cons `("Control" . (("Play" (system "xmms --play &")) ("Stop" (system "xmms --stop &")) ("Prev" (system "xmms --rew &")) ("Next" (system "xmms --fwd &")))) (and cdrom (cons `("CD" (system ,(concat "xmms " cdrom " &"))) nil))) (let* ((playlist-p (lambda (playlist) (string-match ".m3u$" playlist))) (playlists (sort (delete-if-not playlist-p (directory-files dir)))) (uniquify-sorted (lambda (l) (let loop ((rest l)) (cond ((null rest) l) ((equal (car rest) (cadr rest)) (rplacd rest (cddr rest)) (loop rest)) (t (loop (cdr rest))))))) (artist-f (lambda (playlist) (string-match "-" playlist) (substring playlist 0 (match-start)))) (artists (uniquify-sorted (mapcar artist-f playlists))) (quotees (list 32 40 41 42 44 63)) (quote-file-name (lambda (file) (let loop ((i 0) (s "")) (if (eq i (length file)) s (let ((c (aref file i))) (loop (1+ i) (concat s (and (memq c quotees) 92) c))))))) (play (lambda (playlist) (let* ((quoted (quote-file-name playlist)) (file-name (expand-file-name quoted dir))) (system (concat "xmms " file-name " &")))))) (mapcar (lambda (artist) (cons artist (delq nil (mapcar (lambda (playlist) (and (string-match (concat "^" artist "-") playlist) (list (substring playlist (1+ (length artist)) (- (length playlist) 4)) (lambda () (play playlist))))) playlists)))) artists))))) ;; Install an MP3 menu in the root menu beneath the apps entry, if ;; present; otherwise at the top of the menu. (define (install-mp3-menu mp3-menu) (let ((mp3-entry (lambda (next) (cons (cons "Music" mp3-menu) next)))) (let loop ((menu root-menu)) (cond ((null menu) (setq root-menu (mp3-entry root-menu))) ((eq 'apps-menu (cdar menu)) (rplacd menu (mp3-entry (cdr menu)))) (t (loop (cdr menu))))))))merlin-1.3.1/pager.jl0000644000175000017500000005020710067063452016072 0ustar marillatmarillat00000000000000;; merlin/pager.jl -- a bad pager ;; version -0.91.3 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv pager.jl ~/.sawfish/lisp/merlin ;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. ;; You're probably best off unpacking the entire merlin.tgz archive. ;; Then add to your .sawfishrc: ;; (require 'merlin.pager) ;; (defpager pager) ;; Then restart sawfish. A pager should appear in the top right corner ;; of your screen. ;; Go to Customize->Sawlets->Pager ;; - Here you can customize the behaviour of the pager ;; Also go to Customize->Matched Windows->^Sawlet/pager$->Edit... ;; - Here you can specify a border type for the window, etc. ;; You can create multiple icon boxes and can configure them programatically ;; at creation if you want.. but you probably don't.. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; I divide window dimensions instead of dividing window bounds.. ;; but it looks better. ;; Dragging a win from the very edge can leave the pager with ;; the wrong idea of who is focused at the end of the drag ;; because I suppress enter/leave notification. I could store ;; the last enter/leave notification to resend it after the ;; drag is finished... todo. ;; Dragging a win from the very edge sometimes appears to lose ;; hold of the window. But this could be just a gammy mouse button. ;; The pager does not keep up with merging workspaces.. I just ;; hear a 'workspace-state-changed which is too common for me ;; to do a full rebuild on.. In fact, I think this is a bug in ;; remove-workspace: It does not emit enter-workspace, ;; add-to-workspace or remove-from-workspace. Perhaps I could ;; fix this by noticing changes on the 'workspace* property of ;; windows? ;; If you toggle a window 'ignored (and maybe 'sticky, etc.) ;; I don't pick up on it. I'm not sure that I care. ;; TODO: use icon name ;; TODO: support a delay before drags warp into the pager. ;;;; (define-structure merlin.pager (export defpager) (open rep rep.system rep.io.timers sawfish.wm.colors sawfish.wm.custom sawfish.wm.events sawfish.wm.fonts sawfish.wm.menus sawfish.wm.misc sawfish.wm.stacking sawfish.wm.viewport sawfish.wm.windows sawfish.wm.workspace sawfish.wm.commands.move-resize sawfish.wm.ext.tooltips sawfish.wm.state.iconify sawfish.wm.util.display-window sawfish.wm.util.x merlin.sawlet merlin.util merlin.x-util) (defvar viewport-xy (viewport-offset)) ;; ughlobals, can probably do better (define during-restack nil) ;;;; (define (fix-position pager pos) (cons-quotient (cons+ pos (viewport-offset)) (sawlet-config pager 'divisor))) (define (fix-dimensions pager dim bw) (let ((divisor (sawlet-config pager 'divisor))) (cons-max (cons- (cons-quotient (cons+ dim (cons- divisor 1)) divisor) (* 2 bw)) 0))) (define (dimensions pager) (fix-dimensions pager (cons* viewport-dimensions (screen-dimensions)) 0)) (define (viewport-position pager) (fix-position pager (cons 0 0))) (define (viewport-dimensionz pager) (fix-dimensions pager (screen-dimensions) (car (sawlet-config pager 'viewport-border)))) (define (win-foo pager window foo) (sawlet-config pager (if (eq window (input-focus)) (intern (format nil "focused-%s" foo)) foo))) (define (win-position pager window) (fix-position pager (window-position window))) (define (win-dimensions pager window) (fix-dimensions pager (window-frame-dimensions window) (car (win-foo pager window 'win-border)))) ;;;; (define (win-button-press-handler pager event) (remove-tooltip) (let* ((win (cdr (assq 'window event))) (window (x-window-get win 'window)) (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event)))) (time (cdr (assq 'time event))) (button (cdr (assq 'button event)))) (cond ((and (eq button 'button-1) (not (eq window (sawlet-frame pager)))) (if (and (eq win (sawlet-get pager 'old-drag-win)) (< (- time (sawlet-get pager 'drag-time)) 333)) (display-window window) (sawlet-put pager 'drag-win win) (sawlet-put pager 'drag-time time) (sawlet-put pager 'drag-xy xy) (when (and (eq focus-mode 'click) (window-really-wants-input-p window)) (set-input-focus window)))) ((eq button 'button-3) (current-event-window window) (popup-window-menu window)))) nil) ; BUG: If I click, then drag one pixel, then wait, then I ; lose the focus... Also, that first drag event doesn't ; result in the window moving... Obviously because I wait ; until I get that motion before I _start_ the interactive ; move. (define (win-motion-notify-handler pager event) (let* ((win (cdr (assq 'window event))) (window (x-window-get win 'window)) (xy (cons (cdr (assq 'x event)) (cdr (assq 'y event))))) (when (eq win (sawlet-get pager 'drag-win)) (win-button-release-handler pager event) ;; stop multiple moves (setq move-window-unconstrained t move-window-initial-pointer-offset (cons-max 0 (cons* (sawlet-config pager 'divisor) (cons+ (sawlet-get pager 'drag-xy) (car (win-foo pager window 'win-border)))))) (move-window-interactively window))) nil) (define (win-button-release-handler pager event) (sawlet-put pager 'drag-win nil (lambda (win) (sawlet-put pager 'old-drag-win win))) nil) (define (win-enter-notify-handler pager event) (let* ((win (cdr (assq 'window event))) (window (x-window-get win 'window))) (unless (sawlet-get pager 'drag-win) (let ((tooltips-enabled t)) (display-tooltip-after-delay (window-name window) window)) (call-hook 'enter-notify-hook (list window 'normal)))) nil) (define (win-leave-notify-handler pager event) (let* ((win (cdr (assq 'window event))) (window (x-window-get win 'window))) (unless (sawlet-get pager 'drag-win) (call-hook 'leave-notify-hook (list window 'normal)))) nil) (define (win-repaint pager win) (let* ((window (x-window-get win 'window)) (gc (sawlet-get pager 'gc)) (title (window-name window)) (font (win-foo pager window 'win-font))) (x-clear-window win) (x-change-gc gc `((foreground . ,(car (win-foo pager window 'win-color))))) (x-draw-string win gc (cons 1 (font-ascent font)) title font))) (define (win-expose-handler pager event) (win-repaint pager (cdr (assq 'window event))) nil) (define win-event-handlers `((button-press . ,win-button-press-handler) (motion-notify . ,win-motion-notify-handler) (button-release . ,win-button-release-handler) (enter-notify . ,win-enter-notify-handler) (leave-notify . ,win-leave-notify-handler) (expose . ,win-expose-handler))) (define (win-event-handler type window event) (let ((handler (assq type win-event-handlers))) (when handler ((cdr handler) (x-window-get window 'sawlet) event)))) (define (win-reconfigure pager win) (let* ((window (x-window-get win 'window)) (pos (win-position pager window)) (dim (win-dimensions pager window)) (border (win-foo pager window 'win-border))) (x-configure-window win `((x . ,(car pos)) (y . ,(cdr pos)) (width . ,(car dim)) (height . ,(cdr dim)) (border-width . ,(car border)))) (x-change-window-attributes win `((background . ,(cdr (win-foo pager window 'win-color))) (border-color . ,(cdr border)))) (win-repaint pager win))) ;;;; (define (window-moved-eye pager window) (when (or (equal viewport-xy (viewport-offset)) (window-get window 'sticky-viewport)) (let* ((win (window-get window (sawlet-symbol pager 'win)))) (when win (let* ((pos (win-position pager window)) (dim (win-dimensions pager window))) (x-configure-window win `((x . ,(car pos)) (y . ,(cdr pos)) (width . ,(car dim)) (height . ,(cdr dim))))))))) (define (after-add-window-eye pager window) (unless (or (window-get window 'ignored) (dock-window-p window) (desktop-window-p window) (window-get window (sawlet-symbol pager 'win))) ;; HACK (let* ((border (win-foo pager window 'win-border)) (win (x-create-window (win-position pager window) (win-dimensions pager window) (car border) `((parent . ,(sawlet-get pager 'window)) (background . ,(cdr (win-foo pager window 'win-color))) (border-color . ,(cdr border)) (override-redirect . t) (event-mask . (button-press button-release button-motion enter-window leave-window exposure))) win-event-handler))) (x-window-put win 'sawlet pager) (x-window-put win 'window window) (window-put window (sawlet-symbol pager 'win) win) (when (and (window-mapped-p window) (window-visible-p window)) (x-x-map-window win))))) ; could do this more efficiently with better hooks (define (after-restacking-eye pager) (unless during-restack (let* ((wins (delq nil (mapcar (lambda (window) (window-get window (sawlet-symbol pager 'win))) (stacking-order))))) (setq during-restack t) (unwind-protect (when (car wins) (x-x-raise-window (car wins))) ;; hack ;; that is a weird hack that i don't understand. ;; essentially what happens is I have a big emacs ;; window on the left completely covering an xterm. ;; lower emacs and the xterm appears on top in the ;; pager, as it should. then raise the xterm. its ;; pager window disappears behind the emacs pager ;; window. examining the calls, I am (apparently) ;; correctly calling XRestackWindows but it is not ;; doing what I expect. (x-restack-windows wins)) (setq during-restack nil)))) ;; ?? window-mapped-p and window-visible-p (define (map-notify-eye pager window) (let* ((win (window-get window (sawlet-symbol pager 'win)))) (when win (if (and (window-visible-p window) (window-mapped-p window)) (x-x-map-window win) (x-unmap-window win))))) (define (enter-workspace-eye pager) (stop pager) (start pager)) (define (viewport-moved-eye pager) (post-configure pager)) ;; heavier than necessary (define (viewport-resized-eye pager) (sawlet-reconfigure pager)) ;; heavier than necessary (define (focus-in-eye pager window) (let* ((win (window-get window (sawlet-symbol pager 'win)))) (when win (win-reconfigure pager win)))) (define (focus-out-eye pager window) (let* ((win (window-get window (sawlet-symbol pager 'win)))) (when win (win-reconfigure pager win)))) (define (property-notify-eye pager window property state) (let* ((win (window-get window (sawlet-symbol pager 'win)))) (when (and win (eq property 'WM_NAME)) (win-repaint pager win)))) (define (while-moving-eye pager window) (let* ((frame (sawlet-frame pager)) (pos (cons- (query-pointer) (cons- (window-position frame) (window-frame-offset frame))))) (when (and-cons (cons-and (cons>= pos 0) (cons< pos (window-dimensions frame)))) (let* ((repos (cons- (cons* pos (sawlet-config pager 'divisor)) move-window-initial-pointer-offset (viewport-offset)))) (setq move-window-unconstrained t move-resize-x (car repos) move-resize-y (cdr repos)))))) (define (after-move-eye pager window directions) (sawlet-put pager 'drag-win nil)) ;;;; (define (viewport-expose-handler pager) (x-clear-window (sawlet-get pager 'viewport)) nil) (define (viewport-event-handler type window event) (let ((sawlet (x-window-get window 'sawlet))) (cond ((eq type 'expose) (viewport-expose-handler pager)) ((eq type 'enter-notify) (window-enter-notify-handler pager event))))) (define pagers nil) (mapc (lambda (hook) (add-hook (car hook) (lambda (#!rest args) (mapc (lambda (pager) (apply (cdr hook) (list* pager args))) pagers)))) `((window-moved-hook . ,window-moved-eye) (window-resized-hook . ,window-moved-eye) (window-maximized-hook . ,window-moved-eye) (window-unmaximized-hook . ,window-moved-eye) (place-window-hook . ,after-add-window-eye) ;; hack (after-add-window-hook . ,after-add-window-eye) ;; hack (after-restacking-hook . ,after-restacking-eye) (map-notify-hook . ,map-notify-eye) (unmap-notify-hook . ,map-notify-eye) ;; destroy-notify-hook?? (iconify-window-hook . ,map-notify-eye) (uniconify-window-hook . ,map-notify-eye) (add-to-workspace-hook . ,map-notify-eye) (remove-from-workspace-hook . ,map-notify-eye) (enter-workspace-hook . ,enter-workspace-eye) (viewport-moved-hook . ,viewport-moved-eye) (viewport-resized-hook . ,viewport-resized-eye) (focus-in-hook . ,focus-in-eye) (focus-out-hook . ,focus-out-eye) (property-notify-hook . ,property-notify-eye) (while-moving-hook . ,while-moving-eye) (after-move-hook . ,after-move-eye))) (define (start pager) (let ((viewport (x-create-window (viewport-position pager) (viewport-dimensionz pager) (car (sawlet-config pager 'viewport-border)) `((parent . ,(sawlet-get pager 'window)) (background . ,(sawlet-config pager 'viewport-background)) (border-color . ,(cdr (sawlet-config pager 'viewport-border))) (override-redirect . t) (event-mask . (exposure enter-window))) viewport-event-handler))) (x-window-put viewport 'sawlet pager) (sawlet-put pager 'viewport viewport x-destroy-window) (x-x-map-window viewport)) (mapc (lambda (window) (after-add-window-eye pager window)) (reverse (stacking-order))) (setq pagers (nconc pagers (list pager)))) (define (stop pager) (setq pagers (delq pager pagers)) (mapc (lambda (window) (let ((win (window-get window (sawlet-symbol pager 'win)))) (when win (window-put window (sawlet-symbol pager 'win) nil) (x-destroy-window win)))) (managed-windows)) (sawlet-put pager 'viewport nil x-destroy-window)) (define (post-configure pager) (let ((viewport (sawlet-get pager 'viewport)) (pos (viewport-position pager)) (dim (viewport-dimensionz pager))) (x-configure-window viewport `((x . ,(car pos)) (y . ,(cdr pos)) (width . ,(car dim)) (height . ,(cdr dim)) (border-width . ,(car (sawlet-config pager 'viewport-border))))) (x-change-window-attributes viewport `((background . ,(sawlet-config pager 'viewport-background)) (border-color . ,(cdr (sawlet-config pager 'viewport-border))))) (viewport-expose-handler pager)) (mapc (lambda (window) (let ((win (window-get window (sawlet-symbol pager 'win)))) (when win (win-reconfigure pager win)))) (managed-windows))) (define (window-expose-handler pager event) (x-clear-window (cdr (assq 'window event))) nil) (define (window-enter-notify-handler pager event) (let ((frame (sawlet-frame pager))) (unless (sawlet-get pager 'drag-win) (call-hook 'enter-notify-hook (list frame 'normal)))) nil) (define (window-button-press-handler pager event) (let* ((button (cdr (assq 'button event))) (x (cdr (assq 'x event))) (y (cdr (assq 'y event))) (viewport (cons-quotient (cons* (cons x y) (sawlet-config pager 'divisor)) (screen-dimensions)))) (when (eq button 'button-1) (set-screen-viewport (car viewport) (cdr viewport)))) nil) ;; a hack on sawfish.wm.viewport#set-viewport so I can ignore the myriand ;; move-windows... (eval-in `(let ((old-set-viewport set-viewport)) (define (set-viewport x y) (setq viewport-xy (cons x y)) (old-set-viewport x y))) 'sawfish.wm.viewport) (defmacro defpager (pager . keys) `(progn (require 'merlin.sawlet) ,(append `(defsawlet ,pager) keys ; allow override `(:start ,start :stop ,stop :post-configure ,post-configure :dimensions ,dimensions :expose-handler ,window-expose-handler :enter-notify-handler ,window-enter-notify-handler :button-press-handler ,window-button-press-handler :font ,nil :foreground ,nil :background (get-color-rgb 0 0 0) :defcustom (viewport-background (get-color-rgb 0 8192 0) "Viewport background color." :type color :after-set sawlet-reconfigure) :defcustom (viewport-border (cons 1 (get-color-rgb 0 16384 0)) "Viewport internal border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :after-set sawlet-reconfigure) :defcustom (divisor (cons 24 24) "Divisor from screen to pager." :type (pair (labelled "Horizontal:" (number 2 100)) (labelled "Vertical:" (number 2 100))) :after-set sawlet-reconfigure) :defgroup (windows "Windows") :defcustom (win-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") "Window font." :type font :group (windows) :after-set sawlet-reconfigure) :defcustom (win-color (cons (get-color-rgb 36864 24576 0) (get-color-rgb 16384 0 0)) "Window color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (windows) :after-set sawlet-reconfigure) :defcustom (win-border (cons 1 (get-color-rgb 24576 0 0)) "Window border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (windows) :after-set sawlet-reconfigure) :defcustom (focused-win-font (get-font "-misc-fixed-*-*-*-*-7-*-*-*-*-*-*-*") "Focused window font." :type font :group (windows) :after-set sawlet-reconfigure) :defcustom (focused-win-color (cons (get-color-rgb 65535 65535 0) (get-color-rgb 28672 0 0)) "Focused window color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (windows) :after-set sawlet-reconfigure) :defcustom (focused-win-border (cons 1 (get-color-rgb 36864 0 0)) "Focused window border." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (windows) :after-set sawlet-reconfigure)))))) merlin-1.3.1/pile.jl0000644000175000017500000002566407472223527015745 0ustar marillatmarillat00000000000000;; merlin/pile.jl -- a bad pile ;; version -0.3.1 ;; Copyright (C) 2002 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv pile.jl ~/.sawfish/lisp/merlin ;; You also need merlin/sawlet.jl, merlin/util.jl and merlin/x-util.jl. ;; You're probably best off unpacking the entire merlin.tgz archive. ;; Then add to your .sawfishrc: ;; (require 'merlin.pile) ;; (defpile pile) ;; ; `pile' is the name of the pile; you can choose any name you ;; ; want, and have multiple piles. ;; Then restart sawfish. A pile should appear. ;; Go to Customize->Sawlets->Pile ;; - Here you can customize the behaviour of the pile. ;; Next, go to Customize->Matched Windows ;; - Here you must add a matched window setting for any fish that you ;; want captured to have Place mode pile. ;; Now, restart your apps. Hopefully they'll be in the pile. ;; You can create multiple piles and can configure them programatically ;; at creation if you want.. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; This is PRE-ALPHA INCOMPLETE SOFTWARE! ;; this is a bit hacky! ;; todo: should I tell windows they've moved?? ;; see fishbowl ;; beos-window-menu is hardwired in, which may not be cool ;;;; (define-structure merlin.pile (export defpile pile-p popup-pile-menu pile-window-menu) (open rep rep.regexp rep.system rep.io.timers sawfish.wm.colors sawfish.wm.commands sawfish.wm.events sawfish.wm.fonts sawfish.wm.frames sawfish.wm.menus sawfish.wm.placement sawfish.wm.misc sawfish.wm.stacking sawfish.wm.windows sawfish.wm.ext.beos-window-menu sawfish.wm.util.display-window sawfish.wm.util.x merlin.sawlet merlin.util merlin.x-util) ;; (define (pile-p sawlet) (memq sawlet piles)) (define (dimensions pile) (if (sawlet-active pile) (window-dimensions (sawlet-frame pile)) (cons 64 64))) (define piles nil) (define (start pile) (setq piles (nconc piles (list pile))) (mapc (lambda (window) (when (eq pile (window-get window 'place-mode)) (after-add-window-eye window))) (managed-windows))) (define (mapchattelry thunk pile) (let* ((chattelry (sawlet-get pile 'merlin.pile:chattelry))) (mapc (lambda (chattel) (thunk chattel)) chattelry))) (define (stop pile) (let* ((base (window-position (sawlet-frame pile)))) (setq piles (delq pile piles)) (mapchattelry (lambda (chattel) ;; (x-reparent-window (car chattel) nil base) -- doesn't work anymore (x-map-request (car chattel))) pile) (sawlet-put pile 'merlin.pile:chattelry nil))) (define (capture pile) (let* ((window (select-window))) (when (and window (not (eq window (sawlet-frame pile)))) (window-put window 'place-mode pile) (after-add-window-eye window)))) (define (eject pile id) (let* ((base (window-position (sawlet-frame pile)))) (mapchattelry (lambda (chattel) (when (eq id (car chattel)) (sawlet-put pile 'suspend t) ;; (x-reparent-window id nil base) -- doesn't work anymore? (x-map-request id) (sawlet-put pile 'suspend nil))) pile) (sawlet-put pile 'merlin.pile:chattelry (delete-if (lambda (chattel) (eq id (car chattel))) (sawlet-get pile 'merlin.pile:chattelry))) (sawlet-reconfigure pile))) (define (raise pile id) (let (match) ; this is awful; move to front of list (mapchattelry (lambda (chattel) (when (eq id (car chattel)) (setq match chattel))) pile) (sawlet-put pile 'merlin.pile:chattelry (cons match (delete-if (lambda (chattel) (eq id (car chattel))) (sawlet-get pile 'merlin.pile:chattelry))))) ;; raising is not necessary if I move the others off.. ;; (x-configure-window id `((stack-mode . top-if))) (replace pile)) ;; awful (define (constrain value hints axis) ;; TODO: min-aspect / max-aspect (let ((minn (or (cdr (assq (intern (format nil "min-%s" axis)) hints)) 1)) (maxx (or (cdr (assq (intern (format nil "max-%s" axis)) hints)) 10000)) (base (or (cdr (assq (intern (format nil "base-%s" axis)) hints)) 0)) (inc (or (cdr (assq (intern (format nil "%s-inc" axis)) hints)) 1))) (max minn (min maxx (+ base (* inc (quotient (- value base) inc))))))) (define (replace pile) (let ((root (sawlet-get pile 'root)) (chattel (car (sawlet-get pile 'merlin.pile:chattelry))) (dim (cons- (dimensions pile) 10)) ; for demo purposes (x 0) (y 0)) (x-set-wm-name root (if chattel (format nil "%s - %s" pile (aref (x-get-text-property (car chattel) 'WM_NAME) 0)) "pile")) (mapchattelry (lambda (chattel) (let ((width (constrain (car dim) (nth 2 chattel) 'width)) (height (constrain (cdr dim) (nth 2 chattel) 'height))) (x-configure-window (car chattel) `((x . ,x) (y . ,y) (width . ,width) (height . ,height)))) (setq x (car dim) y (cdr dim))) pile))) ; TODO: now that I have x-get-window-properties I could query the size hints ; during replace, rather than storing them here.. ; TODO: would it be better to do this in add-window-hook? Wouldn't get framed ; before it is deframed... (define (after-add-window-eye window) (let* ((pile (window-get window 'place-mode))) (when (and (memq pile piles) (not (sawlet-get pile 'suspend))) (let* ((id (window-id window)) (dim (window-dimensions window)) (chattelry (sawlet-get pile 'merlin.pile:chattelry)) (hints (window-size-hints window))) (x-change-window-attributes id `((override-redirect . ,t))) (x-map-notify id) ; this removes it from window-manager (x-change-window-attributes id `((override-redirect . ,nil))) (x-configure-window id `((border-width . 0))) (x-reparent-window id (sawlet-get pile 'window) (cons 0 0)) (sawlet-put pile 'merlin.pile:chattelry (cons (list id dim hints) chattelry)) (sawlet-reconfigure pile) (x-x-map-window id))))) (add-hook 'after-add-window-hook after-add-window-eye) ;; (define (abbreviate name #!optional len) (unless len (setq len 20)) (if (> (length name) len) (concat (substring name 0 len) "...") name)) (define (make-pile-menu pile thunk) (let ((chattelry (sawlet-get pile 'merlin.pile:chattelry))) (mapcar (lambda (chattel) (list (abbreviate (aref (x-get-text-property (car chattel) 'WM_NAME) 0)) (lambda () (thunk chattel)) (cons 'check (and (eq chattel (car chattelry)))) (cons 'group (sawlet-symbol pile 'window-menu)))) chattelry))) (define (popup-pile-menu window) (let* ((pile (sawlet-from-frame window))) (when (memq pile piles) (popup-menu `((,(_ "_Capture") ,(lambda () (capture pile))) (,(_ "_Raise") . ,(make-pile-menu pile (lambda (chattel) (raise pile (car chattel))))) (,(_ "_Eject") . ,(make-pile-menu pile (lambda (chattel) (eject pile (car chattel)))))))))) (define-command 'popup-pile-menu popup-pile-menu #:spec "%W") ;; ;; ignore attempts by piled windows to move/resize themselves (define (configure-request-handler pile event) ; (let ; ((id (cdr (assq 'window event))) ; (width (cdr (assq 'width event))) ; (height (cdr (assq 'height event))) ; (chattelry (sawlet-get pile 'merlin.pile:chattelry))) ; (mapc ; (lambda (chattel) ; (when (and (equal id (car chattel))) ; (rplaca (cdr chattel) (cons width height)) ; (sawlet-reconfigure pile))) chattelry)) t) (define (destroy-notify-handler pile event) (let* ((id (cdr (assq 'window event))) (chattelry (sawlet-get pile 'merlin.pile:chattelry))) (sawlet-put pile 'merlin.pile:chattelry (delete-if (lambda (chattel) (eq id (car chattel))) chattelry)) (sawlet-reconfigure pile)) nil) (define (expose-handler pile event) (x-clear-window (sawlet-get pile 'window)) nil) (define (button-press-handler pile event) (popup-pile-menu (sawlet-frame pile)) nil) (define (pre pile) (define-placement-mode pile (lambda (window)))) (define (pile-window-menu pile) (or (make-pile-menu pile (lambda (chattel) (raise pile (car chattel)) (display-window (sawlet-frame pile)))) (list (list "" (lambda () (display-window (sawlet-frame pile))))))) (eval-in ; make the window-menu display pile contents `(progn (require 'merlin.pile) (require 'merlin.sawlet) (define (make-item w) (fluid-set windows-left (delq w (fluid windows-left))) (if (pile-p (sawlet-from-frame w)) (cons (make-label w) (lambda () (pile-window-menu (sawlet-from-frame w)))) (list (make-label w) (lambda () (when (windowp w) (display-window w))) (cons 'check (and (eq (input-focus) w))) '(group . beos-window-menu))))) 'sawfish.wm.ext.beos-window-menu) (defmacro defpile (pile . keys) `(progn (require 'merlin.sawlet) ,(append `(defsawlet ,pile :pre ,pre) keys ; allow override `(:start ,start :stop ,stop :post-configure ,replace :wm-size-hints ,(lambda () (cons nil nil)) :dimensions ,dimensions :expose-handler ,expose-handler :button-press-handler ,button-press-handler :destroy-notify-handler ,destroy-notify-handler :configure-request-handler ,configure-request-handler :font ,nil :foreground ,nil :background ,(get-color-rgb 0 0 0) :matcher-actions '((place-mode . ,place-window-mode) (frame-type . normal) (never-focus . #f) (sticky . #f) (sticky-viewport . #f) (window-list-skip . #f) (skip-tasklist . #f)) ))))) merlin-1.3.1/placement.jl0000644000175000017500000000656710067061360016752 0ustar marillatmarillat00000000000000;; merlin/placement.jl -- opaque placement and with resize ;; version 0.4.1 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; this is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; this is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv placement.jl ~/.sawfish/lisp/merlin ;; Then add to your .sawfishrc: ;; (require 'merlin.placement) ;; Then restart sawfish and go to Customize->Placement and select ;; (opaque-)interactively(-with-resize) ;; - Henceforth, windows will be placed opaquely if you so choose. ;; - If you select -with-resize then if you place ;; a window with a mouse button and hold it down, ;; you can drag-resize the window (twm-style). ; BUGS: Sometimes windows get messed up by this. I don't know ; when or why so I don't know what to do about it. ; TODO: do I fire the after-place / before-resize hooks on go-resize ; TODO: do i set the cursor - resize-cursor-shape on go-resize (define-structure merlin.placement (export) (open rep rep.system sawfish.wm.placement sawfish.wm.commands sawfish.wm.commands.move-resize sawfish.wm.events sawfish.wm.misc sawfish.wm.windows) (define (merlin-placement-go-resize) ;; hackalicious (setq move-resize-function 'resize) (setq move-resize-old-x move-resize-x) (setq move-resize-old-y move-resize-y)) (define (merlin-place-window w opaque resize) (accept-x-input) (when (window-id w) (let ((move-outline-mode (if opaque 'opaque 'box)) (resize-edge-mode 'border-grab) (ptr (query-pointer)) (siz (window-dimensions w)) (dims (window-frame-dimensions w))) (move-window-to w (- (car ptr) (quotient (car dims) 2)) (- (cdr ptr) (quotient (cdr dims) 2))) (when opaque (hide-window w) (show-window w)) ;; hackalicious (when resize (bind-keys move-resize-map "Any-Click1" 'merlin-placement-go-resize)) (move-window-interactively w) (when resize (unbind-keys move-resize-map "Any-Click1"))))) (define (place-window-opaque-interactively w) (merlin-place-window w t nil)) (define (place-window-opaque-interactively-with-resize w) (merlin-place-window w t t)) (define (place-window-interactively-with-resize w) (merlin-place-window w nil t)) (define-placement-mode 'opaque-interactively place-window-opaque-interactively #:for-normal t) (define-placement-mode 'opaque-interactively-with-resize place-window-opaque-interactively-with-resize #:for-normal t) (define-placement-mode 'interactively-with-resize place-window-interactively-with-resize #:for-normal t) (define-command 'merlin-placement-go-resize merlin-placement-go-resize)) merlin-1.3.1/sawlet.jl0000644000175000017500000003617210067070320016270 0ustar marillatmarillat00000000000000;; merlin/sawlet.jl -- a bad saw(fish app)let framework ;; version -0.4.3 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;;;;; ;; HERE BE DRAGONS ;; ;;;;;;;;;;;;;;;;;;;;; ;; This software requires a patch to be applied to the Sawfish source to ;; add some additional XLib bindings. ;; Please see x.c.patch. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Please see one of the actual sawlets ;; Go to Customize->Matched Windows->Sawlet->Edit... ;; - Here you can specify settings for all sawlets ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; sawlet's can be per-workspace but not be per-viewport. ;; sawlet defcustom/defgroup :group has to be a list, not a symbol. ;; TODO: auto-remember sawlet position ;; TODO: allow sawlet configuration of wm-class ;;;; (define-structure merlin.sawlet (export defsawlet sawlet-start sawlet-reconfigure sawlet-stop sawlet-active sawlet-get sawlet-put sawlet-config sawlet-frame sawlet-from-frame sawlet-symbol) (open rep rep.system sawfish.wm.colors sawfish.wm.custom sawfish.wm.events sawfish.wm.fonts sawfish.wm.misc sawfish.wm.windows sawfish.wm.ext.match-window sawfish.wm.util.x merlin.sawlet-placement merlin.util merlin.x-util) (defgroup sawlets "Sawlets") (defcustom merlin.sawlet:default-placement:origin 'north-east "Default placement origin." :type (choice north-west north-east south-east south-west) :group sawlets :after-set (lambda () (define-default-sawlet-placement-mode))) (defcustom merlin.sawlet:default-placement:direction 'west "Default placement direction." :type (choice north east south west) :group sawlets :after-set (lambda () (define-default-sawlet-placement-mode))) (defcustom merlin.sawlet:default-placement:avoid t "Default placement avoids panels, etc." :type boolean :group sawlets :after-set (lambda () (define-default-sawlet-placement-mode))) (define (syms symbol . rest) (intern (apply concat (list* (format nil "%s" symbol) (mapcar (lambda (sym) (format nil "-%s" sym)) rest))))) (define (sawlet-symbol sawlet symbol) (intern (format nil "merlin.sawlet:%s:%s" sawlet symbol))) (define (sawlet-get sawlet key) (get sawlet key)) (define (sawlet-put sawlet key value #!optional destructor) (let ((old (get sawlet key))) (and old destructor (destructor old)) (put sawlet key value))) (define (sawlet-config sawlet key) (symbol-value (sawlet-symbol sawlet key))) (define (sawlet-call sawlet command . args) (let ((cmd (sawlet-get sawlet command))) (and cmd (apply cmd args)))) (define (sawlet-frame sawlet) (get-window-by-id (x-window-id (sawlet-get sawlet 'root)))) (define (sawlet-from-frame window) (window-get window 'merlin.sawlet:sawlet)) (define (sawlet-root-client-message event) (let* ((window (cdr (assq 'window event))) (sawlet (x-window-get window 'sawlet)) (message-type (cdr (assq 'message-type event))) (fmt (cdr (assq 'format event))) (data (cdr (assq 'data event)))) (when (and (eq message-type 'WM_PROTOCOLS) (eq fmt 32) (eq (aref data 0) (x-atom 'WM_DELETE_WINDOW))) (sawlet-stop sawlet)))) (define (sawlet-root-event-handler type window event) (cond ((eq type 'client-message) (sawlet-root-client-message event))) nil) (define (sawlet-window-event-handler type window event) (let* ((sawlet (x-window-get window 'sawlet)) (handler (sawlet-get sawlet (syms type 'handler)))) (when handler (handler sawlet event)))) (define event-mask-map `((expose . exposure) (button-press . button-press) (enter-notify . enter-window) (destroy-notify . substructure-notify) (configure-notify . substructure-notify) (configure-request . substructure-redirect))) (define (sawlet-create sawlet) (let* ((dims (or (sawlet-call sawlet 'dimensions sawlet) (cons 64 64))) (bw (car (sawlet-config sawlet 'border))) (root-dims (cons+ dims (* 2 bw))) (root (x-create-window (cons 0 0) root-dims 0 `((override-redirect . ,nil) (event-mask . ())) sawlet-root-event-handler)) (window (x-create-window (cons 0 0) dims bw `((parent . ,root) (background . ,(sawlet-config sawlet 'background)) (border-color . ,(cdr (sawlet-config sawlet 'border))) (override-redirect . ,t) (event-mask . ,(mapcar (lambda (map) (and (sawlet-get sawlet (syms (car map) 'handler)) (cdr map))) event-mask-map))) sawlet-window-event-handler)) (gc (x-create-gc root (and (boundp (sawlet-symbol sawlet 'foreground)) `(foreground . ,(sawlet-config sawlet 'foreground)))))) (x-window-put window 'sawlet sawlet) (x-window-put root 'sawlet sawlet) (sawlet-put sawlet 'gc gc x-free-gc) (sawlet-put sawlet 'window window x-destroy-window) (sawlet-put sawlet 'root root x-destroy-window) (x-set-wm-class root (format nil "%s" sawlet) "Sawlet") (x-set-wm-name root (or (sawlet-get sawlet 'name) (format nil "%s" sawlet))) (x-set-wm-icon-name root (or (sawlet-get sawlet 'icon-name) (format nil "%s" sawlet))) (x-set-wm-protocols root '(delete-window)) (apply x-set-wm-size-hints root (or (sawlet-call sawlet 'wm-size-hints sawlet) (list dims dims))) (x-x-map-window window) ((x-map-fn) root))) (define (sawlet-destroy sawlet) (sawlet-put sawlet 'gc nil x-free-gc) (sawlet-put sawlet 'window nil x-destroy-window) (sawlet-put sawlet 'root nil x-destroy-window)) (define (sawlet-configure sawlet) (let* ((dims (or (sawlet-call sawlet 'dimensions sawlet) (cons 64 64))) (bw (car (sawlet-config sawlet 'border))) (root-dims (cons+ dims (* 2 bw)))) (apply x-set-wm-size-hints (sawlet-get sawlet 'root) (or (sawlet-call sawlet 'wm-size-hints sawlet) (list dims dims))) ;; root-dims? ((x-configure-fn) (sawlet-get sawlet 'root) `((width . ,(car root-dims)) (height . ,(cdr root-dims)))) (x-configure-window (sawlet-get sawlet 'window) `((width . ,(car dims)) (height . ,(cdr dims)) (border-width . ,bw))) (x-change-window-attributes (sawlet-get sawlet 'window) `((background . ,(sawlet-config sawlet 'background)) (border-color . ,(cdr (sawlet-config sawlet 'border))))) (when (boundp (sawlet-symbol sawlet 'foreground)) (x-change-gc (sawlet-get sawlet 'gc) `((foreground . ,(sawlet-config sawlet 'foreground))))))) ;; pub (define sawlets nil) (define (before-add-window-eye window) (mapc (lambda (sawlet) (when (eq window (sawlet-frame sawlet)) (window-put window 'merlin.sawlet:sawlet sawlet))) sawlets)) (add-hook 'before-add-window-hook before-add-window-eye) (define (while-resizing-eye window) (let* ((sawlet (sawlet-from-frame window))) (when sawlet (x-configure-window (sawlet-get sawlet 'window) `((width . ,move-resize-width) (height . ,move-resize-height))) (sawlet-call sawlet 'while-resizing sawlet)))) (add-hook 'while-resizing-hook while-resizing-eye) (define (after-resize-eye window) (let* ((sawlet (sawlet-from-frame window))) (when sawlet (sawlet-reconfigure sawlet)))) (add-hook 'after-resize-hook after-resize-eye) ;; needed to catch match-window placement (add-hook 'after-add-window-hook after-resize-eye) (define (sawlet-start sawlet) (unless (memq sawlet sawlets) (setq sawlets (nconc sawlets (list sawlet))) (sawlet-create sawlet) (sawlet-call sawlet 'start sawlet))) (define (sawlet-reconfigure sawlet) (when (memq sawlet sawlets) (sawlet-call sawlet 'pre-configure sawlet) (sawlet-configure sawlet) (sawlet-call sawlet 'post-configure sawlet) (sawlet-call sawlet 'expose-handler sawlet `((window . ,(sawlet-get sawlet 'window)))))) ;; hack!! (define (sawlet-stop sawlet) (when (sawlet-get sawlet 'root) (setq sawlets (delq sawlet sawlets)) (sawlet-call sawlet 'stop sawlet) (sawlet-destroy sawlet))) (define (sawlet-active sawlet) (and (sawlet-get sawlet 'root) t)) (define (define-default-sawlet-placement-mode) (define-sawlet-placement-mode 'sawlet merlin.sawlet:default-placement:origin merlin.sawlet:default-placement:direction merlin.sawlet:default-placement:avoid)) (define-default-sawlet-placement-mode) (defmacro defsawlet (sawlet #!rest keys) (let* ((Sawlet (capitalize-string (format nil "%s" sawlet))) (class (format nil "^Sawlet/%s$" sawlet)) (fmt (lambda (sym) (intern (format nil ":%s" sym)))) (get (lambda (sym) (cadr (memq (fmt sym) keys)))) (no (lambda (sym) (and (memq (fmt sym) keys) (not (get sym))))) (start-stop (lambda () (if (sawlet-config sawlet 'enabled) (sawlet-start sawlet) (sawlet-stop sawlet)))) (configure (lambda () (sawlet-reconfigure sawlet)))) (append `(progn (require 'sawfish.wm.colors) (require 'sawfish.wm.custom) (require 'sawfish.wm.fonts) (require 'sawfish.wm.ext.match-window) (sawlet-put ',sawlet 'sawlet t (lambda () (error "Sawlet %s already defined." ',sawlet))) (defgroup ,sawlet ,Sawlet :group sawlets)) (mapcar ;; todo: ALL handlers! (lambda (symbol) `(sawlet-put ',sawlet ',symbol ,(get symbol))) '(pre post init start stop pre-configure post-configure name icon-name dimensions wm-size-hints while-resizing matcher-actions expose-handler button-press-handler enter-notify-handler destroy-notify-handler configure-notify-handler configure-request-handler)) (delq nil (mapcar (lambda (def) (let* ((name (nth 0 def)) (symbol (sawlet-symbol sawlet name)) (value (or (get name) (nth 1 def))) ;(doc (format nil "%s %s." Sawlet (nth 2 def))) (doc (nth 2 def)) (type (nth 3 def)) (after-set (nth 4 def))) (and (not (no name)) `(defcustom ,symbol ,value ,doc :type ,type :group (sawlets ,sawlet) :after-set ,after-set)))) `((enabled t "Enabled." boolean ,start-stop) (font default-font "Font." font ,configure) (foreground (get-color-rgb 0 0 0) "Foreground color." color ,configure) (background (get-color-rgb 65535 65535 65535) "Background color." color ,configure) (border (cons 0 (get-color-rgb 0 0 0)) "Internal border." (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) ,configure)))) (nreverse (let loop ((rest keys) (defs nil)) (if (not rest) defs (when (eq ':defgroup (car rest)) (let* ((def (append (cadr rest) ())) ; copy list (group (memq ':group def))) (if group ;; TODO: group can be a symbol (rplaca (cdr group) (list* 'sawlets sawlet (cadr group))) (nconc def `(:group (sawlets ,sawlet)))) (setq defs (cons (cons 'defgroup def) defs)))) (loop (cddr rest) defs)))) (nreverse (let loop ((rest keys) (defs nil)) (if (not rest) defs (when (eq ':defcustom (car rest)) (let* ((def (append (cadr rest) ())) ; copy list (name (nth 0 def)) (symbol (sawlet-symbol sawlet name)) (value (or (get name) (nth 1 def))) (group (memq ':group def)) (after-set (memq ':after-set def)) (depends (memq ':depends def))) (rplaca def symbol) (rplaca (cdr def) value) (if group ;; TODO: group can be a symbol (rplaca (cdr group) (list* 'sawlets sawlet (cadr group))) (nconc def `(:group (sawlets ,sawlet)))) (when depends (rplaca (cdr depends) (sawlet-symbol sawlet (cadr depends)))) (when after-set (rplaca (cdr after-set) `(lambda () (,(cadr after-set) ',sawlet)))) (setq defs (cons (cons 'defcustom def) defs)))) (loop (cddr rest) defs)))) `((unless (catch 'out (mapc (lambda (entry) (when (member (cons 'WM_CLASS ,class) (car entry)) (throw 'out t))) match-window-profile) nil) (setq match-window-profile (nconc match-window-profile (list (list (list (cons 'WM_CLASS ,class)))))) (apply add-window-matcher 'WM_CLASS ,class (sawlet-get ',sawlet 'matcher-actions))) (when (sawlet-get ',sawlet 'pre) ((sawlet-get ',sawlet 'pre) ',sawlet)) (when (sawlet-get ',sawlet 'init) ((sawlet-get ',sawlet 'init) ',sawlet)) (when (and (not batch-mode) (sawlet-config ',sawlet 'enabled)) (sawlet-start ',sawlet)) (when (sawlet-get ',sawlet 'post) ((sawlet-get ',sawlet 'post) ',sawlet)) (defvar ,sawlet ',sawlet))))) ;; define?? (unless (catch 'out (mapc (lambda (entry) (when (member (cons 'WM_CLASS "^Sawlet/") (car entry)) (throw 'out t))) match-window-profile) nil) (setq match-window-profile ;; put at end... (nconc match-window-profile (list (list (list (cons 'WM_CLASS "^Sawlet/")))))) (add-window-matcher 'WM_CLASS "^Sawlet/" '(place-mode . sawlet) '(never-focus . t) '(sticky . t) '(sticky-viewport . t) '(window-list-skip . t) '(task-list-skip . t) '(skip-tasklist . t) '(frame-type . border-only)))) merlin-1.3.1/sawlet-placement.jl0000644000175000017500000002263710067106017020242 0ustar marillatmarillat00000000000000;; merlin/sawlet-placement.jl -- a placement mode for sawlets etc. ;; version 0.3.1 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv sawlet-placement.jl ~/.sawfish/lisp/merlin ;; You also need merlin/util.jl. ;; You're probably best off unpacking the entire merlin.tgz archive. ;; Then add to your .sawfishrc: ;; (require 'merlin.sawlet-placement) ;; (define-sawlet-placement-mode 'south-east-going-north ;; 'south-east 'north) ;; This defines a placement mode 'south-east-going-north that starts ;; in the south-east of your screen and moves northwards. You can ;; choose whatever name you want, and define as many sawlet placement ;; modes as you want. Your options include 'north-west, 'north-east, ;; 'south-east and 'south-west, going 'north, 'south, 'east or 'west. ;; An optional final parameter, avoid, specifies whether to avoid ;; avoided windows (e.g., the gnome panel). So, to avoid the gnome ;; panel: ;; (define-sawlet-placement-mode 'south-east-going-north ;; 'south-east 'north t) ;; Next, try adding: ;; (define-sawlet-subplacement-mode 'south-east-going-west ;; 'south-east-going-north nil 'west) ;; This defines a placement mode 'south-east-going-west which is ;; treated as a composite child (with the specified placement weight) ;; of 'south-east-going-north. The two placement modes try and act ;; harmoniously, allowing you to have automatic window placement ;; as such: ;; [SEgN] ;; [SEgN] ;; [SEgW] [SEgW] [SEgW] ;; More complex arrangements are also possible. ;; Then restart sawfish. ;; Go to Customize->Matched Windows ;; - Here you must add matchers on any windows that you want ;; (e.g., XBiff, XClock) for your new Place mode. Also, you ;; can use the Placement weight setting to assert an order ;; on the sawlets (least first); otherwise they are placed ;; in the order that they happen to be picked up by sawfish. ;; Now, launch the apps. Or, if they launch at startup, restart ;; your X session. ;;;;;;;;;;;;;;;;;; ;; HERE BE BUGS ;; ;;;;;;;;;;;;;;;;;; ;; I don't wrap around when I come to the edge of the screen... ;; See merlin.pager for a probable problem with merging/removing ;; workspaces. ;; Subplacements should try to pack windows better rather than ;; assuming pessimistic overlap with consequent full avoidance. ;;;; (define-structure merlin.sawlet-placement (export get-size define-sawlet-placement-mode define-sawlet-subplacement-mode) (open rep rep.system sawfish.wm.events sawfish.wm.misc sawfish.wm.placement sawfish.wm.viewport sawfish.wm.windows sawfish.wm.util.workarea merlin.util) (define modes nil) (define (origin mode) (let* ((origin (get mode 'merlin.sawlet-placement:origin))) (cons (if (memq origin '(north-east south-east)) 1 0) (if (memq origin '(south-west south-east)) 1 0)))) (define (direction mode) (let* ((direction (get mode 'merlin.sawlet-placement:direction))) (cond ((eq direction 'east) (cons 1 0)) ((eq direction 'west) (cons -1 0)) ((eq direction 'north) (cons 0 -1)) (t (cons 0 1))))) (define (gravity mode) (let* ((direction (get mode 'merlin.sawlet-placement:direction)) (org (origin mode))) (cond ;; yech ((eq direction 'east) (cons 0 (- (cdr org)))) ((eq direction 'west) (cons -1 (- (cdr org)))) ((eq direction 'north) (cons (- (car org)) -1)) (t (cons (- (car org)) 0))))) (define (placement-p placement) (and (symbolp placement) (get placement 'merlin.sawlet-placement:direction))) (define (subplacement-p placement) (and (symbolp placement) (get placement 'merlin.sawlet-placement:parent))) (define (get-placement x) (if (subplacement-p x) (get x 'merlin.sawlet-placement:parent) (window-get x 'place-mode))) (define (get-weight x) (or (if (subplacement-p x) (get x 'merlin.sawlet-placement:weight) (window-get x 'placement-weight)) -1)) (define (visible-p window) (and (window-mapped-p window) (window-visible-p window) (or (window-get window 'sticky-viewport) (not (window-outside-viewport-p window))))) ;; TODO: make multiple dependent placement modes be smart about ;; just not overlapping windows; not to always be pessimistic ;; TODO: honour origin of subplacements... (define (get-size x) (if (not (placement-p x)) (if (visible-p x) (window-frame-dimensions x) (cons 0 0)) (let* ((direction (get x 'merlin.sawlet-placement:direction)) (sawlets (get x 'merlin.sawlet-placement:list)) (sizes (mapcar get-size sawlets)) (op (if (memq direction '(east west)) (cons + max) (cons max +)))) (apply cons-op op (cons 0 0) sizes)))) (define (mode-place mode pos) (let* ((sawlets (get mode 'merlin.sawlet-placement:list)) (org (origin mode)) (dir (direction mode)) (grv (gravity mode))) (mapc (lambda (sawlet) (if (placement-p sawlet) (mode-place sawlet pos) (when (visible-p sawlet) (let* ((dim (window-frame-dimensions sawlet)) (tmp (cons+ pos (cons* grv dim)))) (move-window-to sawlet (car tmp) (cdr tmp))))) (setq pos (cons+ pos (cons* dir (get-size sawlet))))) sawlets))) (define (place x) (let* ((mode (let loop ((mode (get-placement x))) (if (not (subplacement-p mode)) mode (loop (get-placement mode))))) (rect (if (get mode 'merlin.sawlet-placement:avoid) (calculate-workarea) (list 0 0 (screen-width) (screen-height)))) (xy (cons (nth 0 rect) (nth 1 rect))) (wh (cons- (cons (nth 2 rect) (nth 3 rect)) xy)) (pos (cons+ xy (cons* (origin mode) wh)))) (mode-place mode pos))) (define (add-window-eye window) (let* ((mode (get-placement window)) (weight (get-weight window)) (sawlets (cons nil (and mode (get mode 'merlin.sawlet-placement:list))))) (when (memq mode modes) (let loop ((rest sawlets)) (if (or (null (cdr rest)) (> (get-weight (cadr rest)) weight)) (rplacd rest (cons window (cdr rest))) (loop (cdr rest)))) (put mode 'merlin.sawlet-placement:list (cdr sawlets))))) (define (destroy-notify-eye window) (let* ((mode (get-placement window)) (sawlets (and mode (get mode 'merlin.sawlet-placement:list))) (next (cadr (memq window sawlets)))) (when sawlets (put mode 'merlin.sawlet-placement:list (delq window sawlets)) (when next (place next))))) ;; TODO: must replace ALWAYS if it is subplaced (define (window-resized-eye window) (let* ((mode (get-placement window))) (when (placement-p mode) (place window)))) (define (after-initialization-eye) (mapc (lambda (mode) (let* ((sawlets (get mode 'merlin.sawlet-placement:list)) (first (car sawlets))) (when (and first (not (subplacement-p mode))) (place first)))) modes)) (add-hook 'add-window-hook add-window-eye) (add-hook 'destroy-notify-hook destroy-notify-eye) (mapc (lambda (hook) (add-hook hook window-resized-eye)) '(window-resized-hook after-framing-hook map-notify-hook unmap-notify-hook iconify-window-hook uniconify-window-hook window-maximized-hook window-unmaximized-hook)) (mapc (lambda (hook) (add-hook hook after-initialization-eye)) '(after-initialization-hook enter-workspace-hook viewport-moved-hook)) (define (define-sawlet-subplacement-mode symbol parent weight direction #!optional avoid) (when (memq symbol modes) ;; TODO: Allow redefinition (error "placement mode %s is already defined." symbol)) (unless (placement-p parent) (error "parent placement mode %s must be defined." parent)) (define-sawlet-placement-mode symbol (get parent 'merlin.sawlet-placement:origin) direction avoid) (put symbol 'merlin.sawlet-placement:parent parent) (put symbol 'merlin.sawlet-placement:weight weight) (add-window-eye symbol)) (define (define-sawlet-placement-mode symbol origin direction #!optional avoid) (put symbol 'merlin.sawlet-placement:origin origin) (put symbol 'merlin.sawlet-placement:direction direction) (put symbol 'merlin.sawlet-placement:avoid avoid) (if (memq symbol modes) (mapc place (get symbol 'merlin.sawlet-placement:list)) (setq modes (nconc modes (list symbol)))) (define-placement-mode symbol place))) merlin-1.3.1/uglicon.jl0000644000175000017500000001445507472223527016450 0ustar marillatmarillat00000000000000;; merlin/uglicon.jl -- window icons ;; version 0.2 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; this is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; this is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv uglicon.jl ~/.sawfish/lisp/merlin ;; You also need merlin/util.jl and probably want merlin/ugliness.jl. (define-structure merlin.uglicon (export get-window-icon) (open rep rep.io.files sawfish.wm.colors sawfish.wm.custom sawfish.wm.images sawfish.wm.misc sawfish.wm.ext.match-window sawfish.wm.windows.subrs merlin.util) (defgroup uglicon "Window icons" :group appearance) (defcustom uglicon-ignore-hints t "Ignore icons from window hints." :type boolean :group (appearance uglicon) ; :depends cycle-show-window-icons :after-set (lambda () (uglicon-reset))) (defcustom uglicon-search-filesystem t "Search the file system for window icons." :type boolean :group (appearance uglicon) ; :depends cycle-show-window-icons :after-set (lambda () (uglicon-reset))) (defcustom uglicon-path "/usr/share/pixmaps:/usr/share/icons" "Path to search for icons." :tooltip "Colon separated paths." :type string :user-level expert :group (appearance uglicon) :depends uglicon-search-filesystem :after-set (lambda () (uglicon-reset))) (defcustom uglicon-prefixes ",gnome-" "Icon prefixes to look for." :tooltip "Comma separated prefixes." :type string :user-level expert :group (appearance uglicon) :depends uglicon-search-filesystem :after-set (lambda () (uglicon-reset))) (defcustom uglicon-suffixes "png,xpm" "Icon suffixes to look for." :tooltip "Comma separated suffixes." :type string :user-level expert :group (appearance uglicon) :depends uglicon-search-filesystem :after-set (lambda () (uglicon-reset))) (defcustom uglicon-width 48 "Maximum width of window icons." :type number :range (1 . 128) :user-level expert :group (appearance uglicon)) (defcustom uglicon-height 48 "Maximum height of window icons." :type number :range (1 . 128) :user-level expert :group (appearance uglicon)) (define-match-window-property 'window-icon 'appearance 'file) (define uglicon-cache) ;; TODO: periodically purge the cache? (define uglicon-split-path) (define uglicon-split-suffixes) (define uglicon-split-prefixes) (define (uglicon-reset) (setq uglicon-cache '()) (setq uglicon-split-path (split uglicon-path ":")) (setq uglicon-split-suffixes (split uglicon-suffixes ",")) (setq uglicon-split-prefixes (split uglicon-prefixes ","))) (uglicon-reset) ;; returns a cons cell of the key and entry (define (cache-get key creator) (let ((cached (cdr (assoc key uglicon-cache)))) (unless cached (when (setq cached (creator)) (setq uglicon-cache (cons (cons key cached) uglicon-cache)))) (and cached (cons key cached)))) (define (load-icon file) (cache-get file (lambda () (when (file-exists-p file) (make-image file))))) (define (locate-icon name) (cache-get name (lambda () (catch 'out (mapc (lambda (dir) (mapc (lambda (prefix) (mapc (lambda (suffix) (let ((where (expand-file-name (concat prefix name "." suffix) dir))) (when (file-exists-p where) (throw 'out (make-image where))))) uglicon-split-suffixes)) uglicon-split-prefixes)) uglicon-split-path) nil)))) (define (window-icon window) ;; TODO: this should not really be cached; should provide a purge mechanism... (cache-get (format nil "win<0x%x>" (window-id window)) (lambda () (window-icon-image window)))) (define (scale-icon icon max) (let ((key (format nil "%s-scale:%dx%d" (car icon) (car max) (cdr max)))) (cache-get key (lambda () (let ((dims (image-dimensions (cdr icon)))) (if (and (<= (car dims) (car max)) (<= (cdr dims) (cdr max))) (cdr icon) (scale-image (cdr icon) (min (car max) (quotient (* (car dims) (cdr max)) (cdr dims))) (min (cdr max) (quotient (* (car max) (cdr dims)) (car dims)))))))))) (define (fade-icon icon fade) (let* ((rgb (color-rgb-8 fade)) (key (format nil "%s-fade:%02x/%02x/%02x" (car icon) (nth 0 rgb) (nth 1 rgb) (nth 2 rgb)))) (cache-get key (lambda () (let ((icon (copy-image (cdr icon)))) (image-map (lambda (pixel) (list (quotient (+ (nth 0 pixel) (nth 0 rgb)) 2) (quotient (+ (nth 1 pixel) (nth 1 rgb)) 2) (quotient (+ (nth 2 pixel) (nth 2 rgb)) 2) (nth 3 pixel))) icon) icon))))) (define (unknown-icon) (or (and uglicon-search-filesystem (locate-icon "unknown")) (cache-get "unknown" (lambda () ;; TODO: Make it pretty (bevel-image (make-sized-image uglicon-width uglicon-height (get-color "gray")) 2 t 50))))) (define (window-icon-name window) (let ((class (get-x-text-property window 'WM_CLASS))) (and class (>= (length class) 2) (translate-string (aref class 1) downcase-table)))) (define (get-window-icon window #!key (max-size (cons uglicon-width uglicon-height)) (fade-to nil)) (let ((icon (or (and (window-get window 'window-icon) (load-icon (window-get window 'window-icon))) (and (not uglicon-ignore-hints) (window-icon window)) (and uglicon-search-filesystem (window-icon-name window) (locate-icon (window-icon-name window))) (unknown-icon)))) (setq icon (scale-icon icon max-size)) (when fade-to (setq icon (fade-icon icon fade-to))) (cdr icon)))) merlin-1.3.1/ugliness.jl0000644000175000017500000003612407472225371016635 0ustar marillatmarillat00000000000000;; merlin/ugliness.jl -- options for ugliness ;; version 0.9.4 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; this is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; this is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/merlin and then put this file there: ;; mkdir -p ~/.sawfish/lisp/merlin ;; mv ugliness.jl ~/.sawfish/lisp/merlin ;; You also need merlin/util.jl, merlin/uglicon.jl and merlin/message.jl. ;; Then add to your .sawfishrc: ;; (require 'merlin.ugliness) ;; Then restart sawfish and go to Customize->Focus or Customize->Move/Reisze. ;; - You should have lots of options for configuring ugliness. ;; Also go to Customize->Appearance->Window icons ;; - Here you can configure how window icons are determined ;; Also go to Customize->Matched windows->Appearance ;; - Here you can specify per-window icons ;; TODO: honour position of cycle window when icons are showing... ;; Thanks to Christian Marillat, Barthel(?) and Guillermo S. Romero for ;; bug reports, patches and suggestions. (define-structure merlin.ugliness (export ugly-cycle-show-window-list ugly-cycle-hide-window-list) (open rep rep.io.files sawfish.wm.colors sawfish.wm.custom sawfish.wm.fonts sawfish.wm.images sawfish.wm.misc sawfish.wm.commands.move-resize sawfish.wm.commands.x-cycle sawfish.wm.util.x sawfish.wm.windows.subrs merlin.message merlin.util merlin.uglicon) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; x-cycle basic appearance settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup focus-ugliness "Ugliness" :group focus) (defcustom ugly-cycle-show-windows t "Display full list of window names in cycle ring." :group (focus focus-ugliness) :type boolean) (defcustom ugly-cycle-show-icons t "Display icons above window names when cycling." :group (focus focus-ugliness) :type boolean) (defcustom ugly-cycle-relative 'screen "Display cycle list relative to: \\w" :type symbol :options (screen window) :group (focus focus-ugliness)) (defcustom ugly-cycle-percent (cons 50 50) "Offset of cycle list as percentage of parent dimensions." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (focus focus-ugliness)) (defcustom ugly-cycle-color (cons (get-color "black") (get-color "white")) "Window cycle list color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (focus focus-ugliness)) (defcustom ugly-cycle-font default-font "Font for cycle list." :type font :group (focus focus-ugliness)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; x-cycle advanced ugliness settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup focus-extra-ugliness "Extra Ugliness" :group focus) (defcustom ugly-cycle-justify 'center "Justification of window names." :type symbol :options (left center right) :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-current-foreground (get-color "red") "Foreground color for currently-selected window." :type color :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-current-font default-font "Font for currently-selected window." :type font :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-iconified-foreground (get-color "blue") "Foreground color for iconified windows." :type color :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-iconified-font default-font "Font for iconified windows." :type font :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-caption t "Display current window name in caption." :group (focus focus-extra-ugliness) :type boolean) (defcustom ugly-cycle-caption-foreground (get-color "white") "Foreground color for caption." :type color :group (focus focus-extra-ugliness) :depends ugly-cycle-caption) (defcustom ugly-cycle-caption-font default-font "Font for caption." :type font :group (focus focus-extra-ugliness) :depends ugly-cycle-caption) (defcustom ugly-cycle-border (cons 2 (get-color "black")) "Border around window list." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-padding (cons 4 4) "Padding around window list." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (focus focus-extra-ugliness)) (defcustom ugly-cycle-gravity 'center "Gravity of window list." :type symbol :options (north-west north north-east west center east south-west south south-east) :group (focus focus-extra-ugliness)) ;;;;;;;;;;;;;;;;;;;;;;;; ;; my ugly display stuff ;;;;;;;;;;;;;;;;;;;;;;;; (define (ugly-cycle-display-position win) (if (eq ugly-cycle-relative 'window) (cons+ (window-position win) (cons-percent (window-frame-dimensions win) ugly-cycle-percent)) (cons-percent (screen-dimensions) ugly-cycle-percent))) (define (justify child parent) (cond ((eq ugly-cycle-justify 'left) 0) ((eq ugly-cycle-justify 'right) (- parent child)) (t (quotient (- parent child) 2)))) (let (ugly-w ugly-g width height rectangle icons labels) (define (ugly-cycle-show win win-list) ;; bleargh!!! (setq width 0 height 0 rectangle nil icons nil labels nil) (if ugly-cycle-show-icons (let* ;; just hideous; tidy this all up?? ((fonts (list* ugly-cycle-current-font ugly-cycle-iconified-font ugly-cycle-font)) (th (apply max 0 (mapcar (lambda (f) (font-height f)) fonts))) (mi (min (length win-list) (quotient (- (screen-width) (car ugly-cycle-padding) (* 2 (car ugly-cycle-border))) (+ uglicon-width (car ugly-cycle-padding))))) (iw (+ (* mi uglicon-width) (* (1- mi) (car ugly-cycle-padding))))) (setq width (apply max iw (and ugly-cycle-caption (mapcar (lambda (w) (text-width (window-name w) ugly-cycle-caption-font)) win-list))) height (+ height (* (+ uglicon-height th) (ceil (length win-list) mi))) labels (mapcar (lambda (w) (let* ((iconified (window-get w 'iconified)) (font (if (eq w win) ugly-cycle-current-font (if iconified ugly-cycle-iconified-font ugly-cycle-font))) (color (if (eq w win) ugly-cycle-current-foreground (if iconified ugly-cycle-iconified-foreground (car ugly-cycle-color)))) (text (trim (window-name w) font uglicon-width)) (icon (get-window-icon w #:fade-to (and iconified (cdr ugly-cycle-color)))) (index (index-of w win-list)) (pos (cons+ (cons* (cons%/ index mi) (cons (+ uglicon-width (car ugly-cycle-padding)) (+ uglicon-height th))) (cons (justify iw width) 0) ugly-cycle-padding)) (ipos (cons+ pos (cons-quotient (cons- (cons uglicon-width uglicon-height) (image-dimensions icon)) 2))) (tpos (cons+ pos (cons (justify (text-width text font) uglicon-width) (+ uglicon-height (- th (font-descent font))))))) (when (eq win w) (setq rectangle (list color (cons- pos 1) (cons+ (cons uglicon-width (+ uglicon-height th)) 1)))) (setq icons (list* (list icon ipos) icons)) (list color tpos text font))) win-list))) (let* ((fonts (list* ugly-cycle-current-font ugly-cycle-iconified-font ugly-cycle-font (and ugly-cycle-caption (list ugly-cycle-caption-font))))) (setq width (apply max 0 (mapcar (lambda (w) (apply max 0 (mapcar (lambda (f) (text-width (window-name w) f)) fonts))) win-list)) ; + 2*padding labels (mapcar (lambda (w) (let* ((iconified (window-get w 'iconified)) (font (if (eq w win) ugly-cycle-current-font (if iconified ugly-cycle-iconified-font ugly-cycle-font))) (color (if (eq w win) ugly-cycle-current-foreground (if iconified ugly-cycle-iconified-foreground (car ugly-cycle-color)))) (text (window-name w)) (pos (cons+ (cons (justify (text-width text font) width) (+ height (font-ascent font))) ugly-cycle-padding))) (setq height (+ height (font-height font))) ; font-height? (list color pos text font))) win-list)))) (when ugly-cycle-caption (let* ((text (window-name win)) (font ugly-cycle-caption-font) (color ugly-cycle-caption-foreground) (pos (cons+ (cons (justify (text-width text font) width) (+ height (cdr ugly-cycle-padding) (font-ascent font))) ugly-cycle-padding))) (setq height (+ height (cdr ugly-cycle-padding) (font-height font))) ; font-height? (setq labels (nconc labels (list (list color pos text font)))))) (setq width (+ width (* 2 (car ugly-cycle-padding))) height (+ height (* 2 (cdr ugly-cycle-padding)))) (let* ((dim (cons+ (cons width height) (* 2 (car ugly-cycle-border)))) (pos (cons-max (cons-min (gravitate (ugly-cycle-display-position win) dim ugly-cycle-gravity) (cons- (screen-dimensions) dim)) 0)) (repaint (lambda () (x-clear-window ugly-w) (when rectangle (x-change-gc ugly-g `((foreground . ,(nth 0 rectangle)))) (x-draw-rectangle ugly-w ugly-g (nth 1 rectangle) (nth 2 rectangle))) (mapc (lambda (icon) (x-draw-image (nth 0 icon) ugly-w (nth 1 icon))) icons) (mapc (lambda (label) (x-change-gc ugly-g `((foreground . ,(nth 0 label)))) (x-draw-string ugly-w ugly-g (nth 1 label) (nth 2 label) (nth 3 label))) labels) nil))) (if ugly-w (x-configure-window ugly-w `((x . ,(car pos)) (y . ,(cdr pos)) (width . ,width) (height . ,height) (stack-mode . top-if))) (setq ugly-w (x-create-window pos (cons width height) (car ugly-cycle-border) `((background . ,(cdr ugly-cycle-color)) (border-color . ,(cdr ugly-cycle-border)) (override-redirect . ,t) (save-under . ,nil) (event-mask . ,'(exposure))) repaint) ugly-g (x-create-gc ugly-w `((background . ,(cdr ugly-cycle-color))))) (x-map-window ugly-w t)) (repaint))) (define (ugly-cycle-hide) (when ugly-w (x-destroy-window ugly-w) (setq ugly-w nil)) (when ugly-g (x-destroy-gc ugly-g) (setq ugly-g nil)))) ;; function proxy (define (ugly-cycle-show-window-list win win-list) (ugly-cycle-show win (if ugly-cycle-show-windows win-list (list win)))) (define (ugly-cycle-hide-window-list) (ugly-cycle-hide)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; x-cycle ugly display stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-in `(progn (require 'merlin.ugliness) ;; an awful thing, copied from x-cycle.jl (define (ugly-cycle-windows) (let ((win (window-order (if cycle-all-workspaces nil current-workspace) cycle-include-iconified cycle-all-viewports))) (unless (eq (fluid x-cycle-windows) t) (setq win (delete-if (lambda (w) (not (memq w (fluid x-cycle-windows)))) win))) (setq win (delete-if-not window-in-cycle-p win)))) (define (cycle-display-message) (ugly-cycle-show-window-list (fluid x-cycle-current) (ugly-cycle-windows))) (define (remove-message) (ugly-cycle-hide-window-list))) 'sawfish.wm.commands.x-cycle) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; move-resize basic ugliness settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup move-ugliness "Ugliness" :group move) (defcustom ugly-move-resize-relative 'window "Display move/resize coordinates relative to: \\w" :type symbol :options (screen window) :group (move move-ugliness)) (defcustom ugly-move-resize-percent (cons 50 50) "Offset of move/resize coordinates as percentage of parent dimensions." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (move move-ugliness)) (defcustom ugly-move-resize-color (cons (get-color "black") (get-color "white")) "Move/resize coordinates color." :type (pair (labelled "Foreground:" color) (labelled "Background:" color)) :group (move move-ugliness)) (defcustom ugly-move-resize-font default-font "Font for move/resize coordinates." :type font :group (move move-ugliness)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; move-resize advanced ugliness settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup move-extra-ugliness "Extra Ugliness" :group move) (defcustom ugly-move-resize-border (cons 2 (get-color "black")) "Border around move-resize coordinates." :type (pair (labelled "Width:" (number 0 100)) (labelled "Color:" color)) :group (move move-extra-ugliness)) (defcustom ugly-move-resize-padding (cons 4 4) "Padding around move-resize coordinates." :type (pair (labelled "Horizontal:" (number 0 100)) (labelled "Vertical:" (number 0 100))) :group (move move-extra-ugliness)) (defcustom ugly-move-resize-gravity 'center "Gravity of move-resize coordinates." :type symbol :options (north-west north north-east west center east south-west south south-east) :group (move move-extra-ugliness)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; move-resize ugly display stuff ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (eval-in `(progn (require 'merlin.message) (require 'merlin.util) (define (ugly-move-resize-display-message msg) (let* ((pos (if (eq ugly-move-resize-relative 'window) (cons+ (cons move-resize-x move-resize-y) (cons-percent (cons+ move-resize-frame (cons move-resize-width move-resize-height)) ugly-move-resize-percent)) (cons-percent (screen-dimensions) ugly-move-resize-percent))) (attrs `((position . ,pos) (font . ,ugly-move-resize-font) (foreground . ,(car ugly-move-resize-color)) (background . ,(cdr ugly-move-resize-color)) (border-color . ,(cdr ugly-move-resize-border)) (border-width . ,(car ugly-move-resize-border)) (padding . ,ugly-move-resize-padding) (gravity . ,ugly-move-resize-gravity) (spacing . ,0)))) (fancy-message (list msg) attrs))) (define (display-message msg) (if msg (ugly-move-resize-display-message msg) (hide-fancy-message)))) 'sawfish.wm.commands.move-resize)) merlin-1.3.1/util.jl0000644000175000017500000001165107472223527015760 0ustar marillatmarillat00000000000000;; merlin/util.jl -- some utilities ;; version 0.7.3 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; this is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; this is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. (define-structure merlin.util (export fontify colorify wm-initialized percent assqd split index-of rplac cons-op op-cons cons+ cons- cons* cons% cons/ cons< cons> cons<= cons>= cons= cons%/ cons/% cons-percent cons-quotient cons-min cons-max cons-and cons-or and-cons or-cons +cons trim gravitate screen-dimensions viewport-offset ceil) (open rep rep.regexp rep.system sawfish.wm.colors sawfish.wm.fonts sawfish.wm.misc sawfish.wm.windows) ;; string/font -> font (define (fontify font) (if (stringp font) (get-font font) font)) ;; string/color -> color (define (colorify color) (if (stringp color) (get-color color) color)) (define after-initialization nil) (add-hook 'after-initialization-hook (lambda () (setq after-initialization t))) ;; is the window manager initialized yet (define (wm-initialized) ;; a hack (or after-initialization (managed-windows))) ;; b % of a (define (percent a b) (quotient (* a b) 100)) ;; assq with default (define (assqd key alist default) (if (assq key alist) (assq key alist) (cons key default))) ;; split of "" is ("") (define (split string separator) (let ((n (length string)) (m (length separator)) (point 0) out end) (while (<= point n) (setq end (if (string-match separator string point) (match-start) (length string))) (setq out (cons (substring string point end) out)) (setq point (+ m end))) (nreverse out))) ;; the index of item in list or -1 (define (index-of item list) (let loop ((rest list) (i 0)) (cond ((null rest) -1) ((eq (car rest) item) i) (t (loop (cdr rest) (1+ i)))))) ;; replace car and cdr (define (rplac a b) (rplaca a (car b)) (rplacd a (cdr b))) ;; op of cons cells and values (define (cons-op op a . rest) (let ((cars (mapcar (lambda (x) (if (consp x) (car x) x)) (list* a rest))) (cdrs (mapcar (lambda (x) (if (consp x) (cdr x) x)) (list* a rest)))) (cons (apply (or (car op) op) cars) (apply (or (cdr op) op) cdrs)))) ;; op of car and cdr (define (op-cons op a) (op (car a) (cdr a))) (defmacro defcons-ops ops (append `(progn) (apply append (mapcar (lambda (op) (let* ((name (or (car op) op)) (func (or (cdr op) op)) (alpha (alpha-char-p (aref (symbol-name name) 0))) (consop (intern (format nil (if alpha "cons-%s" "cons%s") name))) (opcons (intern (format nil (if alpha "%s-cons" "%scons") name)))) `((define (,consop a . rest) (apply cons-op ,func a rest)) (define (,opcons a) (op-cons ,func a))))) ops)))) (define (myand . args) (let loop ((a args)) (if (or (null (cdr a)) (not (car a))) (car a) (loop (cdr a))))) (define (myor . args) (let loop ((a args)) (if (or (null (cdr a)) (car a)) (car a) (loop (cdr a))))) (defcons-ops + - * % / < > <= >= = percent quotient min max (and . myand) (or . myor) (%/ . (cons % quotient)) (/% . (cons quotient %))) ;; trim text in specified font to specified width, appending ... (define (trim text font width) (if (<= (text-width text font) width) text (let loop ((s (concat text "...")) (n (length text))) (if (or (= 0 n) (<= (text-width s font) width)) s (aset s (1- n) 46) (loop (substring s 0 (+ 2 n)) (1- n)))))) ;; return position of object of specified dimensions gravitated around speified point (define (gravitate pos dim gravity) (cons (cond ((memq gravity '(north center south)) (- (car pos) (quotient (car dim) 2))) ((memq gravity '(north-west west south-west)) (- (car pos) (car dim))) (t (car pos))) (cond ((memq gravity '(west center east)) (- (cdr pos) (quotient (cdr dim) 2))) ((memq gravity '(north-west north north-west)) (- (cdr pos) (cdr dim))) (t (cdr pos))))) ;; screen dimensions (define (screen-dimensions) (cons (screen-width) (screen-height))) ;; viewport offset (define (viewport-offset) (cons viewport-x-offset viewport-y-offset)) ;; ceiling quotient (define (ceil a b) (quotient (+ a (1- b)) b))) merlin-1.3.1/x.c.patch0000644000175000017500000013563010067072742016164 0ustar marillatmarillat00000000000000# # version -0.8.7 # # Copyright (C) 2000-2002 merlin # # Built from sawfish 1.2 # # ********************* # ** HERE BE DRAGONS ** # ********************* # # This code contains horrendous hacks. It introduces the high # probability of crashing your Window Manager and Rendering it # Unstable and Destroying your Valuable Work and Property. # # Tnis is unlikely to work with earlier or later versions of # Sawfish. # # Sawfish was not written with code of this nature on mind. # # More to the point, Sawfish was written with the express # intention of this NOT EVER being done. As a result, this # Software introduces the EXTREME PROBABILITY of FAILURE that # DOES NOT EXIST in Sawfish itself. # # ****************** # ** INSTALLATION ** # ****************** # # I assume that you have a recent copy of the Sawfish # source unpacked somewhere. # # Change into the `src' directory. # cd sawfish-x.yz/src/ # # Run patch against this file to patch x.c: # patch -p1 < /path/to/x.c.patch # # Compile and install Sawfish. # make # make install # # Restart Sawfish. # # Alternatively, you might want to install sawfish using # some package manager, such as apt or RPM. Then you can # build and locally install just the patched library using # the following technique: # make # mkdir -p ~/.sawfish/lib/sawfish/wm/util # cp src/.libs/x.* ~/.sawfish/lib # cp src/.libs/x.* ~/.sawfish/lib/sawfish/wm/util # # You'll also need to add the following line to the *start* # of your ~/.sawfishrc: # (setq dl-load-path (cons "~/.sawfish/lib" dl-load-path)) # # Restart Sawfish. # # ****************** # ** HERE BE BUGS ** # ****************** # # Many XLib features are unimplemented and misimplemented. # # My understanding of rep modules is incomplete and erroneous. # # In order to support managed windows I introduced many hacks with # UNKNOWN CONSEQUENCES. # # This code allows you to emulate being a distinct X application when you # are in fact just a tiny part of a Window Manager that knows NOTHING # about you. As a result, expect Window Management not to work as it # should, and expect Your Application not to work as it should. You won't # get events that you expect, you will get events that you don't and the # Window Manager will simply not operate 100% as it should. # # In particular, if you create a managed window then it will probably be # useless to you; you'll want to cover it with a child. # # One day I'll chop this off so it is a separate rep module that allows # you to write standalone XLib applications that are not bastard, # deformed monstrosities sprouting from the side of something beautiful. # # - merlin Index: src/x.c =================================================================== RCS file: /cvs/gnome/sawfish/src/x.c,v retrieving revision 1.23 diff -u -r1.23 x.c --- src/x.c 3 Nov 2002 02:22:43 -0000 1.23 +++ src/x.c 10 Nov 2002 22:41:28 -0000 @@ -6,6 +6,9 @@ Originally written by merlin , with additions from John Harper + Then patched again by merlin to add some wicked functions: + x.c#pl:merlin/-0.8.6 + This file is part of sawmill. sawmill is free software; you can redistribute it and/or modify it @@ -73,6 +76,7 @@ int is_pixmap : 1; int is_bitmap : 1; /* depth == 1 */ int width, height; + repv plist; } Lisp_X_Window; #define X_XDRAWABLEP(v) rep_CELL16_TYPEP(v, x_window_type) @@ -83,6 +87,8 @@ #define X_PIXMAPP(v) (X_DRAWABLEP (v) && VX_DRAWABLE (v)->is_pixmap) #define X_BITMAPP(v) (X_DRAWABLEP (v) && VX_DRAWABLE (v)->is_bitmap) +#define ANY_WINDOWP(w) (rep_INTEGERP(w) || X_WINDOWP(w) || (WINDOWP(w) && VWIN(w)->id != 0)) + static Lisp_X_GC *x_gc_list = NULL; int x_gc_type; @@ -116,6 +122,37 @@ DEFSYM (clip_mask, "clip-mask"); DEFSYM (clip_x_origin, "clip-x-origin"); DEFSYM (clip_y_origin, "clip-y-origin"); +DEFSYM (sibling, "sibling"); +DEFSYM (stack_mode, "stack-mode"); +DEFSYM (override_redirect, "override-redirect"); +DEFSYM (save_under, "save-under"); +DEFSYM (event_mask, "event-mask"); +DEFSYM (parent, "parent"); +DEFSYM (raise_lowest, "raise-lowest"); +DEFSYM (lower_highest, "lower-highest"); + +DEFSYM (serial, "serial"); +DEFSYM (send_event, "send-event"); +DEFSYM (window, "window"); +DEFSYM (event, "event"); +DEFSYM (subwindow, "subwindow"); +DEFSYM (time, "time"); +DEFSYM (x_root, "x-root"); +DEFSYM (y_root, "y-root"); +DEFSYM (state, "state"); +DEFSYM (keycode, "keycode"); +DEFSYM (same_screen, "same-screen"); +DEFSYM (button, "button"); +DEFSYM (is_hint, "is-hint"); +DEFSYM (focus, "focus"); +DEFSYM (mode, "mode"); +DEFSYM (detail, "detail"); +DEFSYM (count, "count"); +DEFSYM (message_type, "message-type"); +DEFSYM (format, "format"); +DEFSYM (data, "data"); +DEFSYM (above, "above"); +DEFSYM (value_mask, "value-mask"); DEFSYM (LineSolid, "line-solid"); DEFSYM (LineOnOffDash, "line-on-off-dash"); @@ -217,6 +254,54 @@ return GXcopy; } +static Atom +x_symbol_atom (repv symbol) { + return XInternAtom (dpy, rep_STR (rep_SYM (symbol)->name), False); +} + + +/* Symbol matching Functions */ + +typedef struct { + unsigned int value; + char *str; +} x_value_str; + +static repv +x_value_match (unsigned int value, x_value_str *match) { + while (match->str) { + if (value == match->value) + return Fintern (rep_string_dup (match->str), Qnil); + ++ match; + } + return Qnil; +} + +static repv +x_valuemask_match (unsigned int value, x_value_str *match) { + repv result = Qnil; + while (match->str) { + if (value & match->value) + result = Fcons (Fintern (rep_string_dup (match->str), Qnil), result); + ++ match; + } + return result; +} + +static int +x_symbol_match (repv symbol, x_value_str *match) { + char *tmp; + if (!rep_SYMBOLP (symbol)) + return -1; + tmp = rep_STR (rep_SYM (symbol)->name); + while (match->str) { + if (!strcmp (match->str, tmp)) + return match->value; + ++ match; + } + return -1; +} + /* GC Functions */ @@ -500,6 +585,16 @@ return Qt; } +DEFUN ("x-free-gc", Fx_free_gc, Sx_free_gc, (repv gc), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-free-gc:: +x-free-gc X-GC + +Free the X-GC. Same as x-destroy-gc. +::end:: */ +{ + return Fx_destroy_gc (gc); +} + DEFUN ("x-gc-p", Fx_gc_p, Sx_gc_p, (repv gc), rep_Subr1) /* ::doc:sawfish.wm.util.x#x-gc-p:: x-gcp ARG @@ -513,6 +608,15 @@ /* Window functions */ +static x_value_str x_stack_mode_matches[] = { + { Above, "above" }, + { Below, "below" }, + { TopIf, "top-if" }, + { BottomIf, "bottom-if" }, + { Opposite, "opposite" }, + { 0, 0 } +}; + static long x_window_parse_changes (XWindowChanges *changes, repv attrs) { @@ -550,6 +654,24 @@ changes->border_width = rep_INT (rep_CDR (tem)); changesMask |= CWBorderWidth; } + else if (car == Qsibling) + { + Window sibling = window_from_arg (rep_CDR (tem)); + if (sibling) + { + changes->sibling = sibling; + changesMask |= CWSibling; + } + } + else if (car == Qstack_mode) + { + int stack_mode = x_symbol_match (rep_CDR (tem), x_stack_mode_matches); + if (stack_mode != -1) + { + changes->stack_mode = stack_mode; + changesMask |= CWStackMode; + } + } } attrs = rep_CDR (attrs); @@ -567,6 +689,35 @@ w->height = changes->height; } +static x_value_str x_event_mask_matches[] = { + { KeyPressMask, "key-press" }, + { KeyReleaseMask, "key-release" }, + { ButtonPressMask, "button-press" }, + { ButtonReleaseMask, "button-release" }, + { EnterWindowMask, "enter-window" }, + { LeaveWindowMask, "leave-window" }, + { PointerMotionMask, "pointer-motion" }, + { PointerMotionHintMask, "pointer-motion-hint" }, + { Button1MotionMask, "button-1-motion" }, + { Button2MotionMask, "button-2-motion" }, + { Button3MotionMask, "button-3-motion" }, + { Button4MotionMask, "button-4-motion" }, + { Button5MotionMask, "button-5-motion" }, + { ButtonMotionMask, "button-motion" }, + { KeymapStateMask, "keymap-state" }, + { ExposureMask, "exposure" }, + { VisibilityChangeMask, "visibility-change" }, + { StructureNotifyMask, "structure-notify" }, + { ResizeRedirectMask, "resize-redirect" }, + { SubstructureNotifyMask, "substructure-notify" }, + { SubstructureRedirectMask, "substructure-redirect" }, + { FocusChangeMask, "focus-change" }, + { PropertyChangeMask, "property-change" }, + { ColormapChangeMask, "colormap-change" }, + { OwnerGrabButtonMask, "owner-grab-button" }, + { 0, 0 } +}; + static long x_window_parse_attributes (XSetWindowAttributes *attributes, repv attrs) { @@ -589,6 +740,28 @@ attributes->border_pixel = VCOLOR (rep_CDR (tem))->pixel; attributesMask |= CWBorderPixel; } + else if (car == Qoverride_redirect) + { + attributes->override_redirect = rep_NILP(rep_CDR(tem)) ? False : True; + attributesMask |= CWOverrideRedirect; + } + else if (car == Qsave_under) + { + attributes->save_under = rep_NILP(rep_CDR(tem)) ? False : True; + attributesMask |= CWSaveUnder; + } + else if ((car == Qevent_mask) && rep_LISTP(rep_CDR(tem))) + { + repv evl = rep_CDR (tem); + attributes->event_mask = 0; + while (rep_CONSP (evl)) { + int mask = x_symbol_match (rep_CAR (evl), x_event_mask_matches); + if (mask != -1) + attributes->event_mask |= mask; + evl = rep_CDR (evl); + } + attributesMask |= CWEventMask; + } } attrs = rep_CDR (attrs); @@ -597,32 +770,290 @@ return attributesMask; } +/* inefficient */ +static x_value_str x_event_type_matches[] = { + { KeyPress, "key-press" }, + { KeyRelease, "key-release" }, + { ButtonPress, "button-press" }, + { ButtonRelease, "button-release" }, + { MotionNotify, "motion-notify" }, + { EnterNotify, "enter-notify" }, + { LeaveNotify, "leave-notify" }, + { FocusIn, "focus-in" }, + { FocusOut, "focus-out" }, + { KeymapNotify, "keymap-notify" }, + { Expose, "expose" }, + { GraphicsExpose, "graphics-expose" }, + { NoExpose, "no-expose" }, + { VisibilityNotify, "visibility-notify" }, + { CreateNotify, "create-notify" }, + { DestroyNotify, "destroy-notify" }, + { UnmapNotify, "unmap-notify" }, + { MapNotify, "map-notify" }, + { MapRequest, "map-request" }, + { ReparentNotify, "reparent-notify" }, + { ConfigureNotify, "configure-notify" }, + { ConfigureRequest, "configure-request" }, + { GravityNotify, "gravity-notify" }, + { ResizeRequest, "resize-request" }, + { CirculateNotify, "circulate-notify" }, + { CirculateRequest, "circulate-request" }, + { PropertyNotify, "property-notify" }, + { SelectionClear, "selection-clear" }, + { SelectionRequest, "selection-request" }, + { SelectionNotify, "selection-notify" }, + { ColormapNotify, "colormap-notify" }, + { ClientMessage, "client-message" }, + { MappingNotify, "mapping-notify" }, + { 0, 0 } +}; + +static x_value_str x_crossing_mode_matches[] = { + { NotifyNormal, "notify-normal" }, + { NotifyGrab, "notify-grab" }, + { NotifyUngrab, "notify-ungrab" }, + { 0, 0 } +}; + +static x_value_str x_crossing_detail_matches[] = { + { NotifyAncestor, "notify-ancestor" }, + { NotifyVirtual, "notify-virtual" }, + { NotifyInferior, "notify-inferior" }, + { NotifyNonlinear, "notify-nonlinear" }, + { NotifyNonlinearVirtual, "notify-nonlinear-virtual" }, + { 0, 0 } +}; + +static x_value_str x_motion_is_hint_matches[] = { + { NotifyNormal, "notify-normal" }, + { NotifyHint, "notify-hint" }, + { 0, 0 } +}; + +static x_value_str x_button_matches[] = { + { Button1, "button-1" }, + { Button2, "button-2" }, + { Button3, "button-3" }, + { Button4, "button-4" }, + { Button5, "button-5" }, + { 0, 0 } +}; + +static x_value_str x_state_matches[] = { + { Button1Mask, "button-1" }, + { Button2Mask, "button-2" }, + { Button3Mask, "button-3" }, + { Button4Mask, "button-4" }, + { Button5Mask, "button-5" }, + { ShiftMask, "shift" }, + { LockMask, "lock" }, + { ControlMask, "control" }, + { Mod1Mask, "mod-1" }, + { Mod2Mask, "mod-2" }, + { Mod3Mask, "mod-3" }, + { Mod4Mask, "mod-4" }, + { Mod5Mask, "mod-5" }, + { 0, 0 } +}; + +static x_value_str x_configure_mask_matches[] = { + { CWX, "x" }, + { CWY, "y" }, + { CWWidth, "width" }, + { CWHeight, "height" }, + { CWBorderWidth, "border-width" }, + { CWSibling, "sibling" }, + { CWStackMode, "stack-mode" }, + { 0, 0 } +}; + +static repv +x_encode_keysym (unsigned int keycode, unsigned int state) { + KeySym sym = NoSymbol; + char *name; + if (state & ShiftMask) + sym = XKeycodeToKeysym (dpy, keycode, 1); + if (sym == NoSymbol) + sym = XKeycodeToKeysym (dpy, keycode, 0); + /* I don't reset the shift modifier!!! */ + name = XKeysymToString (sym); + return name ? Fintern (rep_string_dup (name), Qnil) : Qnil; +} + +#define ALIST_PRE(A,B,C) A = Fcons (Fcons (B, C), A) + +static repv x_window_or_int_from_id (Window window) { + repv tmp = x_window_from_id (window); + if (tmp == Qnil) + tmp = rep_MAKE_INT (window); + return tmp; +} + +static repv +x_encode_event (XEvent *ev) +{ + repv event = Qnil, data = Qnil; + + ALIST_PRE (event, Qserial, rep_make_long_uint (ev->xany.serial)); + ALIST_PRE (event, Qsend_event, ev->xany.send_event ? Qt : Qnil); + ALIST_PRE (event, Qwindow, x_window_from_id (ev->xany.window)); + + switch (ev->type) { + case KeyPress: + case KeyRelease: + ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xkey.root)); + ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xkey.subwindow)); + ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xkey.time)); + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xkey.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xkey.y)); + ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xkey.x_root)); + ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xkey.y_root)); + ALIST_PRE (event, Qstate, x_valuemask_match (ev->xkey.state, x_state_matches)); + ALIST_PRE (event, Qkeycode, x_encode_keysym (ev->xkey.keycode, ev->xkey.state)); + ALIST_PRE (event, Qsame_screen, ev->xkey.same_screen ? Qt : Qnil); + break; + + case ButtonPress: + case ButtonRelease: + ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xbutton.root)); + ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xbutton.subwindow)); + ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xbutton.time)); + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xbutton.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xbutton.y)); + ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xbutton.x_root)); + ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xbutton.y_root)); + ALIST_PRE (event, Qstate, x_valuemask_match (ev->xbutton.state, x_state_matches)); + ALIST_PRE (event, Qbutton, x_value_match (ev->xbutton.button, x_button_matches)); + ALIST_PRE (event, Qsame_screen, ev->xbutton.same_screen ? Qt : Qnil); + break; + + case MotionNotify: + ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xmotion.root)); + ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xmotion.subwindow)); + ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xmotion.time)); + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xmotion.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xmotion.y)); + ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xmotion.x_root)); + ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xmotion.y_root)); + ALIST_PRE (event, Qstate, x_valuemask_match (ev->xmotion.state, x_state_matches)); + ALIST_PRE (event, Qis_hint, x_value_match (ev->xmotion.is_hint, x_motion_is_hint_matches)); + ALIST_PRE (event, Qsame_screen, ev->xmotion.same_screen ? Qt : Qnil); + break; + + case EnterNotify: + case LeaveNotify: + ALIST_PRE (event, Qroot, x_window_or_int_from_id (ev->xcrossing.root)); + ALIST_PRE (event, Qsubwindow, x_window_or_int_from_id (ev->xcrossing.subwindow)); + ALIST_PRE (event, Qtime, rep_make_long_uint (ev->xcrossing.time)); + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xcrossing.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xcrossing.y)); + ALIST_PRE (event, Qx_root, rep_MAKE_INT (ev->xcrossing.x_root)); + ALIST_PRE (event, Qy_root, rep_MAKE_INT (ev->xcrossing.y_root)); + ALIST_PRE (event, Qmode, x_value_match (ev->xcrossing.mode, x_crossing_mode_matches)); + ALIST_PRE (event, Qdetail, x_value_match (ev->xcrossing.detail, x_crossing_detail_matches)); + ALIST_PRE (event, Qsame_screen, ev->xcrossing.same_screen ? Qt : Qnil); + ALIST_PRE (event, Qfocus, ev->xcrossing.focus ? Qt : Qnil); + ALIST_PRE (event, Qstate, x_valuemask_match (ev->xcrossing.state, x_state_matches)); + break; + + case Expose: + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xexpose.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xexpose.y)); + ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xexpose.width)); + ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xexpose.height)); + ALIST_PRE (event, Qcount, rep_MAKE_INT (ev->xexpose.count)); + break; + + case DestroyNotify: + ALIST_PRE (event, Qevent, x_window_or_int_from_id (ev->xdestroywindow.event)); + ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xdestroywindow.window)); + break; + + case ConfigureNotify: + ALIST_PRE (event, Qevent, x_window_or_int_from_id (ev->xconfigure.event)); + ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xconfigure.window)); + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xconfigure.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xconfigure.y)); + ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xconfigure.width)); + ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xconfigure.height)); + ALIST_PRE (event, Qborder_width, rep_MAKE_INT (ev->xconfigure.border_width)); + ALIST_PRE (event, Qabove, x_window_or_int_from_id (ev->xconfigure.above)); + ALIST_PRE (event, Qoverride_redirect, ev->xconfigure.override_redirect ? Qt : Qnil); + break; + + case ConfigureRequest: + ALIST_PRE (event, Qparent, x_window_or_int_from_id (ev->xconfigurerequest.parent)); + ALIST_PRE (event, Qwindow, x_window_or_int_from_id (ev->xconfigurerequest.window)); + ALIST_PRE (event, Qx, rep_MAKE_INT (ev->xconfigurerequest.x)); + ALIST_PRE (event, Qy, rep_MAKE_INT (ev->xconfigurerequest.y)); + ALIST_PRE (event, Qwidth, rep_MAKE_INT (ev->xconfigurerequest.width)); + ALIST_PRE (event, Qheight, rep_MAKE_INT (ev->xconfigurerequest.height)); + ALIST_PRE (event, Qborder_width, rep_MAKE_INT (ev->xconfigurerequest.border_width)); + ALIST_PRE (event, Qabove, x_window_or_int_from_id (ev->xconfigurerequest.above)); + ALIST_PRE (event, Qdetail, x_value_match (ev->xconfigurerequest.detail, x_stack_mode_matches)); + ALIST_PRE (event, Qvalue_mask, x_valuemask_match (ev->xconfigurerequest.value_mask, x_configure_mask_matches)); + break; + + case ClientMessage: + ALIST_PRE (event, Qmessage_type, x_atom_symbol (ev->xclient.message_type)); + ALIST_PRE (event, Qformat, rep_MAKE_INT (ev->xclient.format)); + data = Qnil; + switch (ev->xclient.format) { + int i; + + case 8: /* not a string because length unknown */ + data = Fmake_vector (rep_MAKE_INT (20), Qnil); + for (i = 0; i < 20; ++ i) + rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.b[i]); + break; + + case 16: + data = Fmake_vector (rep_MAKE_INT (10), Qnil); + for (i = 0; i < 10; ++ i) + rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.s[i]); + break; + + case 32: + data = Fmake_vector (rep_MAKE_INT (5), Qnil); + for (i = 0; i < 5; ++ i) /* decoding atoms makes little sense */ + rep_VECTI (data, i) = rep_MAKE_INT (ev->xclient.data.l[i]); + break; + } + ALIST_PRE (event, Qdata, data); + break; + } + + /* + not done... + FocusIn FocusOut KeymapNotify GraphicsExpose NoExpose VisibilityNotify + CreateNotify UnmapNotify MapNotify MapRequest ReparentNotify + ConfigureRequest GravityNotify ResizeRequest CirculateNotify + CirculateRequest PropertyNotify SelectionClear SelectionRequest + SelectionNotify ColormapNotify MappingNotify + */ + + return event; +} + static void x_window_event_handler (XEvent *ev) { repv win = x_window_from_id (ev->xany.window); if (win != Qnil && VX_DRAWABLE (win)->event_handler != Qnil) { - repv type = Qnil, args = Qnil; - switch (ev->type) - { - case Expose: - /* Since we don't provide a method of detecting which - part of the window to redraw, ignore all but the last - expose event. (Another option is to set the clip - rectangle?) */ - if (ev->xexpose.count == 0) - type = Qexpose; - break; - - /* XXX other event types..? */ - } - if (type != Qnil) - { - args = Fcons (type, Fcons (win, args)); - rep_funcall (VX_DRAWABLE (win)->event_handler, args, rep_FALSE); - } + repv type = x_value_match (ev->type, x_event_type_matches); + repv event = x_encode_event (ev); + repv args = Fcons (type, Fcons (win, Fcons (event, Qnil))); + /* Note that in Sawfish 0.34+, expose events whose count is non + * zero are silently suppressed. I don't do that because I + * supply the count. Which means that other people's expose + * handlers will be called multiply... */ + if (rep_funcall (VX_DRAWABLE(win)->event_handler, args, rep_FALSE) != Qnil) + return; /* don't call standard event-handler on non-nil result */ } + + if (ev->type < LASTEvent && event_handlers[ev->type] != 0) + event_handlers[ev->type] (ev); } static Lisp_X_Window * @@ -638,10 +1069,37 @@ w->height = height; w->is_window = w->is_pixmap = w->is_bitmap = 0; w->event_handler = Qnil; + w->plist = Qnil; XSaveContext (dpy, id, x_drawable_context, (XPointer) w); return w; } +DEFUN ("x-reparent-window", Fx_reparent_window, Sx_reparent_window, + (repv win, repv parent, repv xy), rep_Subr3) /* +::doc:sawfish.wm.util.x#x-create-window:: +x-create-window WINDOW PARENT (X . Y) + +Reparents a windows. +::end:: */ +{ + Window _win, _parent; + int _x, _y; + + rep_DECLARE1(win, ANY_WINDOWP); + rep_DECLARE (2, parent, (parent == Qnil) || ANY_WINDOWP (parent)); + rep_DECLARE (3, xy, rep_CONSP (xy) + && rep_INTP (rep_CAR (xy)) && rep_INTP (rep_CDR (xy))); + + _win = window_from_arg (win); + _parent = (parent == Qnil) ? root_window : window_from_arg (parent); + _x = rep_INT (rep_CAR (xy)); + _y = rep_INT (rep_CDR (xy)); + + XReparentWindow (dpy, _win, _parent, _x, _y); + + return Qt; +} + DEFUN ("x-create-window", Fx_create_window, Sx_create_window, (repv xy, repv wh, repv bw, repv attrs, repv ev), rep_Subr5) /* ::doc:sawfish.wm.util.x#x-create-window:: @@ -649,12 +1107,15 @@ Creates a new X-WINDOW with the specified position, dimensions and border width. ATTRS should be a list of cons cells mapping attributes -to values. Known attributes are `background' and `border-color'. The -window is created unmapped. +to values. Known attributes include the symbols `x', `y', +`width', `height', `border-width', `sibling' and `stack-mode'. Valid +values for stack-mode are `above', `below', `top-if', `bottom-if' and +`opposite'. The window is created unmapped. ::end:: */ { Lisp_X_Window *w; - Window id; + repv parent = Qnil; + Window id, _parent; XSetWindowAttributes attributes; long attributesMask; int _x, _y, _w, _h, _bw; @@ -666,6 +1127,11 @@ rep_DECLARE3 (bw, rep_INTP); rep_DECLARE4 (attrs, rep_LISTP); + if (rep_CONSP (attrs) && (Fassq (Qparent, attrs) != Qnil)) + parent = rep_CDR (Fassq (Qparent, attrs)); + if (!(_parent = window_from_arg (parent))) + _parent = root_window; + _x = rep_INT (rep_CAR (xy)); _y = rep_INT (rep_CDR (xy)); _w = rep_INT (rep_CAR (wh)); @@ -673,19 +1139,21 @@ _bw = rep_INT (bw); attributesMask = x_window_parse_attributes (&attributes, attrs); - attributes.override_redirect = True; - attributes.event_mask = ExposureMask; - attributes.colormap = image_cmap; + if (! (attributesMask & CWOverrideRedirect)) + { + attributes.override_redirect = True; + attributesMask |= CWOverrideRedirect; + } if (! (attributesMask & CWBorderPixel)) { attributes.border_pixel = BlackPixel (dpy, BlackPixel (dpy, screen_num)); attributesMask |= CWBorderPixel; } + attributes.colormap = image_cmap; + attributesMask |= CWOverrideRedirect; - attributesMask |= CWOverrideRedirect | CWEventMask | CWColormap; - - id = XCreateWindow (dpy, root_window, _x, _y, _w, _h, _bw, + id = XCreateWindow (dpy, _parent, _x, _y, _w, _h, _bw, image_depth, InputOutput, image_visual, attributesMask, &attributes); @@ -738,17 +1206,80 @@ return rep_VAL (w); } +DEFUN("x-map-notify", Fx_map_notify, Sx_map_notify, (repv win), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-map-notify:: +x-map-notify X-WINDOW +::end:: */ +{ + XEvent fake = { MapNotify }; /* ouch the pain */ + rep_DECLARE1(win, ANY_WINDOWP); + + fake.xmap.window = window_from_arg (win); + fake.xmap.event = fake.xmap.window; + + event_handlers[MapNotify] (&fake); + + return Qt; +} + +DEFUN("x-map-request", Fx_map_request, Sx_map_request, (repv win), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-map-request:: +x-map-request X-WINDOW +::end:: */ +{ + XEvent fake = { MapRequest }; /* ouch the pain */ + rep_DECLARE1(win, ANY_WINDOWP); + + fake.xmaprequest.window = window_from_arg (win); + + event_handlers[MapRequest] (&fake); + + return Qt; +} + DEFUN ("x-map-window", Fx_map_window, Sx_map_window, (repv win, repv unraised), rep_Subr2) /* ::doc:sawfish.wm.util.x#x-map-window:: x-map-window X-WINDOW [UNRAISED] ::end:: */ { - rep_DECLARE1 (win, X_WINDOWP); + rep_DECLARE1 (win, ANY_WINDOWP); if (unraised == Qnil) - XMapRaised (dpy, VX_DRAWABLE (win)->id); + XMapRaised (dpy, window_from_arg (win)); else - XMapWindow (dpy, VX_DRAWABLE (win)->id); + XMapWindow (dpy, window_from_arg (win)); + return Qt; +} + +DEFUN ("x-x-map-window", Fx_x_map_window, Sx_x_map_window, (repv win), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-x-map-window:: +x-x-map-window X-WINDOW + +The real XMapWindow. +::end:: */ +{ + rep_DECLARE1 (win, ANY_WINDOWP); + XMapWindow (dpy, window_from_arg (win)); + return Qt; +} + +DEFUN("x-map-raised", Fx_map_raised, Sx_map_raised, (repv win), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-map-raised:: +x-map-raised X-WINDOW +::end:: */ +{ + rep_DECLARE1(win, ANY_WINDOWP); + XMapRaised (dpy, window_from_arg (win)); + return Qt; +} + +DEFUN("x-map-subwindows", Fx_map_subwindows, Sx_map_subwindows, (repv win), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-map-subwindows:: +x-map-subwindows X-WINDOW +::end:: */ +{ + rep_DECLARE1(win, ANY_WINDOWP); + XMapSubwindows (dpy, window_from_arg (win)); return Qt; } @@ -758,8 +1289,52 @@ x-unmap-window X-WINDOW ::end:: */ { - rep_DECLARE1 (win, X_WINDOWP); - XUnmapWindow (dpy, VX_DRAWABLE (win)->id); + rep_DECLARE1 (win, ANY_WINDOWP); + XUnmapWindow (dpy, window_from_arg (win)); + return Qt; +} + +DEFUN("x-unmap-subwindows", Fx_unmap_subwindows, Sx_unmap_subwindows, (repv win), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-unmap-subwindows:: +x-unmap-subwindows X-WINDOW +::end:: */ +{ + rep_DECLARE1(win, ANY_WINDOWP); + XUnmapSubwindows (dpy, window_from_arg (win)); + return Qt; +} + +DEFUN("x-configure-request", Fx_configure_request, Sx_configure_request, (repv window, repv attrs), rep_Subr2) /* +::doc:sawfish.wm.util.x#x-configure-request:: +x-configure-request WINDOW ATTRS +::end:: */ +{ + XWindowChanges changes; + long changesMask; + + rep_DECLARE1(window, ANY_WINDOWP); + rep_DECLARE2(attrs, rep_LISTP); + + changesMask = x_window_parse_changes (&changes, attrs); + + if (changesMask) + { + XEvent fake = { ConfigureRequest }; + + fake.xconfigurerequest.display = dpy; + fake.xconfigurerequest.window = window_from_arg (window); + fake.xconfigurerequest.x = changes.x; + fake.xconfigurerequest.y = changes.y; + fake.xconfigurerequest.width = changes.width; + fake.xconfigurerequest.height = changes.height; + fake.xconfigurerequest.border_width = changes.border_width; + fake.xconfigurerequest.above = changes.sibling; + fake.xconfigurerequest.detail = changes.stack_mode; + fake.xconfigurerequest.value_mask = changesMask; + + event_handlers[ConfigureRequest] (&fake); + } + return Qt; } @@ -770,22 +1345,25 @@ Reconfigures the X-WINDOW. ATTRS should be an alist mapping attribute names to values. Known attributes include the symbols `x', `y', -`width', `height' and `border-width'. +`width', `height', `border-width', `sibling' and `stack-mode'. Valid +values for stack-mode are `above', `below', `top-if', `bottom-if' and +`opposite'. ::end:: */ { XWindowChanges changes; long changesMask; - rep_DECLARE1 (window, X_WINDOWP); + rep_DECLARE1 (window, ANY_WINDOWP); rep_DECLARE2 (attrs, rep_LISTP); changesMask = x_window_parse_changes (&changes, attrs); if (changesMask) { - XConfigureWindow (dpy, VX_DRAWABLE (window)->id, + XConfigureWindow (dpy, window_from_arg (window), changesMask, &changes); - x_window_note_changes (VX_DRAWABLE (window), changesMask, &changes); + if (X_DRAWABLEP (window)) + x_window_note_changes (VX_DRAWABLE (window), changesMask, &changes); } return Qt; @@ -804,20 +1382,118 @@ XSetWindowAttributes attributes; long attributesMask; - rep_DECLARE1 (window, X_WINDOWP); + rep_DECLARE1 (window, ANY_WINDOWP); rep_DECLARE2 (attrs, rep_LISTP); attributesMask = x_window_parse_attributes (&attributes, attrs); if (attributesMask) { - XChangeWindowAttributes (dpy, VX_DRAWABLE (window)->id, + XChangeWindowAttributes (dpy, window_from_arg (window), attributesMask, &attributes); } return Qt; } +DEFUN("x-x-raise-window", Fx_x_raise_window, Sx_x_raise_window, (repv window), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-x-raise-window:: +x-x-raise-window WINDOW + +The real XRaiseWindow. Raises the X-WINDOW. +::end:: */ +{ + rep_DECLARE1(window, ANY_WINDOWP); + + XRaiseWindow (dpy, window_from_arg (window)); + + return Qt; +} + +DEFUN("x-x-lower-window", Fx_x_lower_window, Sx_x_lower_window, (repv window), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-x-lower-window:: +x-x-lower-window WINDOW + +The real XLowerWindow. Lowers the X-WINDOW. +::end:: */ +{ + rep_DECLARE1(window, ANY_WINDOWP); + + XLowerWindow (dpy, window_from_arg (window)); + + return Qt; +} + +DEFUN("x-circulate-subwindows", Fx_circulate_subwindows, Sx_circulate_subwindows, (repv window, repv direction), rep_Subr2) /* +::doc:sawfish.wm.util.x#x-circulate-subwindows:: +x-circulate-subwindows WINDOW DIRECTION + +Circulates the subwindows of the X-WINDOW in DIRECTION +for either `raise-lowest' or `lower-highest'. +::end:: */ +{ + int _direction; + + rep_DECLARE1(window, ANY_WINDOWP); + rep_DECLARE(2, direction, (direction == Qraise_lowest) || (direction == Qlower_highest)); + _direction = (direction == Qraise_lowest) ? RaiseLowest : LowerHighest; + + XCirculateSubwindows (dpy, window_from_arg (window), _direction); + + return Qt; +} + +DEFUN("x-circulate-subwindows-up", Fx_circulate_subwindows_up, Sx_circulate_subwindows_up, (repv window), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-circulate-subwindows-up:: +x-circulate-subwindows-up WINDOW + +Circulates up the subwindows of the X-WINDOW. +::end:: */ +{ + rep_DECLARE1(window, ANY_WINDOWP); + + XCirculateSubwindowsUp (dpy, window_from_arg (window)); + + return Qt; +} + +DEFUN("x-circulate-subwindows-down", Fx_circulate_subwindows_down, Sx_circulate_subwindows_down, (repv window), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-circulate-subwindows-down:: +x-circulate-subwindows-down WINDOW + +Circulates down the subwindows of the X-WINDOW. +::end:: */ +{ + rep_DECLARE1(window, ANY_WINDOWP); + + XCirculateSubwindowsDown (dpy, window_from_arg (window)); + + return Qt; +} + +DEFUN("x-restack-windows", Fx_restack_windows, Sx_restack_windows, (repv list), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-restack-windows:: +x-restack-windows LIST + +Restacks the LIST of X-WINDOWs. +::end:: */ +{ + Window *windows; + int n = 0; + + rep_DECLARE1(list, rep_LISTP); + + windows = alloca (rep_INT (Flength (list)) * sizeof (Window)); + while (rep_CONSP (list)) { + if (X_WINDOWP (rep_CAR (list))) + windows[n ++] = window_from_arg (rep_CAR (list)); + list = rep_CDR (list); + } + XRestackWindows (dpy, windows, n); + + return Qt; +} + DEFUN ("x-destroy-drawable", Fx_destroy_drawable, Sx_destroy_drawable, (repv drawable), rep_Subr1) /* ::doc:sawfish.wm.util.x#x-destroy-drawable:: @@ -849,7 +1525,7 @@ Destroys the X-WINDOW. ::end:: */ { - return Fx_destroy_drawable (window); + return Fx_destroy_drawable (window); /* TODO: window_from_arg and below? */ } DEFUN ("x-drawable-id", Fx_drawable_id, @@ -989,6 +1665,327 @@ } +/* Lisp property functions */ + +DEFUN ("x-window-put", Fx_window_put, Sx_window_put, (repv window, repv key, repv value), rep_Subr3) /* +::doc:sawfish.wm.util.x#x-window-put:: +x-window-put WINDOW KEY VALUE + +Stores the specified VALUE in the specified WINDOW under the specified +(symbolic) KEY. +::end:: */ +{ + repv plist, ptr; + + rep_DECLARE1(window, X_WINDOWP); + rep_DECLARE2(key, rep_SYMBOLP); + + ptr = plist = VX_DRAWABLE(window)->plist; + while (ptr != Qnil) { + repv cons = rep_CAR (ptr); + if (rep_CAR (cons) == key) { + rep_CDR (cons) = value; + return Qt; + } + ptr = rep_CDR (ptr); + } + VX_DRAWABLE(window)->plist = Fcons (Fcons (key, value), plist); + + return Qt; +} + +DEFUN ("x-window-get", Fx_window_get, Sx_window_get, (repv window, repv key), rep_Subr2) /* +::doc:sawfish.wm.util.x#x-window-get:: +x-window-get WINDOW KEY + +Gets the value stored in the specified WINDOW under the specified +(symbolic) KEY. +::end:: */ +{ + repv plist, ptr; + + rep_DECLARE1(window, X_WINDOWP); + rep_DECLARE2(key, rep_SYMBOLP); + + ptr = plist = VX_DRAWABLE(window)->plist; + while (ptr != Qnil) { + repv cons = rep_CAR (ptr); + if (rep_CAR (cons) == key) + return rep_CDR (cons); + ptr = rep_CDR (ptr); + } + + return Qnil; +} + + +/* X property functions */ + +DEFUN("x-set-text-property", Fx_set_text_property, Sx_set_text_property, (repv window, repv textv, repv property), rep_Subr3) /* +::doc:sawfish.wm.util.x#x-set-text-property:: +x-set-text-property X-WINDOW TEXTV PROPERTY + +Sets the specified PROPERTY on the specified X-WINDOW to the specified +value TEXTV, a vector of strings. +::end:: */ +{ + Atom _prop; + int i, n; + char **_textv; + XTextProperty textprop; + + rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (textv, rep_VECTORP); + n = rep_VECT_LEN (textv); + for (i = 0; i < n; ++ i) + rep_DECLARE (2, textv, rep_STRINGP (rep_VECTI (textv, i))); + rep_DECLARE3 (property, rep_SYMBOLP); + + _prop = x_symbol_atom (property); + _textv = alloca (n * sizeof (char *)); + for (i = 0; i < n; ++ i) + _textv[i] = rep_STR (rep_VECTI (textv, i)); + if (!XStringListToTextProperty (_textv, n, &textprop)) + return Qnil; + + XSetTextProperty (dpy, window_from_arg (window), &textprop, _prop); + XFree (textprop.value); + + return Qt; +} + +DEFUN("x-get-text-property", Fx_get_text_property, Sx_get_text_property, (repv window, repv property), rep_Subr2) /* +::doc:sawfish.wm.util.x#x-get-text-property:: +x-get-text-property X-WINDOW PROPERTY + +Gets the specified PROPERTY of the specified X-WINDOW as a vector +of strings. +::end:: */ +{ + Atom _prop; + XTextProperty textprop; + int i, n; + char **_textv; + repv textv; + + rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (property, rep_SYMBOLP); + + _prop = x_symbol_atom (property); + if (!XGetTextProperty (dpy, window_from_arg (window), &textprop, _prop)) + return Qnil; + if (!XTextPropertyToStringList (&textprop, &_textv, &n)) { + XFree (textprop.value); + return Qnil; + } + XFree (textprop.value); + textv = Fmake_vector (rep_MAKE_INT (n), Qnil); + for (i = 0; i < n; ++ i) + rep_VECTI (textv, i) = rep_string_dup (_textv[i]); + XFreeStringList (_textv); + + return textv; +} + +DEFUN("x-list-properties", Fx_list_properties, Sx_list_properties, (repv window), rep_Subr1) /* +::doc:sawfish.wm.util.x#x-list-properties:: +x-list-properties X-WINDOW + +Returns a list of the properties of the specified X-WINDOW. +::end:: */ +{ + Atom *atoms; + char **_props; + repv props = Qnil; + int i, n; + + rep_DECLARE1 (window, ANY_WINDOWP); + + atoms = XListProperties (dpy, window_from_arg (window), &n); + if (!atoms) + return Qnil; + _props = alloca (n * sizeof (char *)); + if (!XGetAtomNames (dpy, atoms, n, _props)) { + XFree (atoms); + return Qnil; + } + XFree (atoms); + for (i = n - 1; i >= 0; -- i) + props = Fcons (Fintern (rep_string_dup (_props[i]), Qnil), props); + for (i = 0; i < n; ++ i) + XFree (_props[i]); + + return props; +} + +static x_value_str x_change_property_mode_matches[] = { + { PropModeReplace, "prop-mode-replace" }, + { PropModePrepend, "prop-mode-prepend" }, + { PropModeAppend, "prop-mode-append" }, + { 0, 0 } +}; + +#define nDECLARE(index,arg, assert) {\ + rep_DECLARE (index, args, rep_CONSP (args));\ + arg = rep_CAR (args);\ + args = rep_CDR (args);\ + rep_DECLARE (index, arg, assert);\ +} + +DEFUN("x-change-property", Fx_change_property, Sx_change_property, (repv args), rep_SubrN) /* +::doc:sawfish.wm.util.x#x-change-property:: +x-change-property X-WINDOW PROPERTY TYPE FORMAT MODE DATAV + +Sets the specified PROPERTY in the specified X-WINDOW to the +specified TYPE vector value DATAV in format FORMAT. MODE can be +`prop-mode-replace', `prop-mode-prepend' or `prop-mode-append'. +::end:: */ +{ + repv window, property, type, format, mode, datav; + Window _window; + Atom _property, _type; + int _format, _mode; + void *_data; + int i, n; + + nDECLARE (1, window, ANY_WINDOWP (window)); + _window = window_from_arg (window); + nDECLARE (2, property, rep_SYMBOLP (property)); + _property = x_symbol_atom (property); + nDECLARE (3, type, rep_SYMBOLP (type)); + _type = x_symbol_atom (type); + nDECLARE (4, format, rep_INTP (format)); + _format = rep_INT (format); + rep_DECLARE (4, format, (_format == 8) || (_format == 16) || (_format == 32));; + nDECLARE (5, mode, rep_SYMBOLP (mode)); + _mode = x_symbol_match (mode, x_change_property_mode_matches); + rep_DECLARE (5, mode, (_mode != -1)); + nDECLARE (6, datav, rep_VECTORP (datav)); + n = rep_VECT_LEN (datav); + for (i = 0; i < n; ++ i) + rep_DECLARE (6, datav, rep_INTP (rep_VECTI (datav, i))); + + _data = alloca (n * 4); + for (i = 0; i < n; ++ i) { + int datum = rep_INT (rep_VECTI (datav, i)); + if (format == 8) + ((char *) _data)[i] = (char) datum; + else if (format == 16) + ((short *) _data)[i] = (short) datum; + else + ((int *) _data)[i] = datum; + } + XChangeProperty (dpy, _window, _property, _type, _format, _mode, _data, n); + + return Qt; +} + +DEFUN("x-rotate-window-properties", Fx_rotate_window_properties, Sx_rotate_window_properties, (repv window, repv list, repv npos), rep_Subr3) /* +::doc:sawfish.wm.util.x#x-rotate-window-properties:: +x-rotate-window-properties X-WINDOW PROPERTIES NPOS + +Rotates the values of the specified list of X-WINDOW PROPERTIES by NPOS. +::end:: */ +{ + Atom *atoms; + int n = 0; + int _npos; + + rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (list, rep_LISTP); + rep_DECLARE3 (npos, rep_INTP); + + _npos = rep_INT (npos); + + atoms = alloca (rep_INT (Flength (list)) * sizeof (Atom)); + while (rep_CONSP (list)) { + if (rep_SYMBOLP (rep_CAR (list))) + atoms[n ++] = x_symbol_atom (rep_CAR (list)); + list = rep_CDR (list); + } + XRotateWindowProperties (dpy, window_from_arg (window), atoms, n, _npos); + + return Qt; +} + +DEFUN("x-delete-property", Fx_delete_property, Sx_delete_property, (repv window, repv property), rep_Subr2) /* +::doc:sawfish.wm.util.x#x-delete-property:: +x-delete-property X-WINDOW PROPERTY + +Deletes the specified PROPERTY from the specified X-WINDOW. +::end:: */ +{ + Atom _prop; + + rep_DECLARE1 (window, ANY_WINDOWP); + rep_DECLARE2 (property, rep_SYMBOLP); + + _prop = x_symbol_atom (property); + XDeleteProperty (dpy, window_from_arg (window), _prop); + + return Qt; +} + +DEFUN("x-get-window-property", Fx_get_window_property, Sx_get_window_property, (repv args), rep_SubrN) /* +::doc:sawfish.wm.util.x#x-get-window-property:: +x-get-window-property X-WINDOW PROPERTY LONG-OFFSET LONG-LENGTH DELETE TYPE + +Gets the specified PROPERTY from the specified X-WINDOW. If +DELETE is non-nil then the property is deleted. The return +is a list (type format bytes-after [value]). +::end:: */ +{ + repv window, property, offset, length, delete, type, format, nbytes, data; + Window _window; + Atom _property, _type, _ret_type; + Bool _delete; + long _offset, _length; + int _ret_fmt; + unsigned long _ret_nitems, _ret_nbytes; + unsigned char *_ret; + int i, n; + + /* I'm careless with my ints and longs */ + + nDECLARE (1, window, ANY_WINDOWP (window)); + _window = window_from_arg (window); + nDECLARE (2, property, rep_SYMBOLP (property)); + _property = x_symbol_atom (property); + nDECLARE (3, offset, rep_INTP (offset)); + _offset = rep_INT (offset); + nDECLARE (4, length, rep_INTP (length)); + _length = rep_INT (length); + nDECLARE (5, delete, 1); + _delete = delete != Qnil; + nDECLARE (6, type, rep_SYMBOLP (type)); + _type = x_symbol_atom (type); + + XGetWindowProperty (dpy, _window, _property, _offset, _length, _delete, + _type, &_ret_type, &_ret_fmt, &_ret_nitems, &_ret_nbytes, &_ret); + + type = x_atom_symbol (_ret_type); + format = rep_MAKE_INT (_ret_fmt); + nbytes = rep_MAKE_INT (_ret_nbytes); + n = (int) _ret_nitems; + data = Fmake_vector (rep_MAKE_INT (n), Qnil); + for (i = 0; i < n; ++ i) { + switch (_ret_fmt) { + case 8: + rep_VECTI (data, i) = rep_MAKE_INT (_ret[i]); + break; + case 16: + rep_VECTI (data, i) = rep_MAKE_INT (((unsigned short *) _ret)[i]); + break; + case 32: + rep_VECTI (data, i) = rep_MAKE_INT (((unsigned int *) _ret)[i]); + break; + } + } + + return Fcons (type, Fcons (format, Fcons (nbytes, Fcons (data, Qnil)))); +} + + /* Drawing functions */ DEFUN ("x-clear-window", Fx_clear_window, @@ -1456,6 +2453,7 @@ x_window_mark (repv obj) { rep_MARKVAL (VX_DRAWABLE (obj)->event_handler); + rep_MARKVAL (VX_DRAWABLE (obj)->plist); } static void @@ -1501,6 +2499,7 @@ rep_ADD_SUBR (Sx_create_root_xor_gc); rep_ADD_SUBR (Sx_change_gc); rep_ADD_SUBR (Sx_destroy_gc); + rep_ADD_SUBR (Sx_free_gc); rep_ADD_SUBR (Sx_gc_p); x_drawable_context = XUniqueContext (); @@ -1510,12 +2509,26 @@ x_window_sweep, x_window_mark, 0, 0, 0, 0, 0, 0, 0); rep_ADD_SUBR (Sx_create_window); + rep_ADD_SUBR (Sx_reparent_window); rep_ADD_SUBR (Sx_create_pixmap); rep_ADD_SUBR (Sx_create_bitmap); + rep_ADD_SUBR (Sx_map_request); + rep_ADD_SUBR (Sx_map_notify); rep_ADD_SUBR (Sx_map_window); + rep_ADD_SUBR (Sx_x_map_window); + rep_ADD_SUBR (Sx_map_raised); + rep_ADD_SUBR (Sx_map_subwindows); rep_ADD_SUBR (Sx_unmap_window); + rep_ADD_SUBR (Sx_unmap_subwindows); + rep_ADD_SUBR (Sx_configure_request); rep_ADD_SUBR (Sx_configure_window); rep_ADD_SUBR (Sx_change_window_attributes); + rep_ADD_SUBR (Sx_x_raise_window); + rep_ADD_SUBR (Sx_x_lower_window); + rep_ADD_SUBR (Sx_circulate_subwindows); + rep_ADD_SUBR (Sx_circulate_subwindows_up); + rep_ADD_SUBR (Sx_circulate_subwindows_down); + rep_ADD_SUBR (Sx_restack_windows); rep_ADD_SUBR (Sx_destroy_drawable); rep_ADD_SUBR (Sx_destroy_window); rep_ADD_SUBR (Sx_drawable_p); @@ -1529,6 +2542,17 @@ rep_ADD_SUBR (Sx_window_back_buffer); rep_ADD_SUBR (Sx_window_swap_buffers); + rep_ADD_SUBR (Sx_window_put); + rep_ADD_SUBR (Sx_window_get); + + rep_ADD_SUBR (Sx_set_text_property); + rep_ADD_SUBR (Sx_get_text_property); + rep_ADD_SUBR (Sx_get_window_property); + rep_ADD_SUBR (Sx_list_properties); + rep_ADD_SUBR (Sx_change_property); + rep_ADD_SUBR (Sx_rotate_window_properties); + rep_ADD_SUBR (Sx_delete_property); + rep_ADD_SUBR (Sx_clear_window); rep_ADD_SUBR (Sx_draw_string); rep_ADD_SUBR (Sx_draw_line); @@ -1565,6 +2589,37 @@ rep_INTERN (clip_mask); rep_INTERN (clip_x_origin); rep_INTERN (clip_y_origin); + rep_INTERN (sibling); + rep_INTERN (stack_mode); + rep_INTERN (override_redirect); + rep_INTERN (save_under); + rep_INTERN (event_mask); + rep_INTERN (parent); + + rep_INTERN (serial); + rep_INTERN (send_event); + rep_INTERN (event); + rep_INTERN (window); + rep_INTERN (subwindow); + rep_INTERN (time); + rep_INTERN (x_root); + rep_INTERN (y_root); + rep_INTERN (state); + rep_INTERN (keycode); + rep_INTERN (same_screen); + rep_INTERN (button); + rep_INTERN (is_hint); + rep_INTERN (focus); + rep_INTERN (mode); + rep_INTERN (detail); + rep_INTERN (count); + rep_INTERN (message_type); + rep_INTERN (format); + rep_INTERN (data); + rep_INTERN (above); + rep_INTERN (value_mask); + rep_INTERN (raise_lowest); + rep_INTERN (lower_highest); rep_INTERN (LineSolid); rep_INTERN (LineOnOffDash); merlin-1.3.1/x-util.jl0000644000175000017500000001124407472223527016223 0ustar marillatmarillat00000000000000;; merlin/x-util.jl -- some x utilities ;; version -0.4 ;; Copyright (C) 2000-2001 merlin ;; http://merlin.org/sawfish/ ;; this is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; this is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;; TODO: x-get-wm-size-hints etc. (define-structure merlin.x-util (export x-map-fn x-configure-fn x-set-wm-name x-set-wm-icon-name x-set-wm-class x-set-wm-protocols x-set-wm-size-hints x-set-transient-for-hint any-window-id move-window-unconstrained move-window-initial-pointer-offset) (open rep rep.system sawfish.wm.misc sawfish.wm.util.x merlin.util) (define (x-map-fn) (if (wm-initialized) x-map-request x-x-map-window)) (define (x-configure-fn) (if (wm-initialized) x-configure-request x-configure-window)) (define (x-set-wm-name w name) (x-set-text-property w (vector name) 'WM_NAME)) (define (x-set-wm-icon-name w name) (x-set-text-property w (vector name) 'WM_ICON_NAME)) (define (x-set-wm-class w name class) (x-set-text-property w (vector name class) 'WM_CLASS)) (define protocol-map `((delete-window . WM_DELETE_WINDOW))) (define (x-set-wm-protocols w protocols) (let* ((mapper (lambda (protocol) (cdr (assq protocol protocol-map)))) (mapped (delete-if not (mapcar mapper protocols))) (atoms (mapcar x-atom mapped))) (x-change-property w 'WM_PROTOCOLS 'ATOM 32 'prop-mode-replace (apply vector atoms)))) (define gravities '(forget north-west north north-east west center east south-west south south-east static)) (define (x-set-wm-size-hints w #!optional min maxx inc aspect base gravity) (let* ((flags (+ 0 (if min 16 0) (if maxx 32 0) (if inc 64 0) (if aspect 128 0) (if base 256 0) (if gravity 512 0))) (grav (max 0 (index-of gravity gravities))) (values (apply append (mapcar (lambda (x) (cond ((consp x) (list (car x) (cdr x))) ((integerp x) (list x)) (t (list 0 0)))) (list nil nil min maxx inc (car aspect) (cdr aspect) base grav))))) (x-change-property w 'WM_NORMAL_HINTS 'WM_SIZE_HINTS 32 'prop-mode-replace (apply vector flags values)))) (define (any-window-id window) (cond ((integerp window) window) ((windowp window) (window-id window)) ((x-window-p window) (x-window-id window)) (t (error "unknown window type: %s" window)))) (define (x-set-transient-for-hint w parent) (if (null parent) (x-delete-property w 'WM_TRANSIENT_FOR) (x-change-property w 'WM_TRANSIENT_FOR 'WINDOW 32 'prop-mode-replace (vector (any-window-id parent))))) (defvar move-window-preprocessed nil) ;; private (defvar move-window-unconstrained nil) ;; allow move resize beyond screen bounds (defvar move-window-initial-pointer-offset nil) ;; set/get initial pointer offset in window (add-hook 'after-move-hook (lambda (w dirs) (setq move-window-preprocessed nil) (setq move-window-unconstrained nil) (setq move-window-initial-pointer-offset nil))) (eval-in `(let ((old-update-edges update-edges) (old-apply-changes apply-changes)) (define (update-edges) (unless move-window-preprocessed (if move-window-initial-pointer-offset (setq move-resize-last-ptr (cons (+ (car move-window-initial-pointer-offset) move-resize-old-x) (+ (cdr move-window-initial-pointer-offset) move-resize-old-y)) move-resize-old-ptr-x (car move-resize-last-ptr) move-resize-old-ptr-y (cdr move-resize-last-ptr)) (setq move-window-initial-pointer-offset (cons (- (car move-resize-last-ptr) move-resize-old-x) (- (cdr move-resize-last-ptr) move-resize-old-y)))) (setq move-window-preprocessed t)) (old-update-edges)) (define (apply-changes) (if move-window-unconstrained (move-resize-window-to move-resize-window move-resize-x move-resize-y move-resize-width move-resize-height) (old-apply-changes)))) 'sawfish.wm.commands.move-resize) ) merlin-1.3.1/wmresize.jl0000644000175000017500000001444507426011654016647 0ustar marillatmarillat00000000000000;; contrib/wmresize.jl -- wm-like resize/move boxes ;; version 0.1 ;; Copyright (C) 2002 Jindrich Makovicka ;; http://merlin.org/sawfish/ ;; This is free software; you can redistribute it and/or modify it ;; under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; This is distributed in the hope that it will be useful, but ;; WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with sawfish; see the file COPYING. If not, write to ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. ;;;;;;;;;;;;;;;;;; ;; INSTALLATION ;; ;;;;;;;;;;;;;;;;;; ;; Create a directory ~/.sawfish/lisp/contrib and then put this file there: ;; mkdir -p ~/.sawfish/lisp/contrib ;; mv wmresize.jl ~/.sawfish/lisp/contrib ;; Then add to your .sawfishrc: ;; (require 'contrib.wmresize) ;; Then restart sawfish and go to Customize->Move/Resize and select ;; the dimension animation mode. ;; The appearance of the animation mode can be customized under ;; Customize->Move/Resize->Ugliness. (define-structure contrib.wmresize (export) (open rep rep.system sawfish.wm sawfish.wm.custom sawfish.wm.util.x sawfish.wm.util.window-outline) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; move-resize basic ugliness settings ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgroup move-ugliness "Ugliness" :group move) (defcustom ugly-move-resize-dim-font default-font "Font for move/resize dimension marks." :type font :group (move move-ugliness)) (defcustom ugly-dim-text-shift 0 "Y-axis position correction for dimension text." :type number :range (-100 . 100) :group (move move-ugliness)) (defcustom ugly-dim-offset 3 "Dimension offset." :type number :range (0 . 100) :group (move move-ugliness)) (defcustom ugly-dim-width 16 "Dimension width." :type number :range (0 . 100) :group (move move-ugliness)) (defcustom ugly-dim-arrow-size (cons 4 8) "Dimension arrow size." :type (pair (labelled "Width:" (number 0 100)) (labelled "Length:" (number 0 100))) :group (move move-ugliness)) (if (not (memq 'dimension (custom-get-options 'move-outline-mode))) (custom-add-option 'move-outline-mode 'dimension)) (if (not (memq 'dimension (custom-get-options 'resize-outline-mode))) (custom-add-option 'resize-outline-mode 'dimension)) (define (draw-dim-outline x y width height) (require 'sawfish.wm.util.x) (require 'sawfish.wm.fonts) (let ((gc (x-create-root-xor-gc)) (wtext (format nil "%d" width)) (htext (format nil "%d" height)) (htwidth) (wtwidth) (dim) (halfdim) (off ugly-dim-offset) (halfdimoff) (w-orig-y) (h-orig-x) (arrw (car ugly-dim-arrow-size)) (arrl (cdr ugly-dim-arrow-size)) (fheight (font-height ugly-move-resize-dim-font)) ) (x-draw-rectangle 'root gc (cons x y) (cons width height)) (setq wtwidth (text-width wtext ugly-move-resize-dim-font)) (setq htwidth (text-width htext ugly-move-resize-dim-font)) (setq dim ugly-dim-width) (setq halfdim (round (/ dim 2))) (setq halfdimoff (+ halfdim off)) ;; check where to draw (top/bottom, left/right) (if (> (+ dim off) y) (setq w-orig-y (+ y height dim (* off 2))) (setq w-orig-y y) ) (if (> (+ dim off) x) (setq h-orig-x (+ x width dim (* off 2))) (setq h-orig-x x) ) ;; horizontal dimension (if (or (> (+ wtwidth 2 (* arrl 2)) width) (> w-orig-y (screen-height))) (setq wtwidth 0) (x-draw-line 'root gc (cons x (- w-orig-y off)) (cons x (- w-orig-y off dim)) ) (x-draw-line 'root gc (cons (+ x width -1) (- w-orig-y off)) (cons (+ x width -1) (- w-orig-y off dim)) ) (x-draw-string 'root gc (cons (round (+ x (- (/ width 2) (/ wtwidth 2)))) (round (+ (- w-orig-y halfdimoff) (/ fheight 2) ugly-dim-text-shift))) wtext ugly-move-resize-dim-font) (x-draw-line 'root gc (cons x (- w-orig-y halfdimoff)) (cons (round (+ x (- (/ width 2) (/ wtwidth 2) 2) ) ) (- w-orig-y halfdimoff) ) ) (x-draw-line 'root gc (cons (round (+ x (+ (/ width 2) (/ wtwidth 2) 2 ) ) ) (- w-orig-y halfdimoff) ) (cons (+ x width) (- w-orig-y halfdimoff)) ) (x-draw-line 'root gc (cons (+ x arrl) (- w-orig-y (+ halfdimoff arrw))) (cons x (- w-orig-y halfdimoff))) (x-draw-line 'root gc (cons (+ x arrl) (- w-orig-y (- halfdimoff arrw))) (cons x (- w-orig-y halfdimoff))) (x-draw-line 'root gc (cons (- (+ x width) arrl) (- w-orig-y (+ halfdimoff arrw))) (cons (+ x width) (- w-orig-y (+ halfdim off)))) (x-draw-line 'root gc (cons (- (+ x width) arrl) (- w-orig-y (- halfdimoff arrw))) (cons (+ x width) (- w-orig-y halfdimoff))) ) ;; vertical dimension (if (or (> (+ fheight 2 (* arrl 2)) height) (> h-orig-x (screen-width))) (setq fheight 0) (x-draw-line 'root gc (cons (- h-orig-x off dim) y) (cons (- h-orig-x off) y) ) (x-draw-line 'root gc (cons (- h-orig-x off dim) (+ y height)) (cons (- h-orig-x off) (+ y height)) ) (x-draw-string 'root gc (cons (round (- h-orig-x (/ htwidth 2) halfdimoff)) (round (+ y (/ height 2) (/ fheight 2) ugly-dim-text-shift))) htext ugly-move-resize-dim-font) (x-draw-line 'root gc (cons (- h-orig-x halfdimoff) y) (cons (- h-orig-x halfdimoff) (round (+ y (- (/ height 2) (/ fheight 2) 2 ) ) ) ) ) (x-draw-line 'root gc (cons (- h-orig-x halfdimoff) (round (+ y (+ (/ height 2) (/ fheight 2) 2 ) ) ) ) (cons (- h-orig-x halfdimoff) (+ y height)) ) (x-draw-line 'root gc (cons (- h-orig-x (+ halfdimoff arrw)) (+ y arrl)) (cons (- h-orig-x halfdimoff) y)) (x-draw-line 'root gc (cons (- h-orig-x (- halfdimoff arrw)) (+ y arrl)) (cons (- h-orig-x halfdimoff) y)) (x-draw-line 'root gc (cons (- h-orig-x (+ halfdimoff arrw)) (- (+ y height) arrl)) (cons (- h-orig-x halfdimoff) (+ y height))) (x-draw-line 'root gc (cons (- h-orig-x (- halfdimoff arrw)) (- (+ y height) arrl)) (cons (- h-orig-x halfdimoff) (+ y height))) ) (x-destroy-gc gc))) (define-window-outliner 'dimension draw-dim-outline))