home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / twm-popups.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  4KB  |  136 lines
  1. ; Twm-Style Popup Menus (hacked up from std-popups.gwm)
  2. ; =====================================================
  3.  
  4. ; This file is derived from the std-popups.gwm distributed with gwm 1.4.1.30
  5. ; The original file was written by Colas Nahaboo, BULL Research, France.
  6. ;
  7. ; Modifications [Dec 1989] for twm emulation by Arup Mukherjee 
  8. ; (arup@grip.cis.upenn.edu)
  9. ;
  10. ; Within the restrictions of the GWM copyright, you may do whatever you
  11. ; want with this code. It would be nice, however, if my name were to remain 
  12. ; in it somewhere.
  13.  
  14. ; Pop-ups
  15. ; =======
  16.  
  17. (if (not (boundp 'twm-pop-item-font))
  18.     (defname 'twm-pop-item-font screen. (font-make "8x13")))
  19.  
  20. (if (not (boundp 'twm-pop-label-font))
  21.     (defname 'twm-pop-label-font screen. (font-make "8x13")))
  22.  
  23. (if (not (boundp 'twm-pop-item-height))
  24.     (defname 'twm-pop-item-height screen. 10))
  25.  
  26. (setq twm-popups.fsm (fsm-make 
  27.               (: closed 
  28.                  (state-make 
  29.                  (on enter-window 
  30.                      (wob-borderpixel twm-menu-hilite-color)
  31.                      opened)))
  32.               (: opened
  33.                  (state-make
  34.                  (on (buttonrelease any any)
  35.                      (with (calling-wob (with (wob wob-parent)
  36.                              wob-parent))
  37.                        (wob-borderpixel twm-menu-background)
  38.                        (setq twm-popups.action
  39.                          (# 'action wob-property))
  40.                        (wob wob-parent)
  41.                        (unpop-menu 
  42.                     (# 'shadow wob-property))
  43.                        (unpop-menu wob)
  44.                        (wob calling-wob)
  45.                        (eval twm-popups.action)
  46.                        )
  47.                      closed)
  48.                  (on enter-window 
  49.                      (wob-borderpixel twm-menu-hilite-color))
  50.                  (on leave-window 
  51.                      (wob-borderpixel twm-menu-background))))))
  52.  
  53. (df twm-item-make (label action)
  54.     (list 
  55.      (with (borderwidth twm-borderwidth
  56.             borderpixel twm-menu-background
  57.             background twm-menu-background
  58.             foreground twm-menu-foreground
  59.             fsm twm-popups.fsm
  60.             bar-min-width twm-pop-item-height
  61.             property (+ (list 'action action) property))
  62.        (bar-make
  63.         ()
  64.         (with (borderwidth 0 fsm () font twm-pop-item-font)
  65.           (plug-make (label-make label) 
  66.                  ))()))
  67.      (with (borderwidth twm-borderwidth
  68.             borderpixel twm-menu-shadow-color
  69.             foreground twm-menu-shadow-color
  70.             background twm-menu-shadow-color
  71.             fsm ()
  72.             bar-min-width twm-pop-item-height
  73.             property ())
  74.        (bar-make
  75.         ()
  76.         (with (borderwidth 0 fsm () font twm-pop-item-font)
  77.           (plug-make (label-make label) 
  78.                  ))()))))
  79.      
  80.  
  81. (df twm-pop-label-make (label)
  82.     (list 
  83.      (with (borderwidth twm-borderwidth 
  84.             borderpixel twm-menu-border-color fsm ()
  85.             background twm-menu-background
  86.             foreground twm-menu-foreground) 
  87.        (bar-make
  88.         (with (borderwidth 0 font twm-pop-label-font)
  89.           (plug-make (label-make label)))))
  90.      (with (borderwidth twm-borderwidth 
  91.             borderpixel twm-menu-shadow-color fsm ()
  92.             background twm-menu-shadow-color
  93.             foreground twm-menu-shadow-color) 
  94.        (bar-make
  95.         (with (borderwidth 0 font twm-pop-label-font)
  96.           (plug-make (label-make label)))))))
  97.  
  98. (: twm-pop-fsm
  99.    (fsm-make 
  100.     (state-make
  101.      (on (buttonrelease any any) 
  102.      (progn (unpop-menu (# 'shadow wob-property))
  103.         (unpop-menu))))))
  104.  
  105. (df twm-menu-make twm-menu-args
  106.     (with (bar-list (list menu-make) back-list (list menu-make) 
  107.             fsm () bar-separator 0)
  108.       (for item twm-menu-args
  109.            (: twm-item (eval item))
  110.            (setq bar-list (+ bar-list (list (# 0 twm-item))))
  111.            (setq back-list (+ back-list (list (# 1 twm-item)))))
  112.       (with (shadow (eval back-list) fsm twm-pop-fsm
  113.             borderpixel twm-menu-border-color)
  114.         (with (property (+ (list 'shadow shadow) property))
  115.                 (eval bar-list)))))
  116.  
  117. (df twm-pop-menu args
  118.     (if (= (length args) 0)
  119.     (: twm-menu (wob-menu))
  120.       (: twm-menu (eval (# 0 args))))
  121.     (if (= (length args) 2)
  122.     (: pos (eval (# 1 args)))
  123.       (: pos 0))
  124.     (with (wob (menu-wob twm-menu))
  125.       (: shadow (# 'shadow wob-property)))
  126.     (if (not shadow)
  127.     (print "twm menu has no shadow!\n"))
  128.     (with (x (current-event-x) y (current-event-y))
  129.       (warp-pointer (+ x 10) (+ y 10) root-window)
  130.       (pop-menu shadow 0)
  131.       (warp-pointer x y root-window)
  132.       (ungrab-server (menu-wob shadow))
  133.       (pop-menu twm-menu pos)))
  134.       
  135.         
  136.