;; up-door.gwm
;; Contributed by Ulrich Pfeifer
;;
;; I'll append some functions I currently use with virtual doors.  A
;; problem is that the menus are not updated if you add doos later.
;; Maybe add-door and remove door should call hook's? The other know
;; problem is that moving windows to some room automatically (this way)
;; works only if gwm is running before the application starts.

;; Example code to put in .profile.gwm
;
;(set-icon-placement any rows.right-top.placement) ; place most icons on right
;
;; Place the NNML server window always to room 'Mail'
;(set-placement XTerm.xterm.NNML
;               '(lambda (foo) (up-door-place "Mail")))
;; Place all Emacs windows in the current room at the standard posistion
;; Resize to 'A4'
;(set-placement Emacs.emacs
;               '(lambda (foo) (up-door-place ()) (up-door-a4)))
;; Place all Netscape windows in room "WWW" at the standard posistion
;; Resize to 'A4' size
;(set-placement Netscape.Navigator
;               (lambda (foo) (up-door-place "WWW") (up-door-a4)))

;; List of x-positions to use next for all virtual rooms
(setq up-door-x-pos ())

;; Get the next x-position for room nr
(defun up-door-next-xpos (nr)
  (with (pos (or (# nr up-door-x-pos) 0))
        (setq up-door-x-pos
              (# nr up-door-x-pos (+ 30 pos)))
        pos))

;; List the names of all virtual doors
(defun up-door-list ()
  (mapfor desc std-virtual.doors (# 0 desc)))

;; Find the name of the current room
(defun up-current-door ()
  (with (current-door ())
        (for door (up-door-list)
             (if (= (door-virt-coord (door-find-name door)) 
                    (mapfor i virt-pos (- 0 i)))
                 (setq current-door door)))
        current-door))

;; Place window in room named door to next position (n*30,0)
(defun up-door-place (door)
  (with (nr (door-find-name (or door (up-current-door)))
            vp (if nr (door-virt-coord nr) '(0 0))
            x  (+ (# 0 vp) (up-door-next-xpos nr) (# 0 virt-pos))
            y  (+ (# 1 vp) (# 1 virt-pos)))
        (move-window x y)))

;; Resize window to full screen height.
;; Choose width so that the window looks like an a4 paper
(defun up-door-a4 ()
  (resize-window (/ (* screen-height 46) 59) screen-height)) ; !42

;; Move current window to room named door. Don't change virtual position
(defun up-move-to-door (door)
  (with (nr (door-find-name door)
            vp (door-virt-coord nr)
            x  (+ window-x (# 0 vp) (# 0 virt-pos))
            y  (+ window-y (# 1 vp) (# 1 virt-pos)))
        ;(? "moveto " x "," y "\n")
        (move-window x y)))

;; Emergency: move all windows to current room
(defun up-map-all ()
  (for window (list-of-windows 'window)
       (with (x window-x
              y window-y)
             (while (< x 0)
               (setq x (+ x screen-width)))
             (while (> x (- screen-width 1))
               (setq x (- x screen-width)))
             (while (< y 0)
               (setq y (+ y screen-height)))
             (while (> y (- screen-height 1))
               (setq y (- y screen-height)))
             (move-window x y)
             (map-window)
             (raise-window)
             )))

;; One row of doors
;;(insert-at (+ (list 'multi-item-make "Door" ())
;;              (mapfor door (up-door-list)
;;                      (list door (list 'up-move-to-door door))))
;;           window-pop-items
;;           6 ; std-virtual.windowmenupos
;;           )

;; Split the door list in two parts so that the menu will not too wide
(with (door-list (up-door-list)
       half      (/ (length door-list) 2)
       left      (sublist 0  half door-list)
       right     (sublist half (length door-list) door-list))
      (insert-at (+ (list 'multi-item-make "Move" ())
                    (mapfor door left
                            (list door (list 'up-move-to-door door))))
                 window-pop-items 6)
      (insert-at (+ (list 'multi-item-make "Door" ())
                    (mapfor door right
                            (list door (list 'up-move-to-door door))))
                 window-pop-items 7
                 ))
(insert-at 
  '(item-make
    "Map all" (up-map-all)
    )
  root-pop-items
  11
  )