;; Lexical Entries

(defparameter *lex-entry-tag* '*lex-entry-tag*)
(defun make-lex-entry (word cat)
  (cond ((and (stringp word) (symbolp cat))
         `(,*lex-entry-tag* ,word . ,cat))
        (t (error "In make-lex-entry -- Arguments should be~
                   a string and a symbol Got a ~a and a ~a" 
                  (type-of word) (type-of cat)))))
(defun is-lex-entry (x)
  (when (consp x) (eq (car x) *lex-entry-tag*)))
(defun print-lex-entry (lex-entry &optional (stream *standard-input*))
  (cond ((is-lex-entry lex-entry)
         (format stream "{Lex-Entry: ~a ~a}"
                 (lex-entry-word lex-entry)
                 (lex-entry-cat lex-entry)))
        (t (warn "In print-lex-entry -- Expected a lex-entry but got ~a~
                  of type ~a"
                 lex-entry (type-of lex-entry)))))
(defun lex-entry-word (lex-entry)
  (cond ((is-lex-entry lex-entry)
         (second lex-entry))
        (t (error "In lex-entry-word -- This is no lex-entry: ~a" lex-entry))))
(defun lex-entry-cat (lex-entry)
  (cond ((is-lex-entry lex-entry)
         (cddr lex-entry))
        (t (error "In lex-entry-word -- This is no lex-entry: ~a" lex-entry))))


;; The Lexicon

(defparameter *lexicon-tag* '*lexicon-tag*)
(defun make-lexicon (&optional (name "No-name"))
  `(,*lexicon-tag* (lexicon . nil) ;; Store the lex-entries here
                   (count . 0)
                   (name . ,name)
                   ))
(defun is-lexicon (x)
  (when (consp x) (eq (car x) *lexicon-tag*)))
(defun clear-lexicon (lexicon)
  (cond ((is-lexicon lexicon)
         (setf (cdr (second lexicon)) nil)
         (setf (cdr (third lexicon)) 0)
         lexicon)
        (t (error "In clear-lexicon -- This is no lexicon: ~a" lexicon))))
(defmacro lexicon-entries (lexicon)
  `(cdr (second ,lexicon)))
(defmacro lexicon-count (lexicon)
  `(cdr (third ,lexicon)))
(defmacro lexicon-name (lexicon)
  `(cdr (fourth ,lexicon)))
(defun store-in-lexicon (lexicon lex-entry)
  (cond ((and (is-lexicon lexicon)
              (is-lex-entry lex-entry))
         (let ((old-entry
                (find-in-lexicon lexicon (lex-entry-word lex-entry))))
           (when old-entry (warn "In add-in-lexicon -- Overwriting ~a ~a"
                                 (lex-entry-word old-entry)
                                 (lex-entry-cat old-entry))))
         (setf (lexicon-entries lexicon)
           (acons (lex-entry-word lex-entry)
                  lex-entry
                  (lexicon-entries lexicon)))
         (incf (lexicon-count lexicon))
         lexicon)
        (t (error "In add-in-lexicon -- Expected a lexicon and a lex-entry~
                   but got ~a and ~a of type ~a ~a"
                  lexicon lex-entry
                  (type-of lexicon) (type-of lex-entry)))))
(defun find-in-lexicon (lexicon word-string)
  (cond ((and (is-lexicon lexicon)
              (stringp word-string))
         (cdr (assoc word-string (lexicon-entries lexicon)
                     :test #'equal)))
        (t (error "In find-in-lexicon -- Expected a lexicon and a string~
                   but got ~a and ~a of type ~a ~a"
                  lexicon word-string
                  (type-of lexicon) (type-of word-string)))))
(defun print-lexicon (lexicon &optional (stream *standard-input*))
  (cond ((is-lexicon lexicon)
         (format stream "~%#<Lexicon ``~a'' has the following ~a entries:"
                 (lexicon-name lexicon)
                 (lexicon-count lexicon))
         (mapc #'(lambda (cons)
                   (format stream "~%")
                   (print-lex-entry (cdr cons) stream))
               (lexicon-entries lexicon))
         t)
        (t (warn "In print-lexicon -- expected a lexicon but got ~a~
                  of type ~a")
           nil)))
                 
(defun add-lex-entries-from-file (lexicon path)
  (with-open-file (lex-stream path)
     (loop for word = (read lex-stream nil :eof)
           for cat =  (read lex-stream nil :eof)
           until (eq word :eof)
         do (store-in-lexicon lexicon (make-lex-entry word cat))))
  lexicon)