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