home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / mwm-utils.gwm < prev    next >
Text File  |  1995-07-03  |  8KB  |  318 lines
  1. ; Various utilities used in mwm profile
  2. ; ==========================================
  3.  
  4. ;;File: mwm-utils.gwm -- General-purpose WOOL utilities
  5. ;;Author: vincent@mirsa.inria.fr (Vincent BOUTHORS) -- Bull Research FRANCE
  6. ;;Author: colas@mirsa.inria.fr (Colas NAHABOO) -- Bull Research FRANCE
  7. ;;Author: Frederic CHARTON
  8. ;;Author: Glen WHITNEY
  9. ;;Revision: 1.2 -- Feb 5,1991
  10. ;;State: Exp
  11. ;;GWM Version: 1.7d
  12.  
  13. (: focus-in-menu-name-placed ())
  14. (: action-by-menu ())
  15. (: double-click-required ())
  16. (: while-opening ())
  17.  
  18. (load "utils.gwm")
  19.  
  20. ; Teste si une propriete est presente dans une liste de proprietes
  21. (de got-property (atome liste)
  22.  (with (place (member atome liste))
  23.   (if place (= 0 (% place 2)))
  24.  )
  25. )
  26.  
  27. (de property-of-wob (my-wob)
  28.  (with (wob my-wob)
  29.   wob-property
  30.  )
  31. )
  32.  
  33.  
  34.  
  35. (: to-lower-case-list '(A "a" B "b" C "c" D "d" E "e" F "f" G "g" H "h"
  36.             I "i" J "j" K "k" L "l" M "m" N "n" O "o" P "p"
  37.             Q "q" R "r" S "s" T "t" U "u" V "v" W "w" X "X"
  38.             Y "y" Z "z" ))
  39.  
  40. (df window-menu ()
  41.  (with (wob window)
  42.   wob-menu
  43.  )
  44. )
  45.  
  46.  
  47. (de mwm-iconify-window ()
  48.     (if lowerOnIconify (with (window window-icon) (lower-window)))
  49.     (if iconAutoPlace
  50.     (with (
  51.            theWindow window
  52.            wob (if window-group
  53.                (with (window (# 0 window-group)) window-icon)
  54.              window-icon)
  55.            X (# 'X wob-property)
  56.            Y (# 'Y wob-property)
  57.            theIcon (if (and X Y) (get-icon-from-array X Y) t)
  58.            icon-window-group (if (member theIcon (list-of-windows))
  59.                      (with (window theIcon) window-group)
  60.                    ())
  61.            )
  62.       (if (= theIcon ()) 
  63.           (progn
  64.         (## 'X wob X)
  65.         (## 'Y wob Y)
  66.         (set-icon-of-array X Y wob)
  67.         (eval (+ '(move-window wob) (XY-to-xy X Y)))
  68.         (with (window theWindow)
  69.           (iconify-window)
  70.           )
  71.         )
  72.         (= theIcon wob)
  73.         (with (window theWindow)
  74.           (iconify-window)
  75.           )
  76.  
  77.         (member theWindow icon-window-group)
  78.         (progn
  79.           (with (window theWindow)
  80.         (iconify-window)
  81.         )
  82.           )
  83.  
  84.         (with (thePlace (auto-get-place)
  85.                 X (# 0 thePlace)
  86.                 Y (# 1 thePlace)
  87.                 )
  88.           (## 'X wob X)
  89.           (## 'Y wob Y)
  90.           (eval (+ '(move-window wob) (XY-to-xy X Y)))
  91.           (set-icon-of-array X Y wob)
  92.           (with (window theWindow)
  93.         (iconify-window)
  94.         )
  95.           )
  96.         )
  97.       )
  98.       (progn (move-window window-icon (+ window-x window-client-x) 
  99.               (+ window-y window-client-y))
  100.          (iconify-window)
  101.          )
  102.       )
  103.     )
  104.  
  105. (: mwmIconifyHack ())
  106. (de mwm-de-iconify-window ()
  107.     (if (not mwmIconifyHack)
  108.     (with (X (# 'X window-property)
  109.            Y (# 'Y window-property)
  110.            )
  111.       (: mwmIconifyHack t)
  112.       (set-icon-of-array X Y ())
  113.       (iconify-window)
  114.       (raise-window)
  115.       (if (and (= 'explicit keyboardFocusPolicy) deiconifyKeyFocus) 
  116.           (set-focus))
  117.       (process-events 'sync)
  118.       (: mwmIconifyHack ()) ; danger of re-entrance over.
  119.       (with (window window-icon)
  120.         (if (# 'got-focus window)
  121.             (progn
  122.               (## 'got-focus window ())
  123.               (send-user-event 'focus-out)
  124.               (if (# 'focus-in-menu-name-placed window)
  125.               (progn
  126.                 (unpop-menu (# 'focus-in-menu-name window))
  127.                 (ungrab-server)
  128.                 (## 'focus-in-menu-name-placed window ())
  129.                 )))))
  130.       )
  131.       ))
  132.  
  133. (: delta moveThreshold)
  134. (: delta2 (* delta delta))
  135.  
  136. (de deltabutton ()
  137.     (allow-event-processing)        ; otherwise pointer state frozen
  138.     (if (and (> (current-event-code) 0)        ; last event received
  139.          (< (current-event-modifier) 256)) ; is a buttonpress
  140.     (tag DELTABUTTON
  141.          (: e-m (# (current-event-code) '(0 1 2 4)))
  142.          (: e-x (current-event-x))
  143.          (: e-y (current-event-y))
  144.          (: m-p (current-mouse-position))
  145.          (while (= (/ (# 2 m-p) 256) e-m) ; the button is still pressed
  146.            (: dx (- (# 0 m-p) e-x))
  147.            (: dy (- (# 1 m-p) e-y))
  148.            (if (> (+ (* dx dx) (* dy dy)) delta2)
  149.            (exit DELTABUTTON (list dx dy)))
  150.            (: m-p (current-mouse-position)))
  151.          ()))
  152.     )
  153.  
  154.  
  155. (df move-icon ()
  156.  (move-window)
  157.  (if iconAutoPlace
  158.  (with (
  159.         target.x  (+ window-x (/ window-width 2))
  160.         target.y  (+ window-y (/ window-height 2))
  161.         theCoords (xy-to-XY target.x target.y)
  162.         X         (# 0 theCoords)
  163.         Y         (# 1 theCoords)
  164.         theIcon   (get-icon-from-array X Y)
  165.        )
  166.   (if (or (= theIcon ()) (= theIcon window))
  167.    (progn
  168.     (eval (+ '(move-window) (XY-to-xy X Y)))
  169.     (set-icon-of-array (# 'X window) (# 'Y window) ())
  170.     (## 'X window X)
  171.     (## 'Y window Y)
  172.     (set-icon-of-array X Y window)
  173.    )
  174.    (with (theNeighbors (neighbors target.x target.y)
  175.           first        (# 0 theNeighbors)
  176.           first.X      (# 1 first)
  177.           first.Y      (# 2 first)
  178.           second       (# 1 theNeighbors)
  179.           second.X     (# 1 second)
  180.           second.Y     (# 2 second)
  181.          )
  182.     (if (not (# 0 first))
  183.      (progn
  184.       (eval (+ '(move-window) (XY-to-xy first.X first.Y)))
  185.       (set-icon-of-array (# 'X window) (# 'Y window) ())
  186.       (## 'X window first.X)
  187.       (## 'Y window first.Y)
  188.       (set-icon-of-array first.X first.Y window)
  189.      )
  190.      (not (# 0 second))
  191.      (progn
  192.       (eval (+ '(move-window) (XY-to-xy second.X second.Y)))
  193.       (set-icon-of-array (# 'X window) (# 'Y window) ())
  194.       (## 'X window second.X)
  195.       (## 'Y window second.Y)
  196.       (set-icon-of-array second.X second.Y window)
  197.      )
  198.      (progn
  199.       (eval (+ '(move-window)
  200.        (XY-to-xy (# 'X window) (# 'Y window) ))
  201.       )
  202.       (bell)
  203.      )
  204.     )
  205.    )
  206.   )
  207.  )
  208.  )
  209. )
  210.  
  211. (: keyFocusList ())
  212.  
  213. (df maintain-focus-in ()
  214.     (if (not (# 'got-focus wob))
  215.     (progn
  216.       (## 'got-focus window t)
  217.       (send-user-event 'focus-in)
  218.       (set-colormap-focus)
  219.       (if (and autoKeyFocus (= keyboardFocusPolicy 'explicit)
  220.            (= window-status 'window))
  221.           (progn
  222.         (remove-kFL window)
  223.         (new-head-kFL window)))
  224.  
  225.       (if (and (= 'icon wob-status) completeIconNameOnFocusIn )
  226.           (with (x (- wob-x
  227.               (/ (- (width 
  228.                  (menu-wob (# 'focus-in-menu-name window)))
  229.                 wob-width) 2))
  230.                y (+ wob-y (- wob-height icon-bottom-bar-width) 4)
  231.                )
  232.         (## 'focus-in-menu-name-placed window t)
  233.         (## 'icon-father (menu-wob
  234.                   (# 'focus-in-menu-name window)) window)
  235.         (if (< x 0)
  236.             (: x 0))
  237.         (if (> (+ x (width (menu-wob
  238.                     (# 'focus-in-menu-name window))))
  239.                screen-width)
  240.             (: x (- screen-width
  241.                 (width (menu-wob
  242.                     (# 'focus-in-menu-name window))))))
  243.         (menu.move (# 'focus-in-menu-name window) x y)
  244.         (send-user-event 'focus-in (menu-wob
  245.                         (# 'focus-in-menu-name window)))
  246.         (move-window (menu-wob (# 'focus-in-menu-name window))
  247.                  x y)
  248.         (pop-menu (# 'focus-in-menu-name window) 'here)
  249.         (with (grab-keyboard-also t) (grab-server window))
  250.         ))
  251.       (if (and (= keyboardFocusPolicy 'pointer)
  252.            (get-res-truth-value 'focusAutoRaise) 
  253.            (not (= 'icon wob-status)))
  254.           (with (start-time (elapsed-time))
  255.             (while (< (- (elapsed-time) start-time) autoRaiseDelay)
  256.               (process-events)) ; wait for a bit
  257.             (if (# 'got-focus window) (f.raise))))
  258.       )))
  259.  
  260. (df maintain-focus-out ()
  261.     (if (# 'got-focus wob)
  262.     (progn
  263.       (## 'got-focus window ())
  264.       (send-user-event 'focus-out)
  265.       (if (# 'focus-in-menu-name-placed window)
  266.           (progn
  267.         (unpop-menu (# 'focus-in-menu-name window))
  268.         (ungrab-server)
  269.         (## 'focus-in-menu-name-placed window ())
  270.         )))))
  271.  
  272. (de head-kFL ()
  273.     (# 0 keyFocusList)
  274.     )
  275.  
  276. (de remove-kFL (w)
  277.     (with (index (member w keyFocusList)
  278.          )
  279.       (if index
  280.       (: keyFocusList (+ (sublist 0 index keyFocusList)
  281.                  (sublist (+ index 1)
  282.                       (length keyFocusList) keyFocusList)
  283.                  )))))
  284.  
  285.  
  286. (de new-head-kFL (w)
  287.     (: keyFocusList (+ (list w) keyFocusList))
  288.     )
  289.  
  290. (de obscured-by (w1 w2)
  291.     (with (window w1
  292.          w1l window-x
  293.          w1t window-y
  294.          w1r (+ window-width w1l)
  295.          w1b (+ window-height w1t)
  296.          window w2
  297.          w2l window-x
  298.          w2t window-y
  299.          w2r (+ window-width w2l)
  300.          w2b (+ window-height w2t))
  301.        (and (< w2l w1r)
  302.           (< w2t w1b)
  303.           (> w2b w1t)
  304.           (> w2r w1l))))
  305.  
  306. (de pop-up-win strings
  307. (place-menu (# 0 strings)
  308.     (with (direction vertical
  309.            fsm (fsm-make (state-make (on (button any any) (delete-window))))
  310.          borderwidth 0)
  311.         (eval (+ '(menu-make)
  312.                 (mapfor line (+ (sublist 1 (length strings) strings)
  313.                                 (list "" "Click a button to delete"))
  314.                     (bar-make
  315.                      () (plug-make (active-label-make line)) () )))))
  316. (current-event-x)
  317. (current-event-y)))
  318.