;;;;                          Hyper-*-Scheme-*- 1.0
;;;; 
;;;;    Scheme wrappers for HyperNeWS<=>Scheme 'C' interface primitives.
;;;;	See the HyperNeWS manual for a description of the HyperNeWS methods.   
;;;;    Russell Ritchie, <russell@uk.co.igc>, Mon Nov 19 13:01:28 1990.

(require 'macros)

(require 'HyperNeWS.o)			; The C low-level primitives
(provide 'HyperNeWS)

;;; A few little hacks that eased porting from Emacs-Lisp:

(define (string-downcase string)
  (let* ((len (string-length string))
	 (newstring (make-string len)))
    (do ((i 0 (1+ i)))
	((eqv? i len) newstring)
      (string-set! newstring i (char-downcase (string-ref string i))))))

(define (string-upcase string)
  (let* ((len (string-length string))
	 (newstring (make-string len)))
    (do ((i 0 (1+ i)))
	((eqv? i len) newstring)
      (string-set! newstring i (char-upcase (string-ref string i))))))

(define (yes-or-no-p prompt)
  (format #t "~%~a (yes or no): " prompt)
  (do ((answer (read) (read)))
      ((or (eqv? answer 'yes) (eqv? answer 'no))
       (eqv? answer 'yes))
    (format #t "~%Please answer yes or no. ~a (yes or no): " prompt)))

;;; Non-#f inhibits the initial HyperScheme startup dialogue.
;;; This is for use in your personal init file, once you are familiar
;;; with the contents of the startup dialogue.

(if (not (bound? 'inhibit-hnstartup-message))
    (define inhibit-hnstartup-message #f))

(define-macro (hn-first lst) (list 'car lst)) ; To retain a little CLness.
(define-macro (hn-second lst) (list 'cadr lst))
(define-macro (hn-third lst) (list 'caddr lst))

;;; High level Scheme functionality.

(define *hns-interests* '())  ; "Where HyperNeWS interests are registered."
(define (hns-clear-interests)
  ;; ``Undeclare'' all interests in anything: remove all handlers.
  (set! *hns-interests* '()))

(define (hns-interface-object stack type name)
  ;; Register a HyperNeWS interface object for STACK of TYPE called NAME.
  ;; When declaring stacks, the first argument is '().
  (if (not (or (and stack (symbol? stack)) (symbol? name)))
      (let ((type-nr
	     ;; Rationalise object TYPE and TYPE-NR, this is mildly gross...
	     (cond ((number? type)
		    ;; TYPE is a number: remember it and bash a name into TYPE.
		    (let ((type-nr type))
		      (set! type (hnscm-obj-type-name type-nr))
		      type-nr))
		   ((symbol? type)
		    ;; TYPE is a symbol: string-caseify it and get it's number.
		    (set! type (string-downcase (symbol->string type)))
		    (hnscm-obj-type-name type)) 
		   ((string? type)
		    ;; TYPE is a string: downcaseify it and get it's number.
		    (set! type (string-downcase type))
		    (hnscm-obj-type-name type))
		   (t (error "Unknown HyperNeWS object type."))))) ; Give up...
	(if (equal? type "stack")
	    (list "stack" name)
	    (list (if (pair? stack) (hn-second stack) stack)
		  (list type-nr name))))))

(define (hns-set-handler from msg proc)
  ;; Set the handler of object FROM for MSG to be PROCEDURE.
  ;; Either FROM or MSG (or both) can be '() (see below) allowing handlers 
  ;; to be defined in an object-specific or message-specific manner (or both).
  ;; 
  ;; Handlers are called IN THE ORDER they are registered. 
  ;; They should expect single list argument, which will comprise:
  ;;    (append '(FROM MSG) (or MSG-ARGS (list '())))
  ;; 
  ;; A handler should return non-#f if it considers itself to have ``handled'' 
  ;; the message, or #f if later (presumably more general) handlers should be 
  ;; given an opportunity to ``have a go''.
  ;; 
  ;; NB: you will NEVER know what a handler returned, unless you do
  ;; something ugly. 
  ;; 
  ;; Try registering the HyperNeWS/Scheme debug handler as the last one, e.g.:
  ;; 
  ;;    (hns-set-handler '() '() hns-debug-handler)
  ;;
  ;; NB. In Scheme the function and value slots of symbols are the same:
  ;; DO NOT QUOTE THE PROCEDURE NAME, otherwise you can't apply it!
  ;; 
  ;; This facility allows the Scheme programmer to take advantage of the
  ;; HyperNeWS class hierarchy (see Hyperman, the on-line manual, for
  ;; details and pictures) to overload a single message with
  ;; appropriate functionality in the typical object-oriented fashion
  ;; (see any CLOS/flavors/Eiffel/SmallTalk textbook for more
  ;; information on object-oriented programming). Here is a short
  ;; example code segment:
  ;; 
  ;;  ;; ...start up code, and object registration...
  ;;  ;; When foo says Bar call foo-bar
  ;;  (hns-set-handler foo \"Bar\" foo-bar) 
  ;;  ;; ...other handlers for other messages from foo, if any
  ;;  ;; If foo-bar returned #f, try calling foo-any with same args as foo-bar
  ;;  (hns-set-handler foo '() foo-any) 
  ;;  ;; ...other object-message, and object-any handlers...
  ;;  ;; If foo-any returned #f too, have another go with bar-handler 
  ;;  (hns-set-handler '() \"Bar\" bar-handler)
  ;;  ;; ...other any-object, specific-message handlers...
  ;;  ;; ``Bottom-out'' all object-message pairs: call the any-handler
  ;;  (hns-set-handler '() '() any-handler)
  ;;  ;; Call the method-dispatch loop, and wait for one of the
  ;;  ;; handlers to throw. 
  ;;  (catch 'exit (hns-run))
  ;;  ;; ...clean-up and chill-out...

  (set! *hns-interests*
	(append *hns-interests* (list (list (list from msg) proc)))))

(define (hns-call-handlers from msg . args)
  ;; Call the handler(s) of object FROM for MSG, if any, with optional ARGS.
  (do ((handlers (hns-get-handlers from msg) (cdr handlers)))
      ((or (null? handlers)
	   (apply (car handlers)
		  (list (append (list from msg) (if args (car args)))))) #t)))

(define (hns-get-handlers from message)
  ;; Return the handlers of object FROM for MESSAGE, if any, or nil.
  ;; 
  ;; This is made needlessly complex and slow by the prime directive:
  ;; because any FROM MESSAGE pair could be potentially matched by 
  ;; from-* and *-message handlers, and because these handlers must be called 
  ;; IN THE ORDER they were defined, we have to check the registration order of
  ;; the from-* and *-message handlers if both are defined.
  ;; 
  ;; In reality, this means there is enormous scope for speed-up here.
  (let ((event-fn (assoc (list from message) *hns-interests*))
	(from-*-alist (assoc (list from '()) *hns-interests*))
	(*-message-alist (assoc (list '() message) *hns-interests*))
	(any-fn (assoc (list '() '()) *hns-interests*)))
    (if from-*-alist
	(if *-message-alist
	    (if (memq from-*-alist (memq *-message-alist *hns-interests*))
		;; *-MESSAGE registered before FROM-* 
		(append (if event-fn (cdr event-fn))
			(cdr *-message-alist)
			(cdr from-*-alist)
			(if any-fn (cdr any-fn)))
	      (append (if event-fn (cdr event-fn))
		      (cdr from-*-alist)
		      (cdr *-message-alist)
		      (if any-fn (cdr any-fn))))
	  (append (if event-fn (cdr event-fn))
		  (cdr from-*-alist)
		  (if any-fn (cdr any-fn))))
      (append (if event-fn (cdr event-fn))
	      (if *-message-alist (cdr *-message-alist))
	      (if any-fn (cdr any-fn))))))

(define (hns-debug-handler msg)
  ;; Use FORMAT to show (and help debug) MSG.
  (let* ((sender (hn-first msg))
	 (msg-name (hn-second msg))
	 (args (hn-third msg))
	 (stack? (equal? (hnscm-obj-type-name (hn-first sender)) "stack"))
	 (stack (if stack? "HyperNeWS" (hn-second (hns-mystack sender))))
	 (type (if stack?
		   "stack"
		 (hnscm-obj-type-name (hn-first (hn-second sender)))))
	 (name (if stack? (hn-second sender) (hn-second (hn-second sender)))))
    (format
     #t "~%Received Message: ~s:~s:~s ~s ~s." stack type name msg-name args)
    (flush-output-port)))

(define (hns-ignore msg) #t)  ; Ignore MSG in a pre-emptive fashion.

;;; General routines for setting and getting object values

(define (hns-set-value target value)
  ;; Set object TARGET's value to VALUE.
  (if (eqv? (hns-object-type target) (hnscm-obj-type-name "edittext"))
      (hns-set-text target (if (pair? value) value (list value)))
    (hns-send target "SetValue" (if (pair? value) value (list value)))))

(define (hns-get-value target)
  ;; Get object TARGET's current value.
  (hns-get target "Value")) 

;;; Low level interface between Scheme and HyperNeWS.

;; Checks on object types etc.

(define (hns-stack? obj)
  ;; Return t iff OBJECT is a stack.
  (equal? (hn-first obj) "stack"))

(define (hns-object obj)
  ;; Return non-nil if OBJECT is a HyperNeWS object.
  (if (pair? obj)
      (if (hns-stack? obj)
	  (string? (hn-second obj))
	(and (string? (hn-first obj))
	     (string? (hn-second (hn-second obj)))
	     (hnscm-obj-type-name (hn-first (hn-second obj)))))))

(define (hns-object-type obj)
  ;; Return OBJECT's HyperNeWS type (as a string).
  (if (hns-object obj)
      (if (hns-stack? obj)
	  "stack"
	(hn-first (hn-second obj)))))

(define (hns-object-name obj)
  ;; Returns OBJECT's HyperNeWS name (as a string).
  (if (hns-object obj)
      (if (hns-stack? obj)
	  (hn-second obj)
	(hn-second (hn-second obj)))))

(define (hns-object-stack object)
  ;; Return the stack OBJECT is on.
  (hns-mystack object))

(define (hns-card-object obj)
  ;; Return non-nil if OBJECT is a card object.
  (let ((nr (hns-object-type obj))
	(card-nr (hnscm-obj-type-name "card")))
    (> nr card-nr)))

(define (hns-mystack object)
  ;; Return OBJECT's stack or OBJECT if it is a stack.
  (if (hns-object object)
      (if (hns-stack? object)
	  #f
	  (list "stack" (hn-first object)))))

;;; Control Routines.

(define (hns-start . name)
  ;; Start the HyperNeWS connection, using optional NAME (default "scheme").
  (hnscm-start (if name (car name) "scheme")))

(define (hns-stop)			; Stop the HyperNeWS connection.
  (hnscm-stop))
  
(define (hns-flush)			; Flush output from HyperNeWS.
  (hnscm-flush))

(define (hns-flush-input)		; Flush input from HyperNeWS.
  (hnscm-flush-input))

(define (hns-ok)			; #t if HyperNeWS connection is ok.
  (hnscm-ok))

(define (hns-verbose . state)
  ;; Toggle HyperNeWS verbosity state (0/1), and return the new state.
  (if (and state (car state)) (hnscm-verbose 1) (hnscm-verbose 0)))

(define (hns-clear) (hnscm-clear))	; Clear the HyperNeWS stack.

(define (hns-ps PostScript)
  ;; Send POSTSCRIPT (a string) directly to the NeWS server.
  (hnscm-ps PostScript))

;;; The main event loop.

(define (hns-run . timeout)
  ;; Run forever processing events, pass optional arg TIMEOUT (-1) to hns-read.
  (do ()
      ((not (hns-interpret (hns-read (if timeout (car timeout) -1)))) #t)))

(define (hns-interpret data)
  ;; Interpret whatever HyperNeWS read said, don't call this directly.
  (if (or (null? data) (equal? data "timeout"))
      #f
    (hns-call-handlers (hn-first data) (hn-second data) (hn-third data))))

;;; High level I/O

(define (hns-read . delay)
  ;; Read something from HyperNeWS. Optional arg DELAY (-1) is read timeout.
  (if (not delay)
      (hns-clear))
  (and (hnscm-read (if delay (car delay) -1)) (hnscm-get '())))

(define (hns-write arg . type)
  ;; Write ARG to HyperNeWS. Optional arg TYPE tells HyperNeWS what it is.
  (hns-clear)
  (hnscm-put arg (and type (car type)))
  (hnscm-write))

;; Sending Messages.

(define (hns-send object message . args)
  ;; Send MESSAGE to HyperNeWS. Optional message ARGS can be sent as well.
  (hns-clear)
  (hnscm-put (if (hns-object object)
		 (cons object (append (list message) args))
	       object)
	     "message")
  (and (hnscm-write) (hns-flush)))

;; Editing objects.

(define (hns-get object arg)
  ;; Get the value of OBJECT's ARG from HyperNeWS.
  (if (and (string? arg) (hns-object object))
      (begin
	(hnscm-put object "object")
	(and (hnscm-get-any arg) (hnscm-get '())))))

(define (hns-put object arg value)
  ;; Set OBJECT's ARG to VALUE.
  (if (and (string? arg) (hns-object object))
      (begin
	(hnscm-put value)
	(hnscm-put object "object")
	(hnscm-put-any arg))))

;; Other operation on objects.

(define (hns-show object)
  ;; Tell HyperNeWS to show OBJECT (make it visible).
  (if (and (hns-clear) (hns-object object))
      (begin
	(hnscm-put object "object")
	(hnscm-show))))

(define (hns-hide object)
  ;; Tell HyperNeWS to hide OBJECT (make it invisible).
  (if (and (hns-clear) (hns-object object))
      (begin
	(hnscm-put object "object")
	(hnscm-hide))))

(define (hns-move object coord-list)
  ;; Tell HyperNeWS to move OBJECT to COORDLIST.
  (hns-send object "Move" coord-list))

(define (hns-size object wh-list)
  ;; Tell HyperNeWS to resize OBJECT to WIDTH-HEIGHT-LIST.
  (hns-send object "Size" wh-list))

(define (hns-reshape object xywh-list)
  ;; Tell HyperNeWS to reshape OBJECT to X-Y-WIDTH-HEIGHT-LIST.
  (hns-send object "Reshape" xywh-list))

(define (hns-update object)
  ;; Tell HyperNeWS to update OBJECT.
  (hns-send object "Update" '()))

(define (hns-lock-update stack)
  ;; Tell HyperNeWS to lock updates on STACK.
  (if (hns-stack? stack) (hns-send stack "LockUpdate" '())))

(define (hns-unlock-update stack)
  ;; Tell HyperNeWS to unlock updates on STACK.
  (if (hns-stack? stack) (hns-send stack "UnLockUpdate" '())))

(define (hns-connect stack)
  ;; Tell HyperNeWS to connect to STACK.
  (hns-send (if (not (equal? (hns-object-type stack) "stack"))
		(list "stack" stack)
		stack)
	    "Connect" '()))

(define (hns-exists object)
  ;; Return non-#f if OBJECT exists.
  (if (and (hns-clear) (hns-object object))
      (begin
	(hnscm-put object "object")
	(hnscm-exists))))

(define (hns-start-edit object)
  ;; If OBJECT is a stack, put it into edit mode.
  (if (hns-stack? object) (hns-send object "StartEditMode" '())))

(define (hns-stop-edit object)
  ;; If OBJECT is a stack, bring it out of edit mode.
  (if (hns-stack? object) (hns-send object "StopEditMode" '())))

(define (hns-select object)
  ;; Select OBJECT.
  (if (hns-card-object object)
      (hns-send (hns-mystack object) "SelectObject" (list object))))

(define (hns-menu object message . args)
  ;; Set OBJECT's menu to be MESSAGE, with optional ARGS.
  (if (and (pair? args) (hns-stack? object) (string? message))
      (hns-send object "OnMenu" (list args message))))

(define (hns-focus-menu object message . args)
  ;; Set OBJECT's focus menu to be MESSAGE, with optional ARGS.
  (if (and (pair? args) (hns-stack? object) (string? message))
      (hns-send object "OnFocusMenu" (list args message))))

(define (hns-stack-menu object message . args)
  ;; Set OBJECT's stack menu to be MESSAGE, with optional ARGS.
  (if (and (pair? args) (hns-stack? object) (string? message))
      (hns-send object "OnStackMenu" (list args message))))

(define (hns-stack-copy stack)
  If OBJECT is a stack, copy it to the clipboard.
  (if (hns-stack? stack)
      (begin
	(hns-clear)
	(hnscm-put stack "object")
	(and (hnscm-stack-copy)
	     (hnscm-get '())))))

(define (hns-rename object name)
  ;; If OBJECT is a stack, rename it to NAME.
  (hns-clear)
  (if (not (hns-stack? object))
      (begin
	(hnscm-put object "object")
	(and (hnscm-rename name)
	     (hnscm-get '())))))

(define (hns-new-object object name)
  ;; Add a new object of TYPE called NAME.
  (if (string? name) (hns-menu object "NewObj" (list name))))

(define (hns-home-card object)
  ;; If OBJECT is a stack, go to it's home card.
  (if (hns-stack? object) (hns-send object "GoHomeCard" '())))

(define (hns-next-card object)
  ;; If OBJECT is a stack, go to it's next card.
  (if (hns-stack? object) (hns-send object "GoNextCard" '())))

(define (hns-previous-card object)
  ;; If OBJECT is a stack, go to it's previous card.
  (if (hns-stack? object) (hns-send object "GoPreviousCard" '())))

(define (hns-last-card object)
  ;; If OBJECT is a stack, go to it's last card.
  (if (hns-stack? object) (hns-send object "GoLastCard" '())))

(define (hns-goto-card object &optional arg)
  ;; If OBJ is a Card, go to it. If it's a stack, go to it's ARGth card.
  (if arg
      (if (hns-stack? object)
	  (if (or (integer? arg) (string? arg))
	      (hns-send object "GotoCard" (list arg))))
    (if (and (hns-object object)
	     (equal (hns-object-type object) (hnscm-obj-type-name "card")))
	(hns-goto-card (hns-mystack object) (hns-object-name object)))))

(define (hns-set-drawing butt-obj file)
  ;; If OBJECT is a button, set it's drawing to be DRAWFILE.
  (hns-clear)
  (if (eqv? (hns-object-type butt-obj) (hnscm-obj-type-name "button"))
      (begin
	(hnscm-put butt-obj "object")
	(hnscm-set-drawing file))))

(define (hns-show-error arg)
  ;; Show ARG using the ShowError dialogue.
  (hns-clear)
  (cond ((string? arg) (hns-write arg "string"))
	((pair? arg) (hns-write arg "text")))
  (hns-ps "ShowError"))

(define (hns-response) 
  ;; Return what HyperNeWS said changing #f to nil
  (let ((response (hns-read)))
    (if (equal? response #f)
	'()
      response)))

(define (hns-confirm text)
  ;; Show ARG using the Confirm dialogue, return #t/#f if Yes/No was pressed.
  (hns-connect "Confirm")
  (hns-send '("stack" "Confirm") "Init" (list text))
  (do ((answer (hn-second (hns-read)) (hn-second (hns-read))))
      ((or (equal? answer "ConfirmYes") (equal? answer "ConfirmNo"))
       (equal? answer "ConfirmYes"))))

(define (hns-set-text text-object value)
  ;; If OBJECT is an EditText object, set it to VALUE.
  (if (eqv? (hns-object-type text-object) (hnscm-obj-type-name "edittext"))
      (hns-send text-object "SetValue" (list value))))

(define (hns-get-text text-object)
  ;; Return the value of EditText OBJECT.
  (hns-get text-object "Value"))

(define (hns-save stack)
  ;; If OBJECT is stack, save it.
  (if (hns-stack? stack) (hns-send stack "Save")))

(define (hns-save-as stack)
  ;; If OBJECT is stack, use the SaveAs dialogue to save it.
  (if (hns-stack? stack) (hns-send stack "SaveAs")))

(define (hnscm-put arg . type)
  ;; Put HyperNeWS object ARG (wth optional TYPE) on the HyperNeWS stack.
  (if type (set! type (car type)))
  (cond ((equal? type "null") (hnscm-put-null))
 	((equal? type "true") (hnscm-put-boolean 1))
	((equal? type "false") (hnscm-put-boolean 0))
 	((and (equal? type "string") (string? arg)) (hnscm-put-string arg))
	((equal? type "text") (if arg
				   (if (pair? arg)
				       (begin
					 (hnscm-put-array (length arg))
					 (hnscm-put-text arg 0)))
				 (hnscm-put-array 0)))
 	((equal? type "object")
 	 (let ((objtype (hn-first arg)))
	   (if (equal? objtype "stack")
	       (hnscm-put-stack (hn-second arg))
	     (let ((objname (hn-second (hn-second arg))))
	       (if (string? objname)
		   (hnscm-put-object
		    objtype
		    (hn-first (hn-second arg))
		    objname))))))
	((equal? type "message")
 	 (let ((target (hn-first arg))
	       (name (hn-second arg))
	       (arg-array (hn-third arg)))
	   (if (and (or (null? arg-array) (pair? arg-array))
		    (hns-object target) (string? name))
	       (begin
		 (hnscm-put arg-array)
 		 (hnscm-put target "object")
		 (hnscm-put-message name)
 		 #t))))
 	((null? arg) (hnscm-put-array 0))
 	((string? arg) (hnscm-put-string arg))
	((integer? arg) (hnscm-put-integer arg))
	((real? arg) (hnscm-put-float arg))
 	((pair? arg) (begin
		       (hnscm-put-array (length arg))
		       (hnscm-put-array-elements arg 0)))))

(define (hnscm-put-array-elements lst n)
  "Put LIST of elements (length N) on the HyperNeWS stack as an array."  
  (or (null? lst)
      (begin
	(hnscm-put (car lst))
	(hnscm-put-array-elt n)
	(hnscm-put-array-elements (cdr lst) (1+ n)))))

(define (hnscm-put-text str-lst n)
  "Put LIST of strings (length N) on the HyperNeWS stack."  
  (or (null? str-lst)
      (begin
	(hnscm-put (car str-lst))
	(hnscm-put-array-elt n)
	(hnscm-put-text (cdr str-list) (1+ n)))))

(if (not inhibit-hnstartup-message)
    ;; Pop up the HyperSchemeIntro Stack.
    (and (hns-start)
	 (hns-connect (list "stack" "HyperSchemeIntro"))
	 (hns-show (list "stack" "HyperSchemeIntro"))))