;;;File:  widgets.gwm -- various widgets for decorations

;;Author: Brian L. Kahn
;;Not for sale or resale, distribution unlimited
;; modified by colas for more customizability

(load "cursor-names.gwm")
(defaults-to

  widget.bar-cursor
  (cursor-make XC_fleur)

  widget.menu-cursor
  (cursor-make XC_crosshair)

  widget.scroll-cursor
  (cursor-make XC_sb_v_double_arrow)

  widget.scroll-up-cursor
  (cursor-make XC_sb_up_arrow)

  widget.scroll-down-cursor
  (cursor-make XC_sb_down_arrow)

  widget.scroll-index-cursor
  (cursor-make XC_sb_right_arrow)

  widget.weave 
  (pixmap-make "/usr/include/X11/bitmaps/cross_weave")

  widget.gray
  (pixmap-make "/usr/include/X11/bitmaps/gray")

  widget.lt-gray
  (pixmap-make "/usr/include/X11/bitmaps/light_gray")

  widget.black
  (pixmap-make "/usr/include/X11/bitmaps/black")

  widget.font
  (font-make "widget")

  widget.Bfont
  (font-make "widgetBold")

  widget.foreground
  black

  widget.background
  white

  widget.name-font
  widget.font

  widget.name-background
  widget.background
  
  widget.name-foreground
  widget.foreground

  widget.close-pixmap
  (pixmap-make widget.background "close-18.xbm" widget.foreground)
)

;(: widget.font  (font-make "*clean-medium*--10*c-60*"))
;(: widget.Bfont (font-make "*clean-bold*--10*c-60*"))

(setq widget.invert-color (bitwise-xor widget.foreground widget.background))

;PROGRAMMING
;===========


(defun widget:message message
  ;; put "who what when why"  into property for this widget
  (with (output (+ "(" ;who
		   (or (# 'name message) (# 'name wob-property) "widget")
		   " " ;what
	(if (= 0 (bitwise-and current-event-modifier with-shift))
		   (itoa (current-event-code))
	  (itoa (+ 3 (current-event-code)))
	)
		   " " ;when
		   (itoa (current-event-modifier))
		   " " ;why
		   (or (# 'message message) (# 0 message) "no-message")
		   ")"
		   ))
	(set-x-property (or (# 'widget message) (# 'widget wob-property))
			output)
	))


(: widget:scrollbar-fsm
   (fsm-make
    (: inactive 
       (state-make
	(on (buttonpress 1 any)
	    (wob-cursor widget.scroll-up-cursor)
	    active)
	(on (buttonpress 1 with-shift)
	    (wob-cursor widget.scroll-index-cursor)
	    active)
	(on (buttonpress 2 any)
	    (wob-cursor widget.scroll-index-cursor)
	    active)
	(on (buttonpress 3 any)
	    (wob-cursor widget.scroll-down-cursor)
	    active)
	))
    (: active
       (state-make
	(on (buttonrelease any any)
	    (progn
	      (wob-cursor widget.scroll-cursor)
	      (widget:message
	       (itoa (/ (* 100 (current-event-relative-y))
			(height wob)))))
	    inactive)
	))
    ))

(: widget:scrollbar-make
   (with (fsm widget:scrollbar-fsm
	  borderwidth 1
	  tile widget.weave
	  cursor widget.scroll-cursor
	  property (list 'widget "scrollbar" 'name "leftside")
	  bar-min-width 14)
	 (bar-make)))

(: widget:Dmenu-fsm
  (fsm-make
    (: menu-off
      (state-make
	(on enter-window
	  (wob-tile (# 'on-pix wob-property)))
	(on leave-window
	  (wob-tile (# 'off-pix wob-property)))
	(on (buttonpress menu-button any)
	  (progn
	    (wob-tile (# 'off-pix wob-property))
	    (if wob-menu
	      (pop-menu))
	))
	(on (buttonpress any any) (progn
	    (setq invert-color widget.invert-color)
	    (wob-invert)
	  )
	  menu-on)
    ))
    (: menu-on
      (state-make
	(on (buttonrelease any any)
	  (progn 
	    (setq invert-color widget.invert-color)
	    (wob-invert)
	    (eval (# 'action wob-property)))
	  menu-off)
	(on leave-window
	  (progn
	    (setq invert-color widget.invert-color)
	    (wob-invert)
	    (wob-tile (# 'off-pix wob-property)))
	  menu-off)
    ))
))
    
(: widget:Dmenubar-fsm
   (fsm-make
    (state-make
     (on (user-event 'focus-in)
	 (wob-tile widget.gray))
     (on (user-event 'focus-out)
	 (wob-tile widget.lt-gray))
     standard-title-behavior)))

(defun widget:Dmenubar-make (menulist)
  (with (fsm widget:Dmenubar-fsm
      tile widget.gray 
      plug-separator 8
      borderwidth 1
      cursor widget.bar-cursor
      bar-min-width 2
      bar-max-width 24
      menulist (+
	(list widget.close-plug)
	'(())
	menulist
	'(()()()())
	(list '(widget.name-plug))
      )
    )
    (apply 'bar-make menulist)
)))

(setq widget.close-plug (with (
      fsm (fsm-make
	(state-make
	  (on (buttonpress any alone) (delete-window))
	  standard-title-behavior
	  standard-behavior
      ))
      borderwidth 0
    )
    (plug-make widget.close-pixmap)
))

(defun widget.name-plug () (with (
      fsm (fsm-make
	(state-make
	  (on (user-event 'name-change)
	    (with (
		font widget.name-font
		background widget.name-background
		foreground widget.name-foreground
	      )
	      (wob-tile (label-make (window-name))))
	  )
	  standard-title-behavior
	  standard-behavior
      ))
      font widget.name-font
      background widget.name-background
      foreground widget.name-foreground
      borderwidth 0
    )
    (plug-make (label-make window-name))
  )  
)))

(defun widget:Dmenu-make (args)
  ;; Make a plug that drops a menu.  
  ;; ARGS is '(name (item ... item))
  ;; item is ("label" action)
  ;; action is "(elisp-function args)" or (wool-function args)
  (with (name (# 0 args)
      widget "Dmenu"
      pop-item.background widget.background
      pop-item.foreground widget.foreground
      item-list (# 1 args)
      action (widget:action (# 1 (# 0 item-list)))
      menu (widget:menu-make item-list)
      fsm widget:Dmenu-fsm
      borderwidth 1
      cursor widget.menu-cursor
      property (list 'widget widget
	'name name 
	'action action
	'off-pix (with (
	    foreground widget.foreground
	    background widget.background
	  )
	  (label-make name widget.font)
	)
	'on-pix (with (
	    foreground widget.background
	    background widget.foreground
	  )
	  (label-make name widget.Bfont))
      )
    )
    (plug-make (# 'off-pix property))))


(defun widget:menu-make (item-list)
  (with (
      property (+ property (list 'invert-color
	  (bitwise-xor pop-item.foreground pop-item.background)
      ))
    )
  (menu-make-from-list
   (mapfor item item-list
	   (list 'item-make 
		 (# 0 item) 
		 (widget:action (# 1 item)))
))))


; action is "(elisp-function args)" or (wool-function args)
(defun widget:action (action)
  (cond ((eq 'string (type action))
	 (list 'widget:message ''message action))
	((eq 'list (type action))
	 action)
	(t (progn (? "Invalid widget:action - ")
		  (? action)))
	))




(: widget:Pmenu-fsm 
  (fsm-make 
    (setq initial (state-make
	(on enter-window-not-from-grab		; init menu colors
	  (: invert-color (bitwise-xor pop-item.foreground
	      pop-item.background))
	  realized			; then go in normal mode
	  )
	(on (buttonrelease any any)	; ButRel before menu appeared 
	  (progn			; then call default action
	    (with (calling-wob wob-parent Menu wob)
	      (setq std-popups.action
		(# 'action wob-property))
	      (wob wob-parent)
	      (send-user-event 'depop Menu t)
	      (wob calling-wob)
	      (eval std-popups.action))
	  )
	  waiting-for-enter-window	; must trap the actual menu map
	)
	(on (user-event 'depop) (unpop-menu) initial)      
    ))
    (setq realized (state-make
	(on (buttonrelease any any)	; ButRel outside of menu
	    (progn
	      (with (quit (# 'quit wob-property))
		    (if quit (eval quit)))
	      (unpop-menu)
	      )
	    initial)
	(on (user-event 'depop) (unpop-menu) initial)      
    ))
    (setq waiting-for-enter-window (state-make
	(on enter-window-not-from-grab () initial)
    ))
))


(defun widget:Pmenu-make spec
  ;; Make a pop-up menu that returns index of selection
  (with (
      fsm widget:Pmenu-fsm
      pop-item.background widget.background
      pop-item.foreground widget.foreground
      item-list (# 0 spec) 
      property (list 'widget "Pmenu"
	'name "Pmenu"
	'quit '(widget:message 'message "nil" 'widget 'Pmenu)
	'action '(widget:message 'message 0 'widget 'Pmenu)
      )
      index -1 ; starts at 0, pre-incremented
    )
    (eval 
      (+ '(menu-make)
	(mapfor item item-list
	  (list 'item-make 
	    item
	    (list 'widget:message
	      ''message (itoa (: index (+ index 1)))
	      ''widget "Pmenu")
    ))))
))




;; for convenience in defining Dmenus
(defunq Dmenu: (Dmenu.name arglist)
  ;; assign DMENU.NAME equal to the Dmenu created using ARGLIST.
  (set Dmenu.name (eval (list 'widget:Dmenu-make arglist))))