home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 22 gnu / 22-gnu.zip / gwm18a.zip / data / widgets.gwm < prev    next >
Lisp/Scheme  |  1995-07-03  |  6KB  |  268 lines
  1. ;;;File:  widgets.gwm -- various widgets for decorations
  2.  
  3. ;;Author: Brian L. Kahn
  4. ;;Copyright 1992, MITRE Corporation
  5. ;;Not for sale or resale, distribution unlimited
  6.  
  7.  
  8. (load "cursor-names.gwm")
  9. (: widget.bar-cursor
  10.    (cursor-make XC_fleur))
  11. (: widget.menu-cursor
  12.    (cursor-make XC_crosshair))
  13. (: widget.scroll-cursor
  14.    (cursor-make XC_sb_v_double_arrow))
  15. (: widget.scroll-up-cursor
  16.    (cursor-make XC_sb_up_arrow))
  17. (: widget.scroll-down-cursor
  18.    (cursor-make XC_sb_down_arrow))
  19. (: widget.scroll-index-cursor
  20.    (cursor-make XC_sb_right_arrow))
  21. (: widget.weave 
  22.    (pixmap-make "/usr/include/X11/bitmaps/cross_weave"))
  23. (: widget.gray
  24.    (pixmap-make "/usr/include/X11/bitmaps/gray"))
  25. (: widget.lt-gray
  26.    (pixmap-make "/usr/include/X11/bitmaps/light_gray"))
  27. (: widget.black
  28.    (pixmap-make "/usr/include/X11/bitmaps/black"))
  29. (: widget.font  (font-make "widget"))
  30. (: widget.Bfont (font-make "widgetBold"))
  31.  
  32. ;(: widget.font  (font-make "*clean-medium*--10*c-60*"))
  33. ;(: widget.Bfont (font-make "*clean-bold*--10*c-60*"))
  34.  
  35.  
  36. ;PROGRAMMING
  37. ;===========
  38.  
  39. (de apply (func arg)
  40.     (eval (+ (list func) arg)))
  41.  
  42. (de apply1 (func arg)
  43.     (eval (list (eval func) arg)))
  44.  
  45.  
  46.  
  47. (defun widget:message message
  48.   ;; put "who what when why"  into property for this widget
  49.   (with (output (+ "(" ;who
  50.            (or (# 'name message) (# 'name wob-property) "widget")
  51.            " " ;what
  52.            (itoa (current-event-code))
  53.            " " ;when
  54.            (itoa (current-event-modifier))
  55.            " " ;why
  56.            (or (# 'message message) (# 0 message) "no-message")
  57.            ")"
  58.            ))
  59.     (set-x-property (or (# 'widget message) (# 'widget wob-property))
  60.             output)
  61.     ))
  62.  
  63.  
  64. (: widget:scrollbar-fsm
  65.    (fsm-make
  66.     (: inactive 
  67.        (state-make
  68.     (on (buttonpress 1 any)
  69.         (wob-cursor widget.scroll-up-cursor)
  70.         active)
  71.     (on (buttonpress 2 any)
  72.         (wob-cursor widget.scroll-index-cursor)
  73.         active)
  74.     (on (buttonpress 3 any)
  75.         (wob-cursor widget.scroll-down-cursor)
  76.         active)
  77.     ))
  78.     (: active
  79.        (state-make
  80.     (on (buttonrelease any any)
  81.         (progn
  82.           (wob-cursor widget.scroll-cursor)
  83.           (widget:message
  84.            (itoa (/ (* 100 (current-event-relative-y))
  85.             (height wob)))))
  86.         inactive)
  87.     ))
  88.     ))
  89.  
  90. (: widget:scrollbar-make
  91.    (with (fsm widget:scrollbar-fsm
  92.       borderwidth 1
  93.       tile widget.weave
  94.       cursor widget.scroll-cursor
  95.       property (list 'widget "scrollbar" 'name "leftside")
  96.       bar-min-width 14)
  97.      (bar-make)))
  98.  
  99. (: widget:Dmenu-fsm
  100.    (fsm-make
  101.     (: menu-off
  102.        (state-make
  103.     (on enter-window
  104.         (wob-tile (# 'on-pix wob-property)))
  105.     (on leave-window
  106.         (wob-tile (# 'off-pix wob-property)))
  107.     (on (buttonpress menu-button any)
  108.         (progn
  109.           (wob-tile (# 'off-pix wob-property))
  110.           (if wob-menu
  111.           (pop-menu))
  112.           ))
  113.     (on (buttonpress any any)
  114.         (wob-invert) 
  115.         menu-on)
  116.     ))
  117.     (: menu-on
  118.        (state-make
  119.     (on (buttonrelease any any)
  120.         (progn 
  121.           (wob-invert)
  122.           (eval (# 'action wob-property)))
  123.         menu-off)
  124.     (on leave-window
  125.         (progn
  126.           (wob-invert)
  127.           (wob-tile (# 'off-pix wob-property)))
  128.         menu-off)
  129.     ))
  130.     ))
  131.     
  132. (: widget:Dmenubar-fsm
  133.    (fsm-make
  134.     (state-make
  135.      (on (user-event 'focus-in)
  136.      (wob-tile widget.gray))
  137.      (on (user-event 'focus-out)
  138.      (wob-tile widget.lt-gray))
  139.      standard-title-behavior)))
  140.  
  141. (defun widget:Dmenubar-make (menulist)
  142.   (with (fsm widget:Dmenubar-fsm
  143.      tile widget.gray 
  144.      plug-separator 8
  145.      borderwidth 0
  146.      cursor widget.bar-cursor
  147.      bar-min-width 2
  148.      bar-max-width 24)
  149.     (apply 'bar-make menulist)
  150.   ))
  151.  
  152.  
  153.  
  154. (defun widget:Dmenu-make (args)
  155.   ;; Make a plug that drops a menu.  
  156.   ;; ARGS is '(name (item ... item))
  157.   ;; item is ("label" action)
  158.   ;; action is "(elisp-function args)" or (wool-function args)
  159.   (with (name (# 0 args)
  160.            widget "Dmenu"
  161.      item-list (# 1 args)
  162.      action (widget:action (# 1 (# 0 item-list)))
  163.      menu (widget:menu-make item-list)
  164.      fsm widget:Dmenu-fsm
  165.      borderwidth 1
  166.      cursor widget.menu-cursor
  167.      property (list 'widget widget
  168.             'name name 
  169.             'action action
  170.             'off-pix (label-make name widget.font)
  171.             'on-pix (label-make name widget.Bfont))
  172.      )
  173.     (plug-make (# 'off-pix property))))
  174.  
  175.  
  176. (defun widget:menu-make (item-list)
  177.   (menu-make-from-list
  178.    (mapfor item item-list
  179.        (list 'item-make 
  180.          (# 0 item) 
  181.          (widget:action (# 1 item)))
  182.        )))
  183.  
  184.  
  185. ; action is "(elisp-function args)" or (wool-function args)
  186. (defun widget:action (action)
  187.   (cond ((eq 'string (type action))
  188.      (list 'widget:message ''message action))
  189.     ((eq 'list (type action))
  190.      action)
  191.     (t (progn (? "Invalid widget:action - ")
  192.           (? action)))
  193.     ))
  194.  
  195.  
  196.  
  197.  
  198. (: widget:Pmenu-fsm 
  199.   (fsm-make 
  200.     (setq initial (state-make
  201.     (on enter-window-not-from-grab        ; init menu colors
  202.       (: invert-color (bitwise-xor pop-item.foreground
  203.           pop-item.background))
  204.       realized            ; then go in normal mode
  205.       )
  206.     (on (buttonrelease any any)    ; ButRel before menu appeared 
  207.       (progn            ; then call default action
  208.         (with (calling-wob wob-parent Menu wob)
  209.           (setq std-popups.action
  210.         (# 'action wob-property))
  211.           (wob wob-parent)
  212.           (send-user-event 'depop Menu t)
  213.           (wob calling-wob)
  214.           (eval std-popups.action))
  215.       )
  216.       waiting-for-enter-window    ; must trap the actual menu map
  217.     )
  218.     (on (user-event 'depop) (unpop-menu) initial)      
  219.     ))
  220.     (setq realized (state-make
  221.     (on (buttonrelease any any)    ; ButRel outside of menu
  222.         (progn
  223.           (with (quit (# 'quit wob-property))
  224.             (if quit (eval quit)))
  225.           (unpop-menu)
  226.           )
  227.         initial)
  228.     (on (user-event 'depop) (unpop-menu) initial)      
  229.     ))
  230.     (setq waiting-for-enter-window (state-make
  231.     (on enter-window-not-from-grab () initial)
  232.     ))
  233. ))
  234.  
  235.  
  236. (defun widget:Pmenu-make spec
  237.   ;; Make a pop-up menu that returns index of selection
  238.   (with (fsm widget:Pmenu-fsm
  239.      item-list (# 0 spec) 
  240.      property (list 'widget "Pmenu"
  241.             'name "Pmenu"
  242.             'quit '(widget:message 'message "nil" 'widget 'Pmenu)
  243.             'action '(widget:message 'message 0 'widget 'Pmenu)
  244.             )
  245.      index -1 ; starts at 0, pre-incremented
  246.      )
  247.     (eval 
  248.      (+ '(menu-make)
  249.         (mapfor item item-list
  250.             (list 'item-make 
  251.               item
  252.               (list 'widget:message
  253.                 ''message (itoa (: index (+ index 1)))
  254.                 ''widget "Pmenu")
  255.               ))))
  256.     ))
  257.  
  258.  
  259.  
  260.  
  261. ;; for convenience in defining Dmenus
  262. (defunq Dmenu: (Dmenu.name arglist)
  263.   ;; assign DMENU.NAME equal to the Dmenu created using ARGLIST.
  264.   (set Dmenu.name (eval (list 'widget:Dmenu-make arglist))))
  265.  
  266.  
  267.  
  268.