home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / virtual-door.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  15KB  |  434 lines
  1. ;; virtual-door.gwm --- Doors for the virtual screen in "virtual.gwm"
  2. ;;
  3. ;; Author: Anders Holst  (aho@sans.kth.se)  
  4. ;; Copyright (C) 1995  Anders Holst
  5. ;; Version: virtual-1.0
  6. ;; Last change: 17/6 1995
  7. ;;
  8. ;; This file is copyrighted under the same terms as the rest of GWM
  9. ;; (see the X Inc license for details). There is no warranty that it
  10. ;; works. 
  11. ;;
  12. ;; --------------------------------------------------------------------- 
  13. ;;
  14. ;; This file defines "doors" on the virtual screen, ie. buttons that
  15. ;; when pressed moves the real screen somewhere on the virtual screen.
  16. ;; The position to move to can be fixed, or given by an expression.
  17. ;;
  18. ;; It also defines some very simple "door managing" functions, to add
  19. ;; or remove doors dynamically. Use '(add-door NAME)' to add a door to
  20. ;; the next area with no door already. Use '(add-door NAME 'free)' to
  21. ;; add a door to some area in addition free from windows. Use
  22. ;; '(maybe-add-door NAME)' to add a door (to a window-free area) only
  23. ;; if a door of that name does not exist.
  24. ;; '(goto-door NAME)' moves through a door, and '(remove-door NAME)' 
  25. ;; removes a door. 
  26. ;;
  27.  
  28. (declare-screen-dependent
  29.   door-font
  30.   door-background
  31.   door-foreground
  32.   door-borderwidth
  33.   door-xsize
  34.   door-ysize
  35.   door-mgr-dir-horiz
  36.   door-mgr-dir-len
  37.   door-mgr-mdir-horiz
  38.   door-mgr-mdir-len
  39.   door-mgr-xpos
  40.   door-mgr-ypos
  41.   door-mgr-tile
  42.   door-mgr
  43.   door-context
  44. )
  45.  
  46. ;;
  47. ;;    USER CUSTOMIZABLE VARIABLES
  48. ;;    ---------------------------  
  49. ;;    Adjust these in your own profile
  50. ;;
  51. (for screen (list-of-screens)
  52.      (defaults-to 
  53.        door-font (font-make "8x13")   ; Font in door buttons                
  54.        door-background white          ; Background color of door buttons
  55.        door-foreground black          ; Foreground color of door buttons
  56.        door-borderwidth 2             ; Border width of door buttons
  57.        door-xsize 90                  ; Door button size
  58.        door-ysize 16                  ;  - " -
  59.                                
  60.        door-mgr-dir-horiz t    ; Controls mapping of doors on virtual screen,
  61.        door-mgr-dir-len 2      ; e.g. two screenfulls in a (horizontal) row.
  62.        door-mgr-mdir-horiz t   ; Controls position of door buttons, e.g.
  63.        door-mgr-mdir-len 2     ; place two buttons in each (horizontal) row.
  64.        door-mgr-xpos 0         ; Upper left corner of door manager
  65.        door-mgr-ypos 0         ;  - " -
  66.        door-mgr-tile t         ; tile of empty positions, t = transparent 
  67.        door-context ()         ; p-list of customizations per door name
  68.        )
  69. )
  70.  
  71. (for screen (list-of-screens)
  72.      (setq door-mgr '(() () () ())))
  73.  
  74. (setq door-fsm
  75.   (fsm-make 
  76.     (state-make
  77.       (on (button any alone)
  78.     (with (
  79.         pos (# 'pos wob-property)
  80.         action (# 'action wob-property)
  81.         lst (if (and pos (= (type pos) 'list))
  82.           pos
  83.           (= (type pos) 'quoted-expr)
  84.           (eval (eval pos))
  85.           ()))
  86.       (if lst
  87.         (virtual-move-to (# 0 lst) (# 1 lst)))
  88.       (eval action)
  89.       ))
  90. )))
  91.  
  92. (defun door-make (name xpos ypos gotopos)
  93.   (process-events)
  94.   (with (background door-background
  95.          foreground door-foreground
  96.          borderpixel door-foreground
  97.          borderwidth door-borderwidth
  98.          menu-min-width door-xsize
  99.          menu-max-width door-xsize
  100.          bar-min-width door-ysize
  101.          bar-max-width door-ysize
  102.          direction vertical
  103.          reenter-on-opening ())
  104.     (place-menu "door"
  105.                 (with (borderwidth 0
  106.                        fsm door-fsm
  107.                        property (+ (list 'pos gotopos) property)) 
  108.                   (menu-make 
  109.                    (bar-make
  110.                     ()
  111.                     (plug-make
  112.                      (label-make name door-font))
  113.                     ())))
  114.                 xpos ypos)))
  115.  
  116. (defun door-make-plug (name gotopos)
  117.   (with (background door-background
  118.       foreground door-foreground
  119.       tile ()
  120.       borderwidth 0
  121.       bar-min-width door-xsize
  122.       bar-max-width door-xsize
  123.       context (# (atom name) door-context)
  124.       door-action ()
  125.       door-icon ()
  126.       property (+ (list 'pos gotopos 'name name) property)
  127.       fsm door-fsm)
  128.     (with context
  129.       (if door-action 
  130.     (setq property (+ (list 'action door-action) property))
  131.       )
  132.       (bar-make 
  133.     (with (bar-min-width door-ysize
  134.         bar-max-width door-ysize
  135.         property ()
  136.         fsm ())
  137.       (bar-make 
  138.         ()
  139.         (plug-make
  140.           (if door-icon
  141.         door-icon
  142.         (label-make name door-font))
  143.         )
  144.         ())))))
  145. )
  146.  
  147. (defun door-make-space ()
  148.   (with (background door-background
  149.          foreground door-foreground
  150.          borderwidth 0
  151.          bar-min-width door-xsize
  152.          bar-max-width door-xsize
  153.          tile ()
  154.          fsm ())
  155.     (bar-make 
  156.       (with (bar-min-width door-ysize
  157.              bar-max-width door-ysize
  158.              tile door-mgr-tile)
  159.         (bar-make )))))
  160.  
  161. (defun door-make-vborder (ele1 ele2)
  162.   (with (background door-foreground
  163.          borderwidth 0
  164.          bar-min-width door-borderwidth
  165.          bar-max-width door-borderwidth
  166.          tile (if (and (eq door-mgr-tile t)
  167.                        (not (or ele1 ele2)))
  168.                   t)
  169.          fsm ())
  170.     (bar-make )))
  171.  
  172. (defun door-make-hborder-aux (len tl)
  173.   (with (bar-min-width len
  174.          bar-max-width len
  175.          tile tl)
  176.     (list (bar-make ))))
  177.  
  178. (defun door-make-hborder (lst i1 i2 step num)
  179.   (with (background door-foreground
  180.          borderwidth 0
  181.          bar-min-width door-borderwidth
  182.          bar-max-width door-borderwidth
  183.          tile ()
  184.          fsm ())
  185.     (if (eq door-mgr-tile t)
  186.         (with (tlst (list-make num)
  187.                blst ()
  188.                n 1
  189.                i 0)
  190.           (while (< i num)
  191.             (## i tlst (not (or (# i1 lst) (# i2 lst))))
  192.             (setq i (+ i 1))
  193.             (setq i1 (+ i1 step))
  194.             (setq i2 (+ i2 step)))
  195.           (setq i 0)
  196.           (while (< i num)
  197.             (if (and (< (+ i 1) num) (= (# i tlst) (# (+ i 1) tlst)))
  198.                 (setq n (+ n 1))
  199.               (not (# i tlst))
  200.                 (progn
  201.                   (setq blst 
  202.                         (+ blst 
  203.                            (door-make-hborder-aux (+ (* n (+ door-xsize
  204.                                                              door-borderwidth)) 
  205.                                                      door-borderwidth)
  206.                                                   ())))
  207.                   (setq n 1))
  208.                 (progn
  209.                   (setq blst 
  210.                         (+ blst 
  211.                            (door-make-hborder-aux (+ (* n (+ door-xsize
  212.                                                              door-borderwidth))
  213.                                                      (if (= (+ i 1) n)
  214.                                                          door-borderwidth 0)
  215.                                                      (if (= (+ i 1) num)
  216.                                                          door-borderwidth 0)
  217.                                                      (- door-borderwidth))
  218.                                                   t)))
  219.                   (setq n 1)))
  220.             (setq i (+ i 1)))
  221.           (apply bar-make blst))
  222.         (bar-make ))))
  223.  
  224. (defun door-mgr-show ()
  225.   (process-events)
  226.   (if (and door-mgr
  227.            (# 0 door-mgr)
  228.            (wob-is-valid (# 0 door-mgr)))
  229.       (with (wob (# 0 door-mgr)
  230.              xpos (# 1 door-mgr)
  231.              ypos (# 2 door-mgr))
  232.         (setq xpos (if (and xpos (< xpos 0))
  233.                        (+ wob-x (- wob-borderwidth) window-client-x window-client-borderwidth 
  234.                           (- screen-width) (width wob))
  235.                      (+ wob-x wob-borderwidth window-client-x window-client-borderwidth)))
  236.         (setq ypos (if (and ypos (< ypos 0))
  237.                        (+ wob-y (- wob-borderwidth) window-client-y window-client-borderwidth
  238.                           (- screen-height) (height wob))
  239.                      (+ wob-y wob-borderwidth window-client-y window-client-borderwidth)))
  240.         (## 1 door-mgr xpos)
  241.         (## 2 door-mgr ypos)
  242.         (delete-window)))
  243.   (if (and door-mgr
  244.            (# 3 door-mgr)
  245.            (> (door-mgr-find-last (# 3 door-mgr)) 0))
  246.       (with (background door-background
  247.              foreground door-foreground
  248.              borderpixel door-foreground
  249.              bar-separator 0
  250.              plug-separator 0
  251.              borderwidth 0
  252.              direction vertical
  253.              reenter-on-opening ()
  254.              bar-list (door-mgr-construct-bar-list (# 3 door-mgr))
  255.              mgr (apply menu-make bar-list)
  256.              xpos (or (# 1 door-mgr) door-mgr-xpos)
  257.              ypos (or (# 2 door-mgr) door-mgr-ypos)
  258.              xpos (if (< xpos 0)
  259.                       (- (+ screen-width xpos) (with (wob (menu-wob mgr))
  260.                                                  (width wob)))
  261.                     xpos)
  262.              ypos (if (< ypos 0)
  263.                       (- (+ screen-height ypos) (with (wob (menu-wob mgr))
  264.                                                   (height wob)))
  265.                     ypos))
  266.         (## 0 door-mgr (place-menu
  267.                         "door-mgr"
  268.                         mgr
  269.                         xpos ypos)))))
  270.   
  271. (defun door-mgr-find-last (lst)
  272.   (with (i (- (length lst) 1))
  273.     (while (and (> i -1) (not (# i lst)))
  274.       (setq i (- i 1)))
  275.     (+ i 1)))
  276.  
  277. (defun door-mgr-construct-bar-list (door-lst)
  278.   (with (num (door-mgr-find-last door-lst)
  279.          rows (if door-mgr-mdir-horiz
  280.                   (+ (/ (- num 1) door-mgr-mdir-len) 1)
  281.                 (min num door-mgr-mdir-len))
  282.          cols (if door-mgr-mdir-horiz
  283.                   (min num door-mgr-mdir-len)
  284.                 (+ (/ (- num 1) door-mgr-mdir-len) 1))
  285.          step (if door-mgr-mdir-horiz
  286.                   1 door-mgr-mdir-len)
  287.          bstep (if door-mgr-mdir-horiz
  288.                   door-mgr-mdir-len 1)
  289.          len (+ (* 2 rows) 1)
  290.          lst (list-make len)
  291.          i 1
  292.          n 0)
  293.     (## 0 lst (door-make-hborder door-lst (- bstep) 0 step cols))
  294.     (while (< i len)
  295.       (## i lst (apply bar-make (door-mgr-construct-plug-list door-lst n step cols)))
  296.       (## (+ i 1) lst (door-make-hborder door-lst n (+ n bstep) step cols))
  297.       (setq i (+ i 2))
  298.       (setq n (+ n bstep)))
  299.     lst))
  300.  
  301. (defun door-mgr-construct-plug-list (door-lst n step num)
  302.   (with (len (+ (* 2 num) 1)
  303.          lst (list-make len)
  304.          i 1)
  305.     (## 0 lst (door-make-vborder () (# n door-lst)))
  306.     (while (< i len)
  307.       (## i lst (with (door (# n door-lst))
  308.                   (if door 
  309.                       (door-make-plug (# 0 door) (door-virt-coord n))
  310.                     (door-make-space))))
  311.       (## (+ i 1) lst (door-make-vborder (# n door-lst)
  312.                                          (if (< (+ i 2) len)
  313.                                              (# (+ n step) door-lst))))
  314.       (setq i (+ i 2))
  315.       (setq n (+ n step)))
  316.     lst))
  317.  
  318. (defun door-virt-coord (nr)
  319.   (if door-mgr-dir-horiz
  320.       (list (* screen-width (% nr door-mgr-dir-len))
  321.             (* screen-height (/ nr door-mgr-dir-len)))
  322.       (list (* screen-width (/ nr door-mgr-dir-len))
  323.             (* screen-height (% nr door-mgr-dir-len)))))
  324.  
  325.  
  326. ;; Door Manager Functionality
  327.  
  328. (defun get-door (nr)
  329.   (# nr (# 3 door-mgr)))
  330.  
  331. (defun set-door (nr ele)
  332.   (if (not (> (length (# 3 door-mgr)) nr))
  333.       (## 3 door-mgr (+ (# 3 door-mgr)
  334.                         (list-make (- (+ 1 nr) (length (# 3 door-mgr)))))))
  335.   (## nr (# 3 door-mgr) ele))
  336.  
  337. (defun door-empty-space (virtcoord)
  338.   (with (left (+ (# 0 virtcoord) (# 0 virt-pos))
  339.          right (+ left screen-width)
  340.          top (+ (# 1 virtcoord) (# 1 virt-pos))
  341.          bottom (+ top screen-height))
  342.     (tag ret
  343.          (for wob (list-of-windows 'window 'mapped)
  344.               (if (not (virtual-nailed))
  345.                   (with (midx (+ window-x (/ window-width 2))
  346.                          midy (+ window-y (/ window-height 2)))
  347.                     (if (and (> midx left)
  348.                              (< midx right)
  349.                              (> midy top)
  350.                              (< midy bottom))
  351.                         (exit ret ())))))
  352.          t)))
  353.  
  354. (defun door-find-index (ind free movable)
  355.   (if (and free movable)
  356.       (while (or (get-door ind) (not (door-empty-space (door-virt-coord ind))))
  357.         (setq ind (+ ind 1)))
  358.       movable
  359.       (while (get-door ind)
  360.         (setq ind (+ ind 1)))
  361.       free
  362.       (while (or (not (door-empty-space (door-virt-coord ind)))
  363.                  (and (get-door ind)
  364.                       (not (# 2 (get-door ind)))))
  365.         (setq ind (+ ind 1)))
  366.       (while (and (get-door ind)
  367.                   (or (not (# 2 (get-door ind)))
  368.                       (not (door-empty-space (door-virt-coord ind)))))
  369.         (setq ind (+ ind 1))))
  370.   ind)
  371.  
  372. (defun door-find-name (name)
  373.   (with (ind 0
  374.          ele (get-door ind)
  375.          len (length (# 3 door-mgr)))
  376.     (while (and (< ind len)
  377.                 (not (= name (# 0 ele))))
  378.       (setq ind (+ 1 ind))
  379.       (setq ele (get-door ind)))
  380.     (if (< ind len)
  381.         ind
  382.       ())))
  383.  
  384. (defun add-door args
  385.   (with (name (# 0 args)
  386.          startind (if (= (type (# 1 args)) 'number) (# 1 args) 0)
  387.          free (member 'free args)
  388.          movable (member 'movable args)
  389.          ind (door-find-index startind free movable)
  390.          virtpos (door-virt-coord ind)
  391.          ele (list name free movable))
  392.     (while (get-door ind)
  393.       (with (startind (+ 1 ind)
  394.              oldele (get-door ind)
  395.              newind (door-find-index startind (# 1 oldele) ()))
  396.         (set-door ind ele)
  397.         (setq ele oldele)
  398.         (setq ind newind)))
  399.     (set-door ind ele)
  400.     (door-mgr-show)
  401.     virtpos))
  402.  
  403. (defunq maybe-add-door args
  404.   (with (ind (door-find-name (eval (# 0 args))))
  405.     (if ind
  406.         (door-virt-coord ind)
  407.         (eval (+ (list 'add-door) args)))))
  408.  
  409. (defun goto-door (name)
  410.   (with (ind (door-find-name name)
  411.          pos (if ind (door-virt-coord ind)))
  412.     (if ind
  413.         (virtual-move-to (# 0 pos) (# 1 pos)))))
  414.  
  415. (defun remove-door (arg)
  416.   (with (ind ())
  417.     (if (= (type arg) 'string)
  418.         (: ind (door-find-name arg))
  419.         (= (type arg) 'number)
  420.         (: ind arg))
  421.     (if ind
  422.         (with (ele (get-door ind))
  423.           (set-door ind ())
  424.           (if (door-empty-space (door-virt-coord ind))
  425.               (with (newind (door-find-index (+ 1 ind) t ())
  426.                      newele ())
  427.                 (while (setq newele (get-door newind))
  428.                   (set-door ind newele)
  429.                   (setq ind newind)
  430.                   (setq newind (door-find-index (+ 1 ind) t ())))
  431.                 (set-door ind ())))))
  432.     (door-mgr-show)))
  433.  
  434.