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

;; Getting definitions via the WEBSTER CHAOS protocol
; includes code adapted from  Patrick A O'Donnel (PAO@OZ) for CHAOS WEBSTER

(defvar *webster-stream* nil)

(defvar *webster-host* (si:parse-host "OZ"))

(defun kill-webster ()
  (when *webster-stream*
    (scl:send *webster-stream* :close)
    (setq *webster-stream* nil)))

(defun setup-webster ()
  (kill-webster)
  (setq *webster-stream*
	(chaos:make-stream (chaos:connect *webster-host*
					  (zl:string "OWEBSTER")))))


(defun extract-fields (string &key (start 0) (delims '(#\;)))
  "Return one value for each fields in the string"
  (let (list)
    (do ((field-end (position delims string
			      :start start
			      :test (lambda (list character)
				      (find character list :test #'char=)))
		    (position delims string
			      :start start
			      :test (lambda (list character)
				      (find character list :test #'char=)))))
	((null field-end) (push (subseq string start) list))
      (push (subseq string start field-end) list)
      (setf start (+ field-end 1)))
    (apply #'values (reverse list))))

(defun parse-webster-stream  (stream)
  "Parse STREAM, extracting information, placing results into WEBSTER-ENTRY info"
  (labels
    ((append-definition (string entry)
       (setf (webster-entry-definition entry)
	     (concatenate 'string (webster-entry-definition entry) string)))
     )
    (do ((line (read-line stream nil nil)(read-line stream nil nil))
	 ignore?				;reading uninteresting line?
	 v-hack?				; must append space?
	 entry
	 list
	 )
	((or (null line) (zerop (length line)))
	 (when entry
	   (push entry list))
	 (scl:send stream :clear-eof) (reverse list))
;      (print line)				;debugging
      (case (aref line 0)
	(#\F
	 (when entry
	   (push entry list))
	 (multiple-value-bind (entname homono prefsuf dotss accmarks pos posjoin pos2)
	     (extract-fields line :start 2)
	   (setf entry (make-webster-entry :name entname))
	   (when (and pos (not (zerop (length pos))))
	     (setf (webster-entry-part-of-speech entry) (read-from-string pos)))
						; not used
	   homono
	   prefsuf
	   dotss
	   accmarks
	   posjoin
	   pos2
	   ))
	(#\R )					;Runon, remainder uninteresting
	(#\P
	 (setf (webster-entry-pronunciation entry) (subseq line 2)))
	(#\E					;Etymology
	 (setf ignore? T))
	(#\L					; "Label"  (??)
	 (setf ignore? T))
	(#\V					;Variant spelling
	 (setf ignore? T))
	(#\S					;Synonyms
	 (setf ignore? T))
	(#\X
	 (setf ignore? T))
	(#\D
	 (setf v-hack? (= (length line) 79.))
	 (setf ignore? nil)
	 (when (> (length (webster-entry-definition entry)) 0)
	   (append-definition ".  " entry))
	 (append-definition
	   (subseq line
		   ;; skip the first four fields
		   (do ((pos 0 (position #\; line :test #'char= :start (+ pos 1)))
			(i 0 (1+ i)))
		       ((= i 4) (+ pos 1)))) entry))
	(#\C
	 (if (not ignore?)
	     (if v-hack?
		 (append-definition " " entry))
	     (setf v-hack? (= (length line) 79.))	;+ 2 for C: = 79.
	     (append-definition line entry)))
	(otherwise
	  (warn "Couldn't parse \"~A\"~%" line))))))



(defun get-word-information-net (word)
  "Return Webster-entry for a word"
  (setup-webster)

  (do () ((null (listen *webster-stream*)))
    (read-char *webster-stream*))

  (write-line (string-upcase word) *webster-stream*)
  (scl:send *webster-stream* :finish)
  (parse-webster-stream *webster-stream*))

(export 'get-word-information-net)

#||
(setq eee  (get-word-information-net "walk"))

(setq eee (get-word-information-net "alarm"))

(setq eee (get-word-information-net "banana"))

(defun show (word)
  (let ((info       (get-word-information-net word)))
    (when info
      (scl:send www :clear-window)
      (dolist (eee info)
	(terpri www)
	(print-definition-to-window
	  (webster-entry-definition eee) www))
      info)))

||#