home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / std-virtual.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  5KB  |  173 lines
  1. ; Anders Hoslt virtual screen package loader for the standard profile
  2. ; ===================================================================
  3.  
  4. ;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
  5. ;;Revision: 1.0 -- June 28 1995
  6.  
  7. ;; A wrapper to use Anders very nice virtual screen package in the 
  8. ;; standard profile
  9. ;; see virtual.gwm and virtual-door.gwm for complete options
  10.  
  11. ;; here is an example of use in your .profile.gwm:
  12.  
  13. ;; (setq std-virtual.doors '(
  14. ;;     ("Home" screen-background)
  15. ;;     ("Comp" "LightBlue3")
  16. ;;     ("Mail" 
  17. ;;       (pixmap-make (color-make "seagreen3") "grainy" (color-make "seagreen2"))
  18. ;;       background (color-make "seagreen3"))    
  19. ;;     ("WWW" lightgrey door-icon (pixmap-load "netscape-small.xpm"))
  20. ;;     ("Text" "LightYellow3")
  21. ;;     ("Games" grey)
  22. ;; ))
  23. ;; 
  24. ;; (load "std-virtual.gwm")
  25.  
  26.  
  27. ;;=============================================================================
  28. ;;                    cosmetic changes, can be overriden before load
  29. ;;=============================================================================
  30.  
  31. (if (not (boundp 'frame3d-win)) (load "frame-win"))
  32. (set-window Gwm.menu.door-mgr frame3d-win)
  33. (set-window Gwm.menu.virtual frame3d-win)
  34.  
  35. (defvar door-borderwidth 1)
  36. (defvar show-virtual t)
  37. (defvar std-virtual.menupos 5)
  38. (defvar std-virtual.windowmenupos 5)
  39. (defvar std-virtual.iconmenupos 0)
  40. (defvar lightgrey (color-make "LightGrey"))
  41. (defvar door-background lightgrey)
  42. (defvar virtual-background (color-make "grey90"))
  43. (defvar initial-doors ())
  44. (defvar std-virtual.doors '("Home" "Free"))
  45. (defvar virtual-horizontal-step screen-width)
  46. (defvar virtual-vertical-step screen-height)
  47.  
  48. (defvar door-mgr-xpos (- screen-width 250))
  49. (defvar door-mgr-ypos (- screen-height 
  50.     (+ 16 (* 16 (/ (+ 1 (length std-virtual.doors)) 2)))))
  51.  
  52. (defvar virtual-pixsize 184)
  53. (defvar virtual-xpos door-mgr-xpos)
  54. (defvar virtual-ypos (- door-mgr-ypos (+ virtual-pixsize 16)))
  55.  
  56. ;;=============================================================================
  57. ;;                    behaviors
  58. ;;=============================================================================
  59. ;; a change: button 2 (action) on icon de-iconifies and follows the window
  60.  
  61. (: icon-behavior
  62.   (state-make
  63.     (on (buttonrelease action-button any)
  64.       (with (deiconified-win window-window)
  65.     (std-iconify-window)
  66.     (setq window window-window)
  67.     (virtual-make-window-visible)
  68. ))))
  69.  
  70. (reparse-standard-behaviors)
  71.  
  72. (de de-iconify-window-in-current-room ()
  73.   (with (win window-window
  74.       x 0 y 0
  75.     )
  76.     (std-iconify-window)
  77.     (setq window win)
  78.     (setq x (% window-x screen-width))
  79.     (setq y (% window-y screen-height))
  80.     (if (< x 0) (setq x (+ x screen-width)))
  81.     (if (< y 0) (setq y (+ y screen-height)))
  82.     (move-window x y)
  83. ))
  84.  
  85. ;;=============================================================================
  86. ;;                    menu entries
  87. ;;=============================================================================
  88.  
  89. ;; add entries in the root, window, icon menus
  90. ;; root: entry to toggle global map
  91. ;; window: nail/un-nail virtual window
  92. ;; icon: an entry to de-iconify in this room
  93.  
  94. (if (not (boundp 'std-virtual.menu-added)) (progn
  95.     (setq std-virtual.menu-added t)
  96.     
  97.     (insert-at '(multi-item-make
  98.     ("Virtual Map On" (progn (setq show-virtual t) (virtual-show)))
  99.     ("Off" (progn (setq show-virtual ()) (virtual-show)))
  100.       )
  101.       root-pop-items
  102.       std-virtual.menupos
  103.     )
  104.     (insert-at '(multi-item-make
  105.     "Virtual" ()
  106.     ("Pick" (progn
  107.         (if (virtual-nailed) () (virtual-nail))
  108.         (if virtual-omit-nailed (virtual-update))
  109.     ))
  110.     ("Drop" (progn
  111.         (if (virtual-nailed) (virtual-unnail))
  112.         (if virtual-omit-nailed (virtual-update))
  113.     ))
  114.       )
  115.       window-pop-items
  116.       std-virtual.windowmenupos
  117.     )
  118.     (insert-at '(item-make "de-icon here" (de-iconify-window-in-current-room))
  119.       icon-pop-items
  120.       std-virtual.iconmenupos
  121.     )
  122. ))
  123.  
  124. ;;=============================================================================
  125. ;;                    load the packages themselves
  126. ;;=============================================================================
  127.  
  128. (load "load-virtual.gwm")
  129. (load "pick.gwm")
  130.  
  131. ;;=============================================================================
  132. ;;                    door manager
  133. ;;=============================================================================
  134.  
  135. ;; then create the defaults doors specified in std-virtual.doors
  136.  
  137. (for doorname std-virtual.doors
  138.   (with (context '() name doorname)
  139.     (if (= (type doorname) 'list) (progn
  140.     (setq color (eval (# 1 doorname)))
  141.     (setq name (# 0 doorname))
  142.     (if color
  143.       (if (= (type color) 'number) 
  144.         ()                ;already a color
  145.         (= (type color) 'pixmap)    ;a tile
  146.         (setq context (+ (list
  147.           'tile color
  148.         ) context     
  149.         ))
  150.         (setq color (color-make color)) ;default
  151.       )
  152.       (setq color door-background)    ;no color
  153.     )
  154.     (setq context (+ 
  155.           (if (= (type color) 'pixmap) () (list 'background color))
  156.           (list 'door-action (list 'list ''door-set-background color)
  157.         )
  158.         context)
  159.     )
  160.     (setq context (+ context (sublist 2 (length doorname) doorname)))
  161.     (setq door-context (+ (list (atom name) context) door-context))
  162.     ))
  163.     (setq screen-opening (+ screen-opening (list (list 'add-door name))))
  164. )))
  165.  
  166. (defun door-set-background (color)
  167.   (with (wob root-window) 
  168.     (if color 
  169.       (if (= (type color) 'pixmap)
  170.     (setq wob-tile color)
  171.     (setq wob-background color))
  172. )))
  173.