scsh-conservatory
/
orion-wm
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

- replaced client icons with a pager for move-wm

This commit is contained in:
frese 2005-01-16 17:22:33 +00:00
parent f26844397b
commit d06743740e
1 changed files with 0 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
src/move-wm-icon.scm
View File

@ -1,86 +0,0 @@
(define-record-type icon :icon
(make-icon wm client window)
icon?
(wm icon:wm)
(client icon:client)
(window icon:window))
(define (create-icon wm client rect)
(let* ((dpy (wm:dpy wm))
(window (create-simple-window dpy (wm:window wm)
(rectangle:x rect) (rectangle:y rect)
(rectangle:width rect)
(rectangle:height rect)
0
(black-pixel dpy) (white-pixel dpy)))
(gc (create-gc dpy window
(make-gc-value-alist
(foreground (black-pixel dpy))
(background (white-pixel dpy))))))
(spawn*
(list 'move-wm-icon wm client window)
(lambda (release)
(call-with-current-continuation
(lambda (exit)
(call-with-event-channel
dpy window (event-mask exposure
structure-notify
button-press)
(lambda (event-channel)
(release)
(let loop ()
(let ((xevent (receive event-channel)))
(cond
((destroy-window-event? xevent) (exit 'destroyed))
((expose-event? xevent)
(if (= 0 (expose-event-count xevent))
(draw-icon dpy window gc client)))
((and (button-event? xevent)
(eq? (event-type button-press)
(button-event-type xevent)))
(send (wm:internal-out-channel wm)
(list 'normalize-client client))
(exit 'normalized)))
(loop)))))))
(free-gc dpy gc)))
(make-icon wm client window)))
(define (map-icon icon)
(map-window (wm:dpy (icon:wm icon)) (icon:window icon)))
(define (destroy-icon icon)
(destroy-window (wm:dpy (icon:wm icon)) (icon:window icon)))
(define (draw-icon dpy window gc client)
(let ((title (client-name dpy client)) ;; or WM_ICON_NAME ??
(r (clip-rectangle dpy window)))
(draw-image-string dpy window gc 2 14 title)))
(define (find-icon-rect wm-rect icons)
(let* ((icon-w 200)
(icon-h 18)
(xs (iota (quotient (rectangle:width wm-rect) icon-w)))
(ys (reverse (iota (quotient (rectangle:height wm-rect) icon-h))))
(all (flatten (map (lambda (yi)
(map (lambda (xi)
(make-rectangle (* xi icon-w)
(* yi icon-h)
icon-w icon-h))
xs))
ys)))
(icon-rects (map (lambda (i)
(window-rectangle (wm:dpy (icon:wm i))
(icon:window i)))
icons))
(free (filter (lambda (r)
(not (any (lambda (ir)
(rectangles-overlap? r ir))
icon-rects)))
all)))
(if (null? free)
(if (null? all)
(make-rectangle 0 0 icon-w icon-h)
(car all))
(car free))))