;;
;;
;;      Title : D-EntryConv
;;
;;      Function : Takes the dictionary entries and creates a lexicon
;;                 tree from them
;;
;;      Author :  Alan W Black   Dec 1984
;;                Dept of A.I.  University of Edinburgh
;;
;;      Copyright Graeme Ritchie, Alan Black,
;;                Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;      1.9  19th June 1985
;;           Make hyphen be treated as real character, and add the
;;           morpheme boundary character (+) to the appropriate end 
;;           of the surface form.
;;      1.11 4th September 1985
;;           Changed to be more functional.  The lexicon tree is
;;           now returned, rather than written directly to a file
;;           The entries are only written to the entryfile if 
;;           the global variable D-LEXICON-STATE is set to D-CREATE
;;      1.16 13th March 1986
;;           Changed the structure of the lexicon (again)  to get
;;           round a bug in the searching (I hope).  Also should make
;;           it faster (!).  The new format is a 
;;               <dict> ::= <lex>*
;;               <lex> ::= ( <char> <lex>+ ) |
;;                         ( ZZ  <entry index>+ )
;;               <entry index> ::= <integer>
;;      2.3  23rd October 1986
;;           Make the construction of the lexicon tree so that the
;;           subtrees are ordered.  This is to help the searching during
;;           run time.  The ordering is via the function alphalessp
;;      2.7  14th May 1987
;;           Added noninflect global flag and incore global flag
;;
;;      Description :
;;
;;      Parameters :
;;         entrys     a list of (expanded) lexical entries to be added
;;         lexicon    a lexicon tree (list of lexicons)
;;
;;      Returns :
;;         a lexicon tree
;; 
;;    *************************************************************
;;    * NOTE that the dictionary returned is NOT a lexicon itself *
;;    * as it has no head. A lexicon has a head and sub-lexicons  *
;;    *************************************************************
;;
;;      Side Effect :
;;         Depending on Global D-INCOREFLAG (equal to (DK-OFF)) the 
;;         entries are written to the end of the file on port D-ENTRYFILEID
;;         otherwise the entry is put into the lexicon tree.  
;;         
;;         
;;      External references :
;;         none
;;
;;      System functions used :
;;        Name     type      Args #  type                 Comment
;;
;;      Restrictions :
;;
;;
;;
(declare
   (special
      D-ENTRYFILEID
      D-LEXICON
      D-em
      D-LEXICON-STATE
   )
   (localf
      D-EntryConv                     
      D-MakeToken                     
      D-AddWord                       
      D-CreateSubLexs                 
      D-SetDict                       
      D-AddtoDict                     
      D-AddNewSubLex
      D-FindSubLexPosAndAdd
      D-GetFilePos
      D-PutEntryToFile
      D-NonInflectable
   )
)


(defun D-EntryConv (entrys lexicon)
;;
;;   This adds the list of lexical entries in entrys to the given
;;   lexicon.  The new lexicon tree is returned.  The actual entries
;;   are written to the end of the file on port D-ENTRYFILEID (which
;;   must be open.  If the global variable D-LEXICON-STATE is not
;;   equal to D-CREATE then the entrys are added to the tree (and
;;   may be later written using the routine D-WriteLexicon).
;;
   (D-SetDict 
      entrys
      lexicon             ;; previous lexicon
   )
)

(defun D-MakeToken (word)
;;
;; returns a list of the letters in the word
;;
   (D-SplitIntoChars word)
)

(defun D-AddWord (word entry sublexs)
;;
;;   trys to add the word to one of the given list of lexicons
;;   Returns a new lexicon (head sublist sublist ...)
;;
   (cond
      ((null word)   ;; end of word
	 (cons
	    (D-CreateSubLexs word entry)  ;; this will always return entry
	    sublexs))            ;; actually they are entries
      (t                 ;; not end of word
	 (let ( (sublex (assq (car word) sublexs)) )
	    (cond
	       ((null sublex)   ;; no suitable sub lex at this level
		  (D-AddNewSubLex                ;; add in ordered position
		     (D-CreateSubLexs word entry) 
		     sublexs))                  
	       (t               ;; change the lower level lexicon
		  (rplacd sublex
		     (D-AddWord 
			(cdr word)
			entry
			(cdr sublex)))
		  sublexs
	       )
	    )
	 )
      )
   )
)

(defun D-AddNewSubLex (newsublex sublexs)
;;
;;   Adds newsublex to the appropriate ordered position in
;;   the list of sub lexicons.  Thus the order is now significant
;;   The order is set by by the function alphalessp
;;
   (cond
      ((null sublexs) (ncons newsublex))   ;; not sure if this occurs
      (t
	 (D-FindSubLexPosAndAdd newsublex sublexs)
	 sublexs     ;; this is modified by the previous function
      )
   )
)

(defun D-FindSubLexPosAndAdd (newsublex sublexs)
;;
;;  Destructively adds the new sublex to the appropriate non-null list
;;  of sub lexs
;;
   (cond
      ((or (eq (caar sublexs) (DK-ENDTREE))
	   (and (not (eq (car newsublex) (DK-ENDTREE)))
	        (not (alphalessp (car newsublex) (caar sublexs)))))
	 (cond
	    ((null (cdr sublexs))   ;; about to hit the end
	       (rplacd sublexs      ;; so tag on the end
		  (ncons newsublex)))
            (t      ;; keep going
	       (D-FindSubLexPosAndAdd newsublex (cdr sublexs))))
      )
      (t    ;; ok hit the bit it is to go in
	 (rplacd sublexs 
	    (cons (car sublexs) (cdr sublexs)))
         (rplaca sublexs newsublex)
      )
   )
)

(defun D-CreateSubLexs (letterlst entry)
;;
;;    Fills out a branch for the given letter list
;;    returning a lexicon tree (with heads)
;;
   (cond
      ((null letterlst)
	  entry     ;; end of word  so add lexical entry
      )
      (t
	 (list (car letterlst) (D-CreateSubLexs (cdr letterlst) entry))
      )
   )
)

(defun D-SetDict (wordlst lexicon)
;;
;;  This will add the wordlist to the given dictionary 
;;  and return the dictionary 
;;
   (let ( (dictionary lexicon) )
      (mapcar
	 #'(lambda (entry)
	       ;(princ entry) (terpri)
	       (setq dictionary
		  (D-AddtoDict entry dictionary)))
         wordlst
      )
      dictionary     ;; return new dictionary 
   )
)

(defun D-AddtoDict (entry dictionary)
;;
;;   Add the new entry to the dictionary 
;;
   (D-AddWord
      (append (D-MakeToken (car entry)) (ncons (DK-ENDTREE)))
      (D-GetFilePos 
	 (list
	    (D-CitationForm entry)
	    (D-PhonologicalForm entry)
	    (D-MakeCategory (D-Syntax-Field entry))
	    (D-Semantic-Field entry)
	    (D-User-Field entry)))
      dictionary
   )
)

(defun D-GetFilePos (entry)
;;
;;   This now checks to see if the given entry is non-inflectable
;;   (as per the definition) and marks the entry as such returning
;;   the pair (<non-inflect flag> <entry | file position>)
;;
   (cond
      ((D-NonInflectable (D-Syntax-Field entry))
         (cons t (D-PutEntryToFile entry))
      )
      (t
         (cons nil (D-PutEntryToFile entry))
      )
   )
)

(defun D-PutEntryToFile (entry)
;;
;;  returns a integer posityion number of this entry in the 
;;  file or the entry itself in D-INCOREFLAG is set to on
;;
   (cond
      ((eq D-INCOREFLAG (DK-ON))
	 entry)
      (t
         (let ( (pos (filepos D-ENTRYFILEID)) )
            (print entry D-ENTRYFILEID)
            (terpri D-ENTRYFILEID)
	    pos)
      )
   )
)

(defun D-NonInflectable (category)
;;
;;  returns t if this category is an extension of one of the 
;;  categories in the global D-NONINFLECTS
;;
   (cond
      ((eq D-NONINFLECTFLAG (DK-ON))
	 t)      ;; global non-inflect flag set
      (t
	 (catch
	    (progn
	       (mapcar
		  #'(lambda (noninflect)
		     (cond
			((D-IsExtensionOf noninflect '((t t)) category)
			   (throw t))
			(t nil)))
		  D-NONINFLECTS)
                nil))))
)

