;;;; A -*-Scheme-*- demo using the HyperNeWS interface: look and learn.
;;;; Russell Ritchie, Iain Graham Consultants, <russell@uk.co.igc>.
;;;; Mon Nov 19 15:20:55 1990.

(require 'HyperNeWS)

;;; The following piece of code is a simple program illustrating the use of the
;;; various kinds of objects. A number of message handlers are specified; 
;;; these are called when matching messages arrive.

(define (demo-run)
  (let ((stack (hns-interface-object '() 'stack "SchemeDemo")))
    (let ((menu (hns-interface-object stack 'pulldown "m1"))
	  (text (hns-interface-object stack 'edittext "t1"))
	  (xslider (hns-interface-object stack 'slider "XSlider"))
	  (yslider (hns-interface-object stack 'slider "YSlider"))
	  (star (hns-interface-object stack 'button "Star"))
	  (stop (hns-interface-object stack 'button "StopButton"))
	  (color (hns-interface-object stack 'colorselect "cs1"))
	  (check (hns-interface-object stack 'button "cb1")))
      (hns-clear-interests)		; Flush any old interests...
      ;; Remember, in Scheme symbol function/value slots are one: thus
      ;; we do NOT want to quote the handler procedures, otherwise
      ;; when they are eventually fed to apply they will not be "PROCEDURE?"s.
      (hns-set-handler menu "Action" menu-handler)
      (hns-set-handler text "WordAction" text-handler)
      (hns-set-handler xslider "Action" xslider-handler)
      (hns-set-handler yslider "Action" yslider-handler)
      (hns-set-handler star "Action" star-handler)
      (hns-set-handler color "Action" color-handler)
      (hns-set-handler check "Action" check-handler)
      (hns-set-handler stop '() demo-stop)
      (hns-set-handler '() '() hns-debug-handler)
      (hns-start)			; Start HyperNeWS if it's not started.
      (hns-flush-input)			; Flush any pending input.
      (hns-connect stack)		; Connect to the "SchemeDemo" stack.
      (hns-show stack)			; Make sure it's visible.
      (hns-run))))				; Sit 'n' wait.

(define (demo-stop x)
  (format #t "~%Stop-button-handler: hiding SchemeDemo Stack,")
  (hns-hide (hns-mystack (hn-first x)))
  (format #t "~%Stop-button-handler: closing HyperNeWS connection,")
  (hns-stop)
  (format #t "~%Stop-Button-Handler: exiting Scheme process.")
  (exit 0))

(define yes-or-no-p hns-confirm)

(define (menu-handler selection)
  (yes-or-no-p
   (format #f "~%Menu-handler: received selection ~a." (hn-third selection))))

(define (text-handler selection)
  (yes-or-no-p
   (format #f "~%Text-handler: Double Click on ~a." (hn-third selection))))

(define (xslider-handler value)
  (let ((stack (hns-mystack (hn-first value))))
    (hns-move stack (list (hn-third value) (hns-get stack "ScreenY")))
    (yes-or-no-p
     (format #f "~%X-Slider-handler: Got new value - ~a." (hn-third value)))))

(define (yslider-handler value)
  (let ((stack (hns-mystack (hn-first value))))
    (hns-move stack (list (hns-get stack "ScreenX") (hn-third value)))
    (yes-or-no-p
     (format #f "~%Y-Slider-handler: Got new value - ~a." (hn-third value)))))

(define (star-handler value)
  (if (yes-or-no-p "Twinkle twinkle little star?")
      (let ((star (hn-first value)))
	(do ((val (hn-third value) (1+ val)))
	    ((equal? val 5) (hns-set-value star 0)); Go back to initial colour.
	  (hns-set-value star val)))))

(define (color-handler value)
  (yes-or-no-p
   (format #f "~%Colour-handler: New Colour = ~a." (hn-third value))))

(define (check-handler value)
  (yes-or-no-p
   (format #f "Check-box-handler: Box is now ~a."
	   (if (equal? (hn-third value) 0) "not checked" "checked"))))

(format #t "~%Type (demo-run) to run the demo...")