;;; -*- Mode: LISP; Syntax: Common-lisp; Base: 10; Package: DICT -*-

;; First some utilities


(defmacro do-vector-elements ((vector elt &optional (index 'i)) &body body)
  "Iterate BODY, where ELT is each successive elt in VECTOR, and INDEX (default I) takes on each index"
  (zl:once-only (vector)
    `(let (,elt)
       (do ((,index 0 (+ ,index 1)))
	   ((= ,index (length ,vector)))
	 (setf ,elt  (elt ,vector ,index))
	 ,@body))))


(defvar webster-font-alist
	  `(
	    (#\W ,fonts:hl12)				;Normal
	    (#\X ,fonts:hl12i)				;Italic
	    (#\Y ,fonts:hl12b)				;Bold
	    (#\M ,fonts:hl10)				;Mini Caps
	    (#\I ,fonts:hl7)				;Subscript
	    (#\J ,fonts:hl7)				;Italic Subscript  (fake)
	    (#\K ,fonts:hl7)				;Bold Face Subscript (fake)
	    (#\A ,fonts:hl7)				;superscript
	    (#\B ,fonts:hl7)				;italic super
	    (#\C ,fonts:hl7)				;bold super
	    (#\G interpret-greek)
	    (#\R interpret-apl)
	    (#\Q interpret-weird)
	    )
  "Alist from Webster font letter to either a FONT or the name of function to call for further decoding")

(tv:screen-parse-font-descriptor 'fonts:apl14 NIL)
(tv:screen-parse-font-descriptor 'fonts:hippo12 NIL)

(defvar webster-required-fonts
	(append
	  (remove-if #'symbolp
		     (remove-duplicates
		       (mapcar #'second webster-font-alist)))
	  (list					;Ad-hoc knowledge, sigh
	    fonts:hippo12
	    fonts:apl14))
  "List of all fonts a window must have to display definition")

(export 'webster-required-fonts)

; To be supplied...
(defun interpret-greek (string)
  (values string fonts:hippo12))

;  Bizarre, but the OZ NWEBSTER server returns an APL overstrike with the actual
; name of the word.  So T is what we want (to get the squiqqle)
(defun interpret-apl (string)
;  (values string fonts:apl14)
  string
  (values "T" fonts:apl14))

(defun interpret-weird (string)
  (values string))



(defvar overstruck-alist
	'(
	  (#\< #\( #\{)				;left brace
	  (#\< #\' #\`)				;single open quote
	  (#\< #\a #\*)				;acute accent a
	  (#\< #\e #\*)				;acute accent e
	  (#\< #\E #\*)				;acute accent E
	  (#\( #\| #\[)				;square left bracket
	  (#\+ #\= #\*)				;plus or minus
	  (#\| #\) #\])				;square right bracket
	  (#\| #\- #\*)				;single dagger
	  (#\| #\= #\*)				;double dagger
	  (#\| #\q #\*)				;paragraph
	  (#\| #\B #\*)				;B in a box (backspace)
	  (#\| #\S #\*)				;section
	  (#\) #\> #\})				;right brace
	  (#\; #\c #\*)				;c cedille
	  (#\; #\C #\*)				;C cedille
	  (#\~ #\a #\*)				;circumflex a
	  (#\~ #\e #\*)				;circumflex e
	  (#\~ #\i #\*)				;circumflex i
	  (#\~ #\o #\*)				;circumflex o
	  (#\~ #\u #\*)				;circumflex u
	  (#\~ #\E #\*)				;circumflex E
	  (#\- #\: #\*)				;division sign
	  (#\- #\m #\*)				;m dash
	  (#\- #\n #\*)				;n dash
	  (#\- #\3 #\*)				;ellipsis
	  (#\> #\' #\')				;single close quote
	  (#\> #\a #\*)				;grave accent a
	  (#\> #\e #\*)				;grave accent e
	  (#\> #\u #\*)				;grave accent u
	  (#\> #\E #\*)				;grave accent E
	  (#\' #\" #\*)				;straight apostophe
	  (#\' #\b #\*)				;b with a crossed staff
	  (#\' #\o #\*)				;degree
	  (#\= #\S #\*)				;integral sign
	  (#\" #\a #\*)				;umlaut a
	  (#\" #\e #\*)				;umlaut e
	  (#\" #\i #\*)				;umlaut i
	  (#\" #\o #\*)				;umlaut o
	  (#\" #\u #\*)				;umlaut u
	  (#\" #\A #\*)				;umlaut A
	  (#\" #\O #\*)				;umlaut O
	  (#\" #\U #\*)				;umlaut U
	  )
  "Alist from escape sequence to ???"
  )

(defun find-overstrike-equivalent (table char1 char2)
  (cddr
    (find nil table :test (lambda (ignore elt)
			    (and (char= char1 (first elt))
				 (char= char2 (second elt)))))))


(defun print-overstruck (char1 char2 window font)
  (if (font-p font)
      (print-overstruck-universal char1 char2 window)
      (print-overstruck-in-font char1 char2 window font)))

; An overstrike that should exist in either any Roman font,
; or perhaps only in the main font.
(defun print-overstruck-universal (char1 char2 window)
  (let ((thing (find-overstrike-equivalent overstruck-alist char1 char2)))
    (cond
      ((and (= (length thing) 1)
	    (characterp (first thing)))
       (princ (first thing) window))
      (t
       ;; some other format, probably a font shift.
       ;; not yet decided.
       ))))


(defun print-overstruck-in-font (char1 char2 window font)
  (cond
    ((eq font 'interpret-greek)
     (print-greek-overstrike-in-window char1 char2 window))
    ((eq font 'interpret-apl)
     (print-apl-overstrike-in-window char1 char2 window))
    (t
     (princ char1 window)
     (princ char2 window))))


(defvar greek-overstrike-alist
	'(
	  (#\/ #\a #\a)				;alpha
	  (#\/ #\b #\b)				;beta
	  (#\/ #\g #\g)				;gamma
	  (#\/ #\d #\d)				;delta
	  (#\/ #\e #\e)				;epsilon
	  (#\/ #\z #\z)				;zeta
	  (#\/ #\h #\h)				;eta
	  (#\- #\0 #\q)				;theta
	  (#\/ #\i #\i)				;iota
	  (#\/ #\k #\k)				;kappa
	  (#\/ #\l #\l)				;lambda
	  (#\/ #\m #\m)				;mu
	  (#\/ #\n #\n)				;nu
	  (#\/ #\x #\c)				;xi
	  (#\/ #\o #\o)				;omicron
	  (#\/ #\p #\p)				;pi
	  (#\/ #\r #\r)				;rho
	  (#\/ #\s #\s)				;sigma
	  (#\- #\s #\j)				;sigma (final)
	  (#\/ #\t #\t)				;tau
	  (#\/ #\u #\u)				;upsilon
	  (#\| #\o #\f)				;phi
	  (#\/ #\c #\x)				;chi
	  (#\/ #\v #\y)				;psi
	  (#\/ #\w #\w)				;omega

	  (#\/ #\A #\A)				;Alpha
	  (#\/ #\B #\B)				;Beta
	  (#\/ #\G #\G)				;Gamma
	  (#\/ #\D #\D)				;Delta
	  (#\/ #\E #\E)				;Epsilon
	  (#\/ #\Z #\Z)				;Zeta
	  (#\/ #\H #\H)				;Eta
	  (#\- #\O #\Q)				;Theta
	  (#\/ #\I #\I)				;Iota
	  (#\/ #\K #\K)				;Kappa
	  (#\/ #\L #\L)				;Lambda
	  (#\/ #\M #\M)				;Mu
	  (#\/ #\N #\N)				;Nu
	  (#\/ #\X #\C)				;Xi
	  (#\/ #\O #\O)				;Omicron
	  (#\/ #\P #\P)				;Pi
	  (#\/ #\R #\R)				;Rho
	  (#\/ #\S #\S)				;Sigma
	  (#\/ #\T #\T)				;Tau
	  (#\/ #\U #\U)				;Upsilon
	  (#\/ #\F #\F)				;Phi
	  (#\/ #\C #\X)				;Chi
	  (#\/ #\V #\Y)				;Psi
	  (#\/ #\W #\W)				;Omega
	  )
  "Alist from greek overstrike sequence to character")




(defun print-greek-overstrike-in-window (char1 char2 window)
  (with-font window fonts:hippo12
    (princ (or (first (find-overstrike-equivalent  greek-overstrike-alist char1 char2))
	       #\?) window)))


(defun print-apl-overstrike-in-window (char1 char2 window)
  char1 char2
  (princ #\@ window)
  )



;; Use the overstrikes as actually stored in the text
(defun print-raw-definition-to-window (string window)
  "Print the Webster definition to Window"
  (let ((word (make-extensible-string))
	(font-stack)
	(font  (second (assoc #\W webster-font-alist)))
	)
    (labels
      ((word-fits? (word)			;small text justifier for printing.
	 (> (window-width window)
	    (+ (string-width word window)
	       (cursor-position window))))
       (finish-word ()
	 (if (not (word-fits? word))
	     (terpri window))
	 (princ word window)
	 (setf (fill-pointer word) 0))
       )
      (with-font window font
	(do-vector-elements (string char i)
	  (cond
	    ((and (and (< i (- (length string) 2))
		       (char= (elt string (+ i 1)) #\back-space)))
						; begin overstruck sequence
	     (incf i)				;eat Back-Space
	     (incf i)				;point to second char of sequence
	     (let ((char2 (elt string i)))
	       (cond
		 ((and (char= char #\()
		       (assoc char2 webster-font-alist))
		  ;; Enter Font Shift
		  (finish-word)			;finish word in progress
		  (push font font-stack)
		  (setf font (second  (assoc  char2 webster-font-alist)))
		  (if (font-p font)
		      (setf (current-font window) font))
		  )
		 ((and (char= char #\))
		       (assoc char2 webster-font-alist))
		  ;; Return to previous Font
		  (if (font-p font)		;We are in some font
		      (finish-word)		;so emit word
		      (multiple-value-bind (string font)	;otherwise FONT is a symbol
			  (funcall font word)	;the name of a function
			(when font
			  (setf (current-font window) font))
			(when string
			  (setf (fill-pointer word) (length string))
			  (replace word string)
			  (finish-word))))
		  (setf font (pop font-stack))
		  (if (font-p font)
		      (setf (current-font window) font)))
		 (t
		  ;; Other overstruck sequence
		  (finish-word)
		  (print-overstruck char char2 window font)
		  ))))
	    ((char= char #\space)
	     ;; We assume space doesn't show up inside an escape sequence!
	     (finish-word)
	     (princ #\space window))		;BUG! space may cause line wrap
	    (t
	     (vector-push-extend char word))))
	(finish-word)
	))))


; Definition as returned by WEBSTER server has diff escape sequence @x(....)
; where x is a font character.
; It puts @R(WORD) instead of @R(T)
; it omits greek characters - you get @G() instead

(defun print-definition-to-window (string window)
  "Print the Webster definition to Window"
  (let ((word (make-extensible-string))
	(font-stack)
	(font  (second (assoc #\W webster-font-alist)))
	char2
	)
    (labels
      ((word-fits? (word)			;small text justifier for printing.
	 (> (window-width window)
	    (+ (string-width word window)
	       (cursor-position window))))
       (finish-word ()
	 (if (not (word-fits? word))
	     (terpri window))
	 (princ word window)
	 (setf (fill-pointer word) 0))
       )
      (with-font window font
	(do-vector-elements (string char i)
	  (cond
	    ((and (char= char #\@))
	     (incf i)				;point to char
	     (setf char2 (elt string i))
	     (incf i)				;point to open paren
	     ;; Enter Font Shift
	     (finish-word)			;finish word in progress
	     (push font font-stack)		;save current font
	     (setf font (second  (assoc  char2 webster-font-alist)))
	     (if (font-p font)
		 (setf (current-font window) font))
	     )
	    ((and font-stack
		  (char= char #\)))
;	     (format t "~&::~A~%" font-stack)
	    ;; Return to previous Font
	     (if (font-p font)		;We are in some font
		 (finish-word)		;so emit word
		 ;; otherwise its a special escape
		 (multiple-value-bind (string font)	;otherwise FONT is a symbol
		     (funcall font word)	;the name of a function
		   ;; we may get back a font to use
		   (when font
		     (setf (current-font window) font))
		   (when string
		     ;; copy into word can pass it to FINISH-WORD
		     (setf (fill-pointer word) (length string))
		     (replace word string)
		     (finish-word))))
	     (setf font (pop font-stack))
	     (if (font-p font)
		 (setf (current-font window) font)))
	    ((char= char #\space)
	     ;; We assume space doesn't show up inside an escape sequence!
	     (finish-word)
	     (princ #\space window))		;BUG! space may cause line wrap
	    (t
	     (vector-push-extend char word))))
	(finish-word)
	))))


(defun coerce-window-to-webster-font-map (window)
  "Force window to have font map sufficient for pretty printing of definition"
  (let ((font-map (font-map window)))
    (when (not (every (lambda (font)
			(find font font-map))
		      webster-required-fonts))
      (setf (font-map window)
	    (concatenate 'list font-map webster-required-fonts)))))

(defun print-definition (word &optional (window *standard-output*))
  "Print the definition of WORD to a window"
  (let ((word-info (get-webster-info (string word))))
    (if word-info
	(progn
	  (coerce-window-to-webster-font-map window)
	  (print-definition-to-window (webster-entry-definition word-info)	window))
	(format window "Not in dictionary.~%"))))

(export 'print-definition)

				      
#||
(setq www (tv:make-window
	    'tv:window
	    :edges-from :mouse
	    :label (zl:string "Definitions")
	    :expose-p T
	    :blinker-p nil
	    :more-p nil
	    :font-map webster-required-fonts))
						
(zl:send www :clear-window)
(zl:send www :set-current-font fonts:hl12)


(defun show (word)
  (zl:send www :clear-window)
  (let ((def  (webster-entry-definition
				(get-word-information word))))
    (print-definition-to-window def www)
    def))

(show "banana")
(show "theta")
(show "icing")
(show "matter")

(DEFUN PPP (WORD)
    (BLOCK
     PPP
     (DO-VECTOR-ELEMENTS
      ((WEBSTER-ENTRY-PRONUNCIATION (GET-WORD-INFORMATION WORD)) CHAR)
      (PRINT CHAR))))

 ||#


(defun speak-definition (string stream)
  "Speak the definition in string to stream, intended to be a Dectalk stream"
  (let (
	(prev nil)
	)
    (do-vector-elements (string char i)
      (cond
	((and (and (< i (- (length string) 2))
		   (char= (elt string (+ i 1)) #\back-space)))
						; begin overstruck sequence
	 (incf i)				;eat Back-Space
	 (incf i)				;point to second char of sequence
	 (let ((char2 (elt string i)))
	   (cond
	     ((and (char= char #\()
		   (assoc char2 webster-font-alist))
	      ;; Enter Font Shift
	      (princ ".  " stream)
	      (write-byte 13. stream)
	      )
	     ((and (char= char #\))
		   (assoc char2 webster-font-alist))
	      (princ ".  " stream)
	      (write-byte 13. stream)
	      
	      )
	     (t
	      ;; Other overstruck sequence
	      ))))
	((char= char #\space))
	(t
	 (if (and prev
		  (char= prev #\space))
	     (write-char prev stream))
	 (write-char char stream)))
      (setq prev char))
    (princ ".  " stream)
    (write-byte 13 stream)
    (write-byte 13 stream)
    ))

(export 'speak-definition)