;; William Burdick's attempt at icon groups/rooms
;; The idea is like dvrooms, except that a room is a bar of buttons
;;=============================================================================
;; Date: Thu, 01 Jul 1993 00:08:26 EST
;; From: William R Burdick <burdick@ecn.purdue.edu>
;; 
;; I'm not sure whether the way I did things was totally correct
;; (particularly the justifying of menu items and the user event
;; handling), so please look over the code, if you have time.  I also
;; messed around with the standard menus and their behavior near the end
;; of the file.  Some things I did may not be done right.
;; 
;; I had a little time to clean up this thing, but not too much, so some
;; of my original hacks may still be around.  Let me know if you have any
;; questions or if you have better ways to do some things.  In
;; particular, I learned about user-events halfway through this project.
;; I might have been able to do some of the earlier things better with
;; user-events.  I like user-events, by the way -- they're like message
;; passing in OO languages.
;; 
;; 	-- Bill Burdick
;; 	burdick@octopus.ecn.purdue.edu
;; 
;; A few explanations...
;; 
;; (load 'wbrooms)
;; 	put this in your .profile.gwm after the standard behaviors are
;; 	reparsed (just like with dvrooms)
;; 
;; (wb-add-to-named-room "roomName.barName")
;; 	adds a window to a room.  This implicitly creates the
;; 	room and bar if they are not already there.
;; 
;; (wb-find-room "roomName" "barName")
;; 	gets a room by name
;; 
;; (wb-add-to-room room)
;; 	adds a window to a room when you already have the room
;; 
;; (wb-make-named-room "roomName.barName")
;; 	makes a room (and a bar if that bar doesn't exist, yet).
;; 
;; (wb-reattach)
;; 	reattaches all windows to their rooms
;; 
;; wbroom.background.name (it's a string)
;; 	the name of a 4-shade color (like Thistle or RosyBrown)
;; 	for the background color of room bars
;; 
;; New rooms are added to the right side of their bar.
;;=============================================================================
;;
;; objects
;; type: room-bar
;;	a menu with a bar in it containing rooms
;; property: name
;;	the name of the room-bar
;; property: rooms
;;	a list of the rooms in the room-bar
;; property: plugs
;;	a list of the room plugs in the room-bar
;;
;; type: room
;;	a plug
;; property: name
;;	the name of the room-bar
;; property: members
;;	the windows in the room
;; property: closed
;;	the pixmap for the picture displayed when the room is closed
;; property: open
;;	the pixmap for the picture displayed when the room is open
;; property: openp
;;	whether the room is open


;; variables
(defaults-to
  wbroom.horizontal-margin 5
  wbroom.vertical-margin 5
  wbroom.font (font-make "8x13")
  wbroom.background.name "RosyBrown"	; this color should be a 4-shade color
; wbroom.background.name "DodgerBlue"
  wbroom.foreground black
  wbroom.borderwidth borderwidth
  wbroom.current ()
  wbroom.loaded ()
  wbroom.room-bars ()
  wbroom.x 0
  wbroom.y 0
  wbroom.item-height ()
  wbroom.item-width ()
  wbroom.menu-item.background.name "NavajoWhite"
  wbroom.menu-label.background.name "goldenrod"
)


;(with (m (menu-wob tools-pop) menu-width (width m)) (? "send\n") (send-user-event 'expand m))
;wb-simple-label-make
;	make a simple label with name centered in pixmap
(defun wb-simple-label-make (name wd ht fnt)
  (with (l (if (and wd ht)
	       (with (l (label-make name fnt)
			w (width l)
			h (height l)
			pix (pixmap-make wd ht))
		     (draw-rectangle pix 0 0 wd ht 0 2)
		     (draw-text pix
				wbroom.horizontal-margin ;(/ (- wd w) 2))
				12
				fnt
				name)
		     pix)
	     (label-make name fnt)))
	l))


(defun wb-draw-borders (p1 p2 c1 c2 x y w h)
  (with (w-1 (- w 1)
	 h-1 (- h 1)
	 x+1 (+ x 1)
	 y+1 (+ y 1))
	(setq foreground c1)
	(draw-line p1 x y w y)
	(draw-line p1 x+1 y+1 w-1 1)
	(draw-line p1 x y x h)
	(draw-line p1 x+1 y+1 x+1 h-1)
	(draw-line p2 w h w y)
	(draw-line p2 w-1 h-1 w-1 y+1)
	(draw-line p2 w h x h)
	(draw-line p2 w-1 h-1 x+1 h-1)
	(setq foreground c2)
	(draw-line p1 w h w y)
	(draw-line p1 w-1 h-1 w-1 y+1)
	(draw-line p1 w h x h)
	(draw-line p1 w-1 h-1 x+1 h-1)
	(draw-line p2 x y w y)
	(draw-line p2 x+1 x+1 w-1 x+1)
	(draw-line p2 x y x h)
	(draw-line p2 x+1 y+1 x+1 h-1)))
  


;wb-labels-make
;	makes two 2.5d pixmaps for name (on off)
(defun wb-labels-make (name wd ht fnt)
  (with (label-horizontal-margin wbroom.horizontal-margin
	 label-vertical-margin wbroom.vertical-margin
	 borderwidth 0
	 foreground black
	 background (color-make (+ wbroom.background.name "2"))
	 offpix (wb-simple-label-make name wd ht fnt)
	 background (color-make (+ wbroom.background.name "3"))
	 onpix (wb-simple-label-make name wd ht fnt))
	 (wb-draw-borders offpix onpix (color-make (+ wbroom.background.name "1")) (color-make (+ wbroom.background.name "4")) 0 0 (- (width onpix) 1) (- (height onpix) 1))
	(list offpix onpix)))

; wb-plug-make
;	makes a 2.5d plug
;	properties of plug on return:
;		on: on pixmap
;		off: off pixmap
;		name: name given to wb-plug-make
(defun wb-plug-make args
  (with (name (# 0 args)
	 wd (# 1 args)
	 ht (# 2 args)
	 font wbroom.font
	 pix (wb-labels-make name wd ht font)
	 offpix (# 0 pix)
	 onpix (# 1 pix)
	 property (+ (list 'off offpix
			   'on onpix
			   'name name) property))
	(plug-make offpix)))


; wb-make-room
;	makes a room
(defun wb-make-room (name)
  (with (property (+ (list 'members ()
			   'openp t
			   'registered ())
		     property)
	 borderwidth 0
	 fsm (fsm-make
	      (state-make (on map-notify (wb-register-room) open))
	      (: open (state-make
		     (on (user-event 'raise) (wb-raise-room))
		     (on (user-event 'lower) (wb-lower-room))
		     (on (user-event 'disable) (wb-disable) disabled-open)
		     (on (buttonpress 1 any) (wb-raise-room))
		     (on (buttonpress 2 any) (wb-close-room) closed)
		     (on (buttonpress 3 any) (wb-lower-room))))
	      (: closed (state-make
 		     (on (user-event 'disable) (wb-disable) disabled-closed)
		     (on (buttonpress 2 any) (wb-open-room) open)))
	      (: disabled-open (state-make
		     (on (user-event 'enable) (wb-enable) open)))
	      (: disabled-closed (state-make
		     (on (user-event 'enable) (wb-enable) closed)))))
	(wb-plug-make name)))


; wb-make-room-control
;	makes a room control
(defun wb-make-room-control ()
  (with (borderwidth 0
	 fsm (fsm-make
	      (: s2 (state-make
		     (on (buttonpress 1 any) (wb-raise-rooms))
		     (on (buttonpress 2 any) (wb-close-rooms) s1)
		     (on (buttonpress 3 any) (wb-lower-rooms))))
	      (: s1 (state-make (on (buttonpress 2 any) (wb-open-rooms) s2))))
	 label-horizontal-margin wbroom.horizontal-margin
	 label-vertical-margin wbroom.vertical-margin
	 background (color-make (+ wbroom.background.name "2"))
	 font wbroom.font
	 offpix (label-make " ")
	 background (color-make (+ wbroom.background.name "3"))
	 onpix (label-make " ")
	 property (+ (list 'off offpix
			   'on onpix
			   'openp t)
		     property))
	(wb-draw-borders offpix onpix (color-make (+ wbroom.background.name "1")) (color-make (+ wbroom.background.name "4")) 0 0 (- (width onpix) 1) (- (height onpix) 1))
	(wb-draw-borders offpix onpix (color-make (+ wbroom.background.name "1")) (color-make (+ wbroom.background.name "4")) 4 4 (- (width onpix) 5) (- (height onpix) 5))
	(plug-make offpix)))


; wb-is-room-bar
;	returns whether wob is a room-bar
(defun wb-is-room-bar (obj)
  (member obj wbroom.room-bars))


; wb-register-room
;	register room in menu
(defun wb-register-room ()
  (if (not (# 'registered wob))
      (progn
	(## 'registered wob t)
	(wb-set-bar-rooms window (+ (wb-bar-rooms window) (list wob))))))


; wb-room-members
;	returns all the members of a room
(defun wb-room-members (room)
  (# 'members room))


; wb-set-room-members
;	returns all the members of a room
(defun wb-set-room-members (room mems)
  (## 'members room mems))


; wb-bar-members
;	returns all the members of a bar
(defun wb-bar-members (bar)
  (: mems ())
  (for room (# 'rooms bar)
       (: mems (+ mems (# 'members room))))
  mems)


; wb-bar-rooms
;	returns the rooms in a room-bar
(defun wb-bar-rooms (bar)
  (# 'rooms bar))


; wb-set-bar-rooms
;	sets the rooms in a bar
(defun wb-set-bar-rooms (bar rooms)
  (## 'rooms bar rooms))


;wb-enable
(defun wb-enable ()
  (if (# 'openp wob)
      (wb-open-room)))


;wb-disable
(defun wb-disable ()
  (with (oldwob wob)
	(if (# 'openp oldwob)
	    (progn
	      (wb-close-room)
	      (## 'openp oldwob t)))))


; wb-open-room
;	map all the windows in the room
(defun wb-open-room ()
  (with (oldwob wob
	 wob wob)
	(wob-tile (# 'off oldwob))
	(## 'openp oldwob t)
	(wb-map-wins (wb-room-members oldwob))
	(: wbroom.current wob)))


; wb-map-room-members
;	map each member of the room
(defun wb-map-wins (wins)
  (for window wins
       (if (# 'wbroom-state window)
	   (wb-map-window window)
	 (map-window window-icon)))
  (wb-raise-wins wins))



; wb-close-room
;	unmap all the windows in the room
(defun wb-close-room ()
  (wob-tile (# 'on wob))
  (## 'openp wob ())
  (: wbroom.current wob)
  (wb-unmap-wins (wb-room-members wob)))



; wb-unmap-room-members
;	map each member of the room
(defun wb-unmap-wins (wins)
  (for window wins
       (## 'wbroom-state window window-is-mapped)
       (if window-is-mapped (wb-unmap-window window))
       (if (window-icon?)
	   (with (window window-icon)
		 (if  window-is-mapped (unmap-window window))))))


; wb-add-to-room
;	add this window to a room
(defun wb-add-to-room (room)
  (if (not (member window (wb-room-members room)))
      (with (win window
	     wob room)
	    (wb-set-room-members room (+ (wb-room-members room) (list win)))
	    (## 'wbroom-state window window-is-mapped)
	    (with (bar window
		   window win)
		  (set-x-property "GWM_WBROOM"
				  (+ (# 'name room)
				     "."
				     (# 'name bar)))))))


; wb-remove-from-room
;	remove this window from the room
(defun wb-remove-from-room (room)
  (with (pos (member window (wb-room-members room)))
	(if pos (delete-nth pos (wb-room-members room)))))


; wb-add-room-to-bar
;	adds a room to a room-bar
(defun wb-add-room-to-bar (room bar)
  (## 'plugs bar (+ (# 'plugs bar) (list room)))
  (wb-set-bar-rooms bar ())
  (with (plug-separator 1
	 borderwidth 0
	 newb (menu-make (eval (+ '(bar-make) (list (wb-make-room-control)) (# 'plugs bar))))
	 x (with (wob bar) window-x)
	 y (with (wob bar) window-y)
	 property (with (wob bar) wob-property)
	 newbar (place-menu "wbroombar" newb x y))
	(## (member bar wbroom.room-bars) wbroom.room-bars newbar)
	(with (wob bar)
	      (delete-window))))
	      
	 
; wb-add-room-to-named-bar
;	makes a room-bar containing only this room or adds the room
;	to the existing room-bar
(defun wb-add-room-to-named-bar (room name)
  (: b (wb-find-room-bar name))
  (if b (wb-add-room-to-bar room b)
    (with (borderwidth 0
	   b (menu-make (bar-make (wb-make-room-control) room))
	   property (+ (list 'name name
			     'plugs (list room)
			     'rooms ())
		       property)
	   bar (place-menu "wbroombar" b wbroom.x wbroom.y))
	  (: wbroom.room-bars (+ wbroom.room-bars (list bar))))))


(defun wb-add-named-room-to-named-bar (rname bname)
  (wb-add-room-to-named-bar (wb-make-room rname) bname))


; wb-find-room-bar
;	gets the room bar named name
(defun wb-find-room-bar (name)
  (with (ret ())
	(for b wbroom.room-bars
	     (if (= (# 'name b) name) (: ret b)))
	ret))


; wb-find-room
;	finds a room in a bar
(defun wb-find-room (rname bname)
  (with (bar (wb-find-room-bar bname)
	 ret ())
	(for r (wb-bar-rooms bar)
	     (if (= (# 'name r) rname) (: ret r)))
	ret))
	

; wb-flush-rooms
;	removes a window from all the rooms
;	add wb-flush-rooms to the global closing code
;	wbrooms should be loaded before the set-{window,icon} calls
;	in .profile.gwm
(if (not wbroom.loaded)
    (progn
      (: wbroom.loaded t)
      (: closing (+ closing '((wb-flush-rooms))))))
(defun wb-flush-rooms ()
  (for bar wbroom.room-bars
       (for room (wb-bar-rooms bar)
	    (if (member window (wb-room-members room))
		(wb-remove-from-room room))))
  (with (pos (member window wbroom.room-bars))
	(if pos
	    (progn
	      (wb-map-wins (wb-bar-members window))
	      (delete-nth pos wbroom.room-bars))))
  (: wbroom.current ()))


; wb-unmap-window
;	unmap a window and all of its members
(defun wb-unmap-window (win)
  (if (wb-is-room-bar win)
      (wb-unmap-wins (wb-bar-members win)))
  (unmap-window win))


; wb-map-window
;	map a window and all of its members
(defun wb-map-window (win)
  (if (wb-is-room-bar win)
      (for room (wb-bar-rooms win)
	   (if (# 'openp room)
	       (wb-map-wins (wb-bar-members win)))))
  (map-window win))


(if (not (boundp 'wb-previous-iconify-window))
    (setq wb-previous-iconify-window iconify-window))
(defun iconify-window ()
  (if (wb-is-room-bar window-window)
	; (de)iconifing a room bar
      (with (window window-window)
	    (: wbroom.current ())
	    (if window-is-mapped
		; iconifing (closing) a dvroom manager
		  (wb-unmap-wins (wb-bar-members window))
		; deiconifing (opening) a dvroom manager
		(for room (wb-bar-rooms window-window)
		     (if (# 'openp room)
			 (wb-map-wins (wb-room-members room)))))))
		; (de)iconifing other windows
  (wb-previous-iconify-window))


;wb-add-to-named-room
;	adds window to room named room.bar
(defun wb-add-to-named-room (name)
  (with (names (wb-get-room-and-bar name)
	 rname (# 0 names)
	 bname (# 1 names)
	 room (wb-find-room rname bname))
	(if room (wb-add-to-room room))))


(defun wb-make-named-room (name)
  (with (names (wb-get-room-and-bar name)
	 rname (# 0 names)
	 bname (# 1 names))
	(wb-add-named-room-to-named-bar rname bname)))

; wb-get-room-and-bar
;	returns list of room and bar names from string
(defun wb-get-room-and-bar (name)
  (list (match "\\([^.]*\\)" name 1)
	(match "\\.\\(.*\\)" name 1)))

(defun reverse (l)
  (: res (list-make (length l)))
  (: ind (length l))
  (for item l
    (: ind (- ind 1))
    (## ind res item))
  res)

(defun wb-reorder-wins (windows)
  (: wins ())
  (for w (list-of-windows 'stacking-order)
       (if (member w windows)
	   (: wins (+ wins (list w)))))
  wins)


;control functions
(defun wb-raise-rooms ()
  (send-user-event 'raise window))


(defun wb-lower-rooms ()
  (send-user-event 'lower window))


(defun wb-open-rooms ()
  (wob-tile (# 'off wob))
  (## 'openp wob t)
  (send-user-event 'enable window))


(defun wb-close-rooms ()
  (wob-tile (# 'on wob))
  (## 'openp wob ())
  (send-user-event 'disable window))


;room functions
(defun wb-raise-room ()
  (wb-raise-wins (wb-room-members wob)))

(defun wb-lower-room ()
  (wb-lower-wins (wb-room-members wob)))

(defun wb-raise-wins (wins)
  (with (w (wb-reorder-wins wins))
	(for window w
	     (if (and (member window wbroom.room-bars)
		      window-is-mapped)
		 (for room (wb-bar-rooms window)
		      (if (# 'openp window)
			  (wb-raise-wins (wb-room-members room))))
	       (with (window (if (window-is-mapped) window window-icon))
		     (raise-window))))))


(defun wb-lower-wins (wins)
  (with (w (wb-reorder-wins wins))
	(for window (reverse w)
	     (if (and (member window wbroom.room-bars)
		      window-is-mapped)
		 (for room (wb-bar-rooms window)
		      (if (# 'openp window)
			  (with (window room)
				(wb-lower-wins (wb-room-members room)))))
	       (with (window (if (window-is-mapped) window window-icon))
		     (lower-window))))))


(defun wb-reattach ()
  (for bar wbroom.room-bars
       (for room (wb-bar-rooms bar)
	    (wb-set-room-members room ())))
  (for window (list-of-windows)
       (with (window window-window
	      name (get-x-property "GWM_WBROOM"))
	     (if (< 0 (length name))
		 (progn
		   (wb-add-to-named-room name)
		   (if (and window-is-mapped
			    (not (# 'wbroom-state window)))
		       (unmap-window))
		   (if (and (not window-is-mapped)
			    (# 'wbroom-state window))
		       (map-window)))))))


(de menu-plug-make (label)
  (if (# (type label) string-types)
      (with (wbroom.horizontal-margin label-horizontal-margin
	     wbroom.vertical-margin label-vertical-margin)
	    (wb-plug-make label)); wbroom.item-width wbroom.item-height))
    
    (= 'pixmap (type label))
    (plug-make label)
    
    (= 'list (type label))
    (plug-make (eval label))
    
    (trigger-error "Bad menu item declaration")
    ))


(defun wb-popups-trigger (arg)
  (wb-wob-off)
  (std-popups.trigger arg))


(defun std-popups.trigger (multi)
  (with (calling-wob wob-parent
	 wob wob)
    (setq std-popups.action
      (# 'action wob-property))
    (wob wob-parent)
    (if multi (wob wob-parent))
    (send-user-event 'depop wob t)
    (eval std-popups.action)))



(setq std-popups.fsm
      (fsm-make 
       (: closed
	  (state-make 
	   (on (user-event 'expand)
	       (wb-expand-item))
	   (on enter-window (wb-wob-on) opened)
	   (on (buttonrelease any any) (std-popups.trigger ()))))
       (: opened
	  (state-make
	   (on (user-event 'expand)
	       (wb-expand-item))
	   (on (buttonrelease any any)
	       (wb-popups-trigger ())
	       closed)
	   (on enter-window (wb-wob-on))
	   (on leave-window (wb-wob-off))))))


;; fsm for multi-items (plugs in bar)
(setq std-popups.multi-fsm
      (fsm-make 
       (: closed 
	  (state-make 
	   (on enter-window (wb-wob-on) opened)
	   (on (buttonrelease any any) (std-popups.trigger t))))
       (: opened
	  (state-make
	   (on (buttonrelease any any)
	       (wb-popups-trigger t)
	       closed)
	   (on enter-window (wb-wob-on))
	   (on leave-window (wb-wob-off))))))


(df item-make (label action)
    (with (borderwidth 0
	   borderpixel pop-label.background
	   background pop-item.background
	   wbroom.background.name wbroom.menu-item.background.name
	   foreground pop-item.foreground
	   item (with (fsm std-popups.fsm
			   property (+ (list 'action action) property)
			   borderwidth 0
			   font pop-item.font
			   bar-min-width pop-item.height)
		      (menu-plug-make label))
	   property (+ (list 'item item) property))
	  (bar-make
	   ()
	   item
	   ())))

    
(de wb-wob-on ()
    (with (wob wob)
	  (if (# 'on wob)
	      (wob-tile (# 'on wob))
	    (progn
	      (wob-invert)))))


(de wb-wob-off ()
    (with (wob wob)
	  (if (# 'off wob)
	      (wob-tile (# 'off wob))
	    (wob-invert))))


(if (not (boundp 'old-menu-make-from-list))
    (: old-menu-make-from-list menu-make-from-list))
(de menu-make-from-list (l)
    (with (m (old-menu-make-from-list l)
	   menu-width (width (menu-wob m)))
	  (send-user-event 'expand (menu-wob m))
	  m))

(de wb-register-item ()
    (if (not (# 'registered wob))
	(progn
	  (## 'registered wob t)
	  (## 'wobs window (+ (# 'wobs window) (list wob))))))


(de wb-expand-wob ()
    (if (# 'name wob)
	(with (pix (wb-labels-make
		    (# 'name wob)
		    (- menu-width 2)
		    pop-item.height
		    wbroom.font))
	      (## 'off wob (# 0 pix))
	      (## 'on wob (# 1 pix))
	      (wb-wob-off))))


(df wb-expand-item ()
    (with (wbroom.background.name wbroom.menu-item.background.name)
	  (wb-expand-wob)))


(df wb-expand-label ()
    (with (wbroom.background.name wbroom.menu-label.background.name)
	  (wb-expand-wob)))


(df pop-label-make (label)
  (with (fsm (fsm-make (state-make
			(on (user-event 'expand)
			    (wb-expand-label))))
	 borderwidth 0
	 borderpixel pop-label.background
	 background pop-label.background
	 wbroom.background.name wbroom.menu-label.background.name
	 foreground pop-label.foreground) 
	(bar-make
	 (with (borderwidth 0 font pop-label.font) 
	       (menu-plug-make label)))))


(df multi-item-make list-of-buttons
  (with (
      wbroom.background.name wbroom.menu-item.background.name
      fsm ()
      borderwidth 0 borderpixel pop-label.background
      background pop-item.background
      foreground pop-item.foreground
    )		       
    (eval (+ '(bar-make)
	(with (
	    borderwidth 1
	    fsm std-popups.multi-fsm
	    font pop-item.font
	    bar-min-width pop-item.height
	  )
	  (mapfor button list-of-buttons
	    (if (and (= 'list (type button))
		(= (length button) 2))
	      (with (
		  label (# 0 button)
		  action (# 1 button)
		  property (+ (list 'action action) property)
		)
		(if label
		  (menu-plug-make label)))
	      (if button
		(with (fsm () borderwidth 0)
		  (menu-plug-make button)))
)))))))

;End of wbrooms.gwm