;; load-virtual.gwm --- Install and setup use of virtual.gwm & co.
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1995  Anders Holst
;; Version: virtual-1.0
;; Last change: 17/6 1995
;;
;; This file is copyrighted under the same terms as the rest of GWM
;; (see the X Inc license for details). There is no warranty that it
;; works. 
;;
;; --------------------------------------------------------------------- 
;;
;; This file is intended for use with *other* profiles than VTWM. 
;; It sets up the necessary things to use the virtual screen from 
;; "virtual.gwm", and also loads "virtual-door.gwm" and "virtual-pan.gwm".
;;
;; Load it from somewhere at the end of your *rc.gwm. 
;;


;; First some necessary functions
(if (not (boundp 'defname-in-screen))
    (defunq defname-in-screen args
      (for var args
           (defname var screen.)))
)
(if (not (boundp 'black)) (: black (color-make "Black")))
(if (not (boundp 'white)) (: white (color-make "White")))
(if (or (not (boundp 'defaults-to))
        (not (boundp 'declare-screen-dependent)))
    (load "utils"))

;;
;;  Some reasonable user defaults.
;;  ------------------------------
;;  Change these in your own profile. Also check the three files "virtual.gwm",
;;  "virtual-door.gwm" and "virtual-pan.gwm" for more customization variables.
;;  
(defaults-to
  virtual-xpos 6
  virtual-ypos 6
  virtual-nailed-list '(XLoad XClock XBiff XConsole Gwm)
  virtual-omit-list '(XLoad XClock XBiff Gwm)
  virtual-omit-nailed () 

  door-mgr-xpos 174
  door-mgr-ypos 4

  show-pan-lists t
)
(declare-screen-dependent virtual-fancy-colors)
(for screen (list-of-screens)
  (if (= screen-type 'color)
      (progn 
        (defaults-to virtual-fancy-colors 
          (list (list () (color-make "lightgray"))
                (list 'XTerm () (color-make "lightskyblue"))
                (list 'Emacs () (color-make "lightpink"))
                (list t () (color-make "lightyellow")))
          ))))

;;----------------------------------------------------------------------------

(defunq add-hook (hook expr)
  (if (not (boundp hook))
        (set hook expr)
      (= (# 0 (eval hook)) 'progn)
        (set hook (+ (eval hook) (list expr)))
        (set hook (+ '(progn) (list (eval hook)) (list expr)))))

(add-hook opening (virtual-add))

(add-hook closing (virtual-remove))

(add-hook screen-opening (virtual-show))
(add-hook screen-opening (door-add-initial))
(add-hook screen-opening (if show-pan-lists (install-pan-lists)))

(add-hook screen-closing (virtual-move-home))


(if (not (boundp 'raise-window-orig))
    (progn

      (: raise-window-orig raise-window)

      (defun raise-window arg
        (if arg
            (raise-window-orig (# 0 arg))
          (raise-window-orig))
        (virtual-update))
))

(if (not (boundp 'lower-window-orig))
    (progn

      (: lower-window-orig lower-window)

      (defun lower-window arg
        (if arg
            (lower-window-orig (# 0 arg))
          (lower-window-orig))
        (virtual-update))
))

(if (not (boundp 'move-window-orig))
    (progn

      (: move-window-orig move-window)

      (defun move-window args
        (if args
            (eval (+ (list 'move-window-orig) args))
          (move-window-orig))
        (if (window-is-mapped)
            (virtual-update)))
))

(if (not (boundp 'resize-window-orig))
    (progn

      (: resize-window-orig resize-window)

      (defun resize-window args
        (if args
            (eval (+ (list 'resize-window-orig) args))
          (resize-window-orig))
        (if (window-is-mapped)
            (virtual-update)))
))

(if (not (boundp 'iconify-window-orig))
    (progn

      (: iconify-window-orig iconify-window)

      (defun iconify-window ()
        (iconify-window-orig)
        (virtual-update))
))


(load "virtual")
(load "virtual-door")
(load "virtual-pan")

;; Sorry, have to do this to make doors work properly in the MWM-profile.
(if (boundp 'tooClose)
    (setq tooClose 0))

; "Normal" profiles
(if (boundp 'root-behavior)
    (progn
      (setq root-behavior (state-make root-behavior (virtual-behavior)))
      (setq root-fsm (fsm-make root-behavior))))
; Special for MWM-profile
(if (and (boundp 'root-std-behavior)
         (boundp 'do-bindings-state)
         (boundp 'keyBindings))
    (progn
      (setq root-std-behavior (state-make root-std-behavior (virtual-behavior)))
      (setq root-fsm (fsm-make (state-make
                (do-bindings-state '(root))
                (# 0 (# 'root keyBindings))
                root-std-behavior)))))
; Install new behavior
(with (wob root-window)
  (if (boundp 'root-fsm) (wob-fsm root-fsm))
  (eval (+ '(set-grabs) (virtual-grabs))))