; ======================================================================
; 			BUTTON PACKAGE
; ======================================================================


; =========
; Utilities
; =========

(de button.pixmap-copy (pixmap)	
    ; used colors (background/foreground) are without effect
    (pixmap-make 
	background
	pixmap foreground))

(de button.modify-property (list added-list)
    (with (var ()  j 0)
	  (while (setq var (# j added-list))
		 (setq list (# var list (# (+ 1 j) added-list)))
		 (setq j (+ 2 j)))
	  list))

(de button.enlarge-pixmap (pixmap width height)
    (with (foreground background)
	  (pixmap-make 
	      background
	      (pixmap-make width height) background
	      pixmap foreground)))

(de nop () ())

(de button.context-save (context)
    ;  (? "button.context-save, context: " context"\n\n\n")
    (with (
	   key ()
	   value ()
	   res ())
	  (for i context
	       (if (not key)
		   (setq key i)
		   (progn
			 (setq value 
			       (if (boundp key) (eval key)
				   i))
			 (setq res (+
				     res
				     (list 
					   key
					   (list 'quote value))))
			 (setq key ()))
	       ))
	  (setq trace 0)
	  res
    ))



; ============
; Generic part
; ============

; button.generic-make	to create a button
; ------------------
; 
; no argument
;
; Context:
;
;   for end-user (inherited from plug):
; 	property
; 	borderwidth
; 	borderpixel
; 	bordertile
; 	background
; 	menu 
; 	cursor
;
;   for middle-user:
; 	button.fsm
;	button.property-expression
; 

;(setq count 0)
(de button.generic-make ()			
    ;    (? "button " (setq count (+ 1 count)) "\n")
    (with (
	   fsm 
	   (default button.fsm button.push-fsm)
	   
	   property-expression
	   (default
		   button.property-expression 
		   button.push-property-expression)
	   
	   property
	   (+ (eval property-expression) property)
	  )
	  (plug-make button.default-pixmap)))





; ================
; Push button part
; ================

(de button.push-generic-make ()
    (with button.push-context
	  (button.generic-make)))

(setq button.push-context
    '(
      button.fsm	       		button.push-fsm
      button.property-expression	button.push-property-expression
     ))



; --------------
; push behaviour
; --------------

(setq button.push-behaviour
    (state-make
	(on (user-event 'initialize)
	    (progn 
		   (eval (# 'initializing wob-property))))
	(on (buttonpress any any)
	    (progn 
		   (eval (# 'pressed-drawing wob-property))
		   (eval (# 'press-action wob-property))))
	(on (buttonrelease any any)
	    (progn 
		   (eval (# 'normal-drawing wob-property))
		   (eval (# 'release-action wob-property))))
    ))

(setq button.push-fsm (fsm-make button.push-behaviour))



; ---------------
; Push properties
; ---------------

(setq button.push-property-expression
    '(+
       (button.push-semantic-property-make)
       (button.push-appearance-property-make)))



; Push semantic properties
; ========================

; Semantic Context:
;   for end-user:
; 	button.action		(default= no-action)
; 	button.trigger		('release or 'press; default= 'release)
; 
; 	button.press-action 	(default= no-action)
; 	button.release-action	(default= no-action)

(setq button.no-action ())

(de button.push-semantic-property-make ()
    (with (
	   trigger
	   (default button.trigger 'release) 
	   
	   action
	   (default button.action button.no-action)
	   
	   press-action
	   (default button.press-action button.no-action)
	   
	   release-action 
	   (default button.release-action button.no-action)
	  )
	  (if (= 'press trigger)
	      (setq press-action
		    (+ '(progn)
		       (list action)
		       (list press-action)))
	      (setq release-action
		    (+ '(progn)
		       (list action)
		       (list release-action))))
	  (list
	       'press-action press-action
	       'release-action release-action
	  )
    ))



; Push appearance properties
; ==========================

; push appearance context:
;   for end-user:
; 	button.dynamic-context-making
; 
;   for middle-user:
; 	button.static-context-saving
; 	button.pixmaps-making
;
;   for advanced middle-user:
; 	button.drawing-list
; 	button.pixmaps-updating

(setq button.default-pixmap (label-make "?"))
(setq button.default-bitmap button.default-pixmap)

(de button.push-appearance-property-make ()
    (with (
	   static-context (button.context-save 
				 (default
					 button.extern-context
					 button.push-explicit-extern-context))
	  )
	  (+
	    ; Drawing and Initialize procedures
	    ; IMPORTANT: Must be coherent with behaviour 
	    (default button.drawing-list button.default-drawing-list)
	    
	    ; Pixmaps or Datas to dynamically create Pixmaps
	    (if (and (boundp 'button.dynamic-context-making)
		     button.dynamic-context-making)
		; Dynamic initialization
		(list 
		      'static-context
		      static-context
		      
		      'dynamic-context-making
		      button.dynamic-context-making
		      
		      'pixmaps-updating
		      (default    
			  button.pixmaps-updating
			  button.default-pixmaps-updating)
		)
		; Initialization now
		(with static-context
		      (eval button.pixmaps-making))
	    ))))

;  defaults:
; ---------

(setq button.default-drawing-list
    '(
      initializing (progn
			 (eval (# 'pixmaps-updating wob-property))
			 (eval (# 'normal-drawing wob-property))
		   )
      normal-drawing (wob-tile (# 'normal-pixmap wob-property))
      pressed-drawing (wob-tile (# 'pressed-pixmap wob-property))
     ))
    
(setq button.default-pixmaps-making ())

(setq button.default-pixmaps-updating
    '(with (static-context (# 'static-context wob-property))
	   (with static-context 
		 (with (dynamic-context 
			   (eval (# 'dynamic-context-making
				  wob-property)))
		       (with dynamic-context
			     (wob-property 
				 (button.modify-property
					wob-property
					(eval 
					      (default
						      button.pixmaps-making
						      button.default-pixmaps-making
					      )))))))))

(setq button.default-dynamic-context-making
    ())

; This list must be added to particular extra context list
(setq button.common-extern-context
    (list
	 'button.pixmaps-making button.default-pixmaps-making
	 'button.pixmaps-updating button.default-pixmaps-updating	  
    ))
 






; Pixmap made by explicit pixmaps
; -------------------------------

; Context used
; 
; 	button.normal-pixmap
; 	button.pressed-pixmap

(de button.push-explicit-button-make ()
    (with button.push-explicit-intern-context
	  (button.push-generic-make)))

(setq button.push-explicit-extern-context
    (+ 
       button.common-extern-context
       (list
	    'button.normal-pixmap button.default-pixmap
	    'button.pressed-pixmap button.default-pixmap
       )))

(setq button.push-explicit-pixmaps-making
    '(list 
	   'normal-pixmap (default 
			      button.normal-pixmap 
			      button.default-pixmap)
	   'pressed-pixmap (default 
			       button.pressed-pixmap 
			       button.default-pixmap)
     ))

(setq button.push-explicit-intern-context
    '(
      button.extern-context button.push-explicit-extern-context
      button.pixmaps-making button.push-explicit-pixmaps-making
     ))





; Pixmap made by redrawed stencil
; ------------------------------

; Context
;   for end-user:
; 	button.stencil-bitmap
; 	button.stencil-label
; 	font
; 	foreground
;	background
; 	button.minimum-width		
; 	button.minimum-height
; 
;   for middle-user:
; 	button.normal-redraw
; 	button.pressed-redraw


; Utilities

; enlarge pixmap if necessary, accordingly with 
; button.minimum-width and button.minimum-heigh
(de button.minimize-pixmap (pixmap)
    (if (or (< (width pixmap) button.minimum-width)
	    (< (height pixmap) button.minimum-height))
	(button.enlarge-pixmap 
	       pixmap 
	       (max 1 button.minimum-width)
	       (max 1 button.minimum-height))
	pixmap))

(de button.stencil-pixmap-make ()
    (with (
	   stencil (button.stencil-description-make)
	  )
	  (if stencil
	      (eval (+ (list 'pixmap-make
			     background)
		       stencil))
	      button.default-pixmap)))
		

(de button.stencil-description-make ()
    (with (
	   stencil ()
	   stencil-bitmap button.stencil-bitmap
	   stencil-label button.stencil-label
	  )
	  (if stencil-bitmap
	      (setq stencil
		    (+ stencil
		       (list
			    stencil-bitmap
			    foreground))))
	  (if stencil-label
	      (setq stencil
		    (+ stencil
		       (list
			    (label-make stencil-label)
			    foreground))))
	  stencil))
		
(de button.surround (pixmap top-left-color bottom-right-color x1 y1 x2 y2)
;    (? pixmap " " top-left-color  " " bottom-right-color  " "
;       x1 " " y1 " " x2 " " y2 "\n")
    (with (foreground top-left-color)
	  (draw-line pixmap x1 y1 x2 y1)
	  (draw-line pixmap x1 y1 x1 (- y2 1))
    )
    (with (foreground bottom-right-color)
	  (draw-line pixmap x2 y2 x1 y2)
	  (draw-line pixmap x2 y2 x2 (+ y1 1)))
)



; 2d utilities

(de button.2d-normal-redraw (pixmap)
    (with (
	   width (width pixmap)
	   height (height pixmap))
	  (button.surround
		 pixmap
		 foreground
		 foreground
		 0 0 (- width 1) (- height 1))
    ))

		
(de button.2d-pressed-redraw (pixmap)
    (with (
	   width (width pixmap)
	   height (height pixmap))
	  (button.surround
		 pixmap
		 foreground
		 foreground
		 0 0 (- width 1) (- height 1))
	  (button.surround
		 pixmap
		 foreground
		 foreground
		 1 1 (- width 2) (- height 2))
	  (button.surround
		 pixmap
		 foreground
		 foreground
		 2 2 (- width 3) (- height 3))
    ))
		
		

; 3d utilities

(de button.3d-normal-redraw (pixmap)
    (with (
	   width (width pixmap)
	   height (height pixmap))
	  (button.surround
		 pixmap
		 white
		 black
		 0 0 (- width 1) (- height 1))
	  (button.surround
		 pixmap
		 white
		 black
		 1 1 (- width 2) (- height 2))
    ))
		
(de button.3d-pressed-redraw (pixmap)
    (with (
	   width (width pixmap)
	   height (height pixmap))
	  (button.surround
		 pixmap
		 black
		 white
		 0 0 (- width 1) (- height 1))
	  (button.surround
		 pixmap
		 white
		 black
		 1 1 (- width 2) (- height 2))
    ))
		
(de button.old-3d-pressed-redraw (pixmap)
    (with (
	   width (width pixmap)
	   height (height pixmap))
	  (button.surround
		 pixmap
		 black
		 white
		 0 0 (- width 1) (- height 1))
    ))
		


; Definitions

(de button.push-redrawed-button-make ()
    (with button.push-redrawed-intern-context
	  (button.push-generic-make)))

(setq button.stencil-extern-context
    (list 
	  'button.stencil-bitmap button.default-bitmap
	  'button.stencil-label ()
	  'font	font
	  'foreground foreground
	  'background background
    ))

(setq button.push-redrawed-extern-context
    (+ 
       button.common-extern-context
       button.stencil-extern-context
       (list
	    'button.minimum-width 0
	    'button.minimum-height 0
	    'button.normal-redraw button.2d-normal-redraw
	    'button.pressed-redraw button.2d-pressed-redraw
       )))

(setq button.push-redrawed-pixmaps-making
    '(with (
	    stencil-pixmap (button.minimize-pixmap
				  (button.stencil-pixmap-make))
	   )
	   (list
		'normal-pixmap
		(with (pixmap (button.pixmap-copy stencil-pixmap))
		      (button.normal-redraw pixmap)
		      pixmap)
		
		'pressed-pixmap
		(with (pixmap stencil-pixmap) 
		      ; for this last usage stencil-pixmap itself is used
		      ;  instead of a copy
		      (button.pressed-redraw pixmap)
		      pixmap)
	   )))
		
(setq button.push-redrawed-intern-context
    '(
      button.extern-context button.push-redrawed-extern-context
      button.pixmaps-making button.push-redrawed-pixmaps-making
      borderwidth 0
     ))
		



		
; ==================
; End User Functions
; ==================

; Context (for end-user):
;   semantic:
; 	button.action		(default= no-action)
; 	button.trigger		('release or 'press; default= 'release)
; 
; 	button.press-action 	(default= no-action)
; 	button.release-action	(default= no-action)
;
;   appearance:
; 	button.stencil-label	[1]
; 	button.stencil-bitmap	[1]
; 	font			[1]
; 	foreground		[1]
;	background		[1]
; 	button.minimum-width	[1]
; 	button.minimum-height	[1]
; 	cursor
; 
;   stuff:
; 	property
; 	menu 
; 	button.dynamic-context-making
; 		context marked by [1] may be updated by initialize
; 		eg: 	button.dynamic-context-making
; 		    	'(button.stencil-label machine-name)
; 		This expression may be used to update property 
;		(see xload button)


(de button.push-2d-redrawed-button-make ()
    (button.push-redrawed-button-make))

(de button.push-3d-redrawed-button-make ()
    (with (
	   button.normal-redraw button.3d-normal-redraw
	   button.pressed-redraw button.3d-pressed-redraw
	  )
	  (button.push-redrawed-button-make)))

(de button.push-old-3d-redrawed-button-make ()
    (with (
	   button.normal-redraw button.3d-normal-redraw
	   button.pressed-redraw button.old-3d-pressed-redraw
	  )
	  (button.push-redrawed-button-make)))

(de button.make ()
    (if (and (boundp 'look-3d) look-3d) 
	(button.push-old-3d-redrawed-button-make)
	(button.push-2d-redrawed-button-make)))

; ----------------------------------------------------------------------


; ==================
; Predefined buttons
; ==================

; Context:
;   button.mode   'graphic (default), or 'english 

(de button.iconify ()
    (with (
	   button.mode (default button.mode 'graphic)
	  )
	  (with-eval
	      (+
		'(
		  button.action '(iconify-window)
		 )
		(if (= 'graphic button.mode)
		    '(button.stencil-bitmap "iconify-vb")
		    '(button.stencil-label "iconify-vb"))
	      )
	      (button.make))))

(setq kill-window-yes-no-menu
    (with (fsm pop-fsm menu ())
	  (menu-make
	      (item-make "yes" (kill-window))
	      (item-make "no"  ())
	  )))

(de button.kill ()
    (with (
	   button.mode (default button.mode 'graphic)
	  )
	  (with-eval
	      (+
		'(
		  button.press-action 
		  '(progn 
			  (eval (# 'normal-drawing wob-property))
			  (pop-menu kill-window-yes-no-menu 1))
		 )
		(if (= 'graphic button.mode)
		    '(button.stencil-bitmap "kill")
		    '(button.stencil-label "kill"))
	      )
	      (button.make))))

(de button.lower ()
    (with (
	   button.mode (default button.mode 'graphic)
	  )
	  (with-eval
	      (+
		'(
		  button.action '(lower-window)
		 )
		(if (= 'graphic button.mode)
		    '(button.stencil-bitmap "lower")
		    '(button.stencil-label "lower"))
	      )
	      (button.make))))

(de button.raise ()
    (with (
	   button.mode (default button.mode 'graphic)
	  )
	  (with-eval
	      (+
		'(
		  button.action '(raise-window)
		 )
		(if (= 'graphic button.mode)
		    '(button.stencil-bitmap "raise")
		    '(button.stencil-label "raise"))
	      )
	      (button.make))))




; 	------------------------------------
; 	Utilities for xterm and xload buttons
; 	------------------------------------

(de get-current-machine-name ()
    ; <<< to ameliorate
    window-machine-name)
		      
(setq rxterm-font-name-list
    '("screen.r.7"		; 0
      "cour.r.10"		; 1
      "8x13"			; 2
      "vania9x13"		; 3
      "9x15"			; 4
      "serif.r.16"		; 5
      "cour.b.18"		; 6
      "cour.b.24"		; 7
     ))
    
(setq default-font-number 1)

(de rxterm-with-selected-font (machine)
    (setq exec.machine machine)
    (exec.xterm))
;(de rxterm-with-selected-font (machine)
;    ; IMPORTANT:
;    ;    machine is memorised in a global variable (exec.machine)
;    ;    because this function just pops a menu 
;    ;    and action will be executed asynchronously
;    (setq exec.machine machine)
;    (pop-menu rxterm-with-selected-font-pop default-font-number))

;(setq rxterm-with-selected-font-pop
;    (with (
;	   fsm pop-fsm
;	   items '(menu-make)
;	  )
;	  (for font-name rxterm-font-name-list
;	       (setq items
;		     (+ items
;			(list
;			     (list 'with 
;				   (list 'item-font
;					 (list 'quote
;					       (font-make font-name)))
;				   (list 'item-make
;					 font-name
;					 (list 'with
;					       (list 'exec.font-name 
;						     (list 'quote font-name))
;					       '(exec.xterm))))))))
;	  (eval items)))




(de button.xload ()
    (with (
	   button.mode (default button.mode 'graphic)
	  )
	  (if (= 'graphic button.mode)
	      (with (
		     button.action
		     '(with (exec.machine (eval (# 'current-machine-name wob-property)))
			    (exec.xload))
		     
		     button.dynamic-context-making
		     '(with (current-machine-name (get-current-machine-name))
			    (wob-property
				(button.modify-property
				       wob-property
				       (list
					    'current-machine-name
					    current-machine-name)))
			    ())
		     button.stencil-bitmap "xload"
		    )
		    (button.make))
	      (with (
		     button.action
		     '(with (exec.machine (eval (# 'current-machine-name wob-property)))
			    (exec.xload))
		     
		     button.dynamic-context-making
		     '(with (current-machine-name (get-current-machine-name))
			    (wob-property
				(button.modify-property
				       wob-property
				       (list
					    'current-machine-name
					    current-machine-name)))
			    (list 'button.stencil-label 
				  (+ "load " current-machin)))
		    )
		    (button.make)))))
	       
(de button.xterm ()
    (with (
	   button.mode (default button.mode 'graphic)
	  )
	  (if (= 'graphic button.mode)
	      (with (
		     button.press-action 
		     '(progn
			    (eval (# 'normal-drawing wob-property))
			    (rxterm-with-selected-font 
				(eval (# 'current-machine-name 
				       wob-property))))
		     
		     button.dynamic-context-making
		     '(with (current-machine-name (get-current-machine-name))
			    (wob-property
				(button.modify-property
				       wob-property
				       (list
					    'current-machine-name
					    current-machine-name)))
			    ())
		     button.stencil-bitmap "xterm")
		    (button.make))
	      (with (
		     button.press-action
		     '(progn
			    (eval (# 'normal-drawing wob-property))
			    (rxterm-with-selected-font 
				(eval (# 'current-machine-name 
				       wob-property))))
		     
		     button.dynamic-context-making
		     '(with (current-machine-name (get-current-machine-name))
			    (wob-property
				(button.modify-property
				       wob-property
				       (list
					    'current-machine-name
					    current-machine-name)))
			    (list 'button.stencil-label current-machine-name))
		    )
		    (button.make)))))
	       
; ======================================================================

(provide 'vb-button)