;;
;;
;;      Title : D-CheckPairMatch
;;
;;      Function :  This takes a pair of from the surface and lexical
;;         alphabet and a configuration and retruns a new configuration
;;         or the atom ERROR if no new configuration exists
;;
;;      Author :  Alan W Black   May 1986
;;     
;;      Copyright : Graeme Ritchie, Alan Black,
;;                  Steve Pulman and Graham Russell  1987
;;
;;         ---------------------------------------------
;;         |    Not to be used for military purposes   |
;;         ---------------------------------------------
;;
;;      1.18 23rd June 1986
;;       Changed the interpretation of the automata to a more complex
;;       form but this requires less work.  Moving of the
;;       rules is done in two stages.  First the new states are
;;       found which must pass some simple tests.  Then some post
;;       processing is done.
;;      2.4.F March 1987
;;       Added check to see what spelling rule formalism is running and 
;;       selected the appropriate functions.
;;      2.6 April 1987
;;       removed the alternate spelling rules
;;
;;      Description :
;;       The formalism is in the Koskenniemi framework of transducers.
;;       With a slight midification in the implementation (see above)
;;       rather than the finite state implementation described in the
;;       Texas Linguistics Forum 22.
;;
;;       The configurationation here consists of a list of states. The
;;       states are effectively in one non-deterministic automaton.
;;       Each one is tested with the given pair a list of new
;;       states are returned.  Also at each stage the main automaton is 
;;       restarted.
;;
;;       After a move a new configuration must 
;;        - Contain at leas one state marked as LICENCE
;;        - No D-ERROR state
;;        - No nil Commit groups
;;       The it is processed (in this order)
;;        - TERMINAL states removed
;;        - TERMINAL commit groups removed
;;        - All LICENCE states are grouped into a commit group
;;
;;      Parameters :
;;	  lex and surf, characters in the lexical and surface alphabet
;;           which includes 0 (nulls).
;;        config - a list of states of the automata
;;      Returns :
;;           a new configuration or the atom ERROR if no possible new
;;           configuration.
;;      Side Effect :
;;           none
;;
;;      External references :
;;
;;      System functions used :
;;        Name     type      Args #  type                 Comment
;;
;;      Restrictions :
;;
;;
(declare
   (special
      D-FINALSLIST
      D-TRANSITIONSLIST
      D-UNUSUALFEASIBLES
      D-POSSIBLEUNRESTRICTED
   )
   (localf
      D-CheckPairMatch                
      D-MoveAllStates                 
      D-FindNextState                 
      D-CheckNewConfiguration         
      D-MoveCommitStates                  
      D-IsFeasibleP                   
      D-Final                         
      D-Terminal                      
   )
)

(include "keywords")

(defmacro D-MakeAutoSymbol (lex surf)
;;
;;  returns an atom representing these two characters
;;
   `(cdr (assq ,lex (cdr (assq ,surf D-AUTOSYMBOLS))))
)

(defun D-CheckPairMatch (lex surf configuration)
;;
;;    moves on the next possible states, returns new config if all
;;    ok, ERROR if transitions are impossible
;;
   ;(print configuration) (print pair) (terpri)
   ;(setq ATOT (+ 1 ATOT))
   (catch 
      (D-CheckNewConfiguration
	 (D-MoveAllStates
	    (D-MakeAutoSymbol lex surf)
	    ;(concat 'D lex surf)
	    (cons
	       D-TRANSITIONSLIST      ;; and restart it
	       configuration))))
)

(defun D-MoveAllStates (pair configuration)
;;
;;   Moves each state to its next one.
;;
   (mapcan 
      #'(lambda (state)
	 (cond
	    ((eq (car state) 'COMMIT)   ;; a COMMIT group
	       (D-MoveCommitStates pair state) ;; nil if it terminates 
	    )
	    (t
	       (D-FindNextState pair state)))
      )
      configuration)
)

(defun D-FindNextState (pair state)
;;
;;   finds the next state.  And returns the new and old state as a
;;   pair             
;;
   (let ( (newstate (assq pair (cdr state))) )
      (cond
	 ((null newstate) nil)
	 ((assq (DK-D-ERROR) (cdr newstate)) (throw 'ERROR))
	 (t (mapcar #'(lambda (x) x) (cdr newstate)))) ;; copy list
   )
)
      

(defun D-CheckNewConfiguration (newconfig)
;;
;;   checks firstly that this is non nil and also that at least
;;   one state is a licence state
;;   
;;   All licence states are collected together into a COMMIT group. Also
;;   all COMMIT groups are checked to see that they are non-nil
;;
   (let  (licencestates simplestates)
      (setq simplestates
	 (mapcan
	    #'(lambda (state)
	       (cond
		  ((eq (car state) 'COMMIT)
		     (ncons state))
                  ((D-LicenceP state)          ;; if a licence state
		     (setq licencestates
			(cons state licencestates))
                     nil) ; nil so licence state will appear in a new OR clause
                  ((D-TerminalP state) nil)    ;; no need to continue
                  (t
		     (ncons state))            ;; state is a boring one
               ))
            newconfig))
      (cond
	 ((null licencestates)   ;; no licence pair for this transition
	    (throw 'ERROR))
         ((D-Terminal licencestates)  ;; these are true so no new OR clause
	    simplestates
         )
         (t                     ;; return new config with new OR clause
	    (cons
	       (cons 'COMMIT licencestates)
	       simplestates)
         )
      )
   )
)

(defun D-MoveCommitStates (pair orconfig)
;;
;;   Checks a commit group of states.  This has a slightly
;;   different interpretation than when moving normal states
;;   A new or state is returned, or nil if this one has been proved true.
;;   (returns a list of states)
;;   If it no new states can be found this throws 'ERROR
;;   
   (let ( newconfig )
      (setq newconfig
	 (mapcan
	    #'(lambda (state)
	       (D-FindNextState pair state))
            (cdr orconfig)))
      (cond
	 ((null newconfig) (throw 'ERROR))  ;; not found true
	 ((D-Terminal newconfig) nil)      ;; has been found true
	 (t (ncons (cons 'COMMIT newconfig)))          ;; still pending
      )
   )
)

(defun D-IsFeasibleP (lex surf concatedpair)
;;
;;  This checks to see if the pair is feasible.  This has
;;  been written for speed purposes.  If the two symbols in
;;  the pair are equal then it is (probably feasible)
;;  so it is accepted and it is left upto the automata to through
;;  it away (which they will).  If they are no feasible then
;;  there is a memq down with the list of non-eq pairs whcih are 
;;  held in D-UNUSUALFEASIBLES
;;
   (cond
      ((eq lex surf) t)
      (t          ;; ok have to find out the hard way
	 (memq concatedpair D-UNUSUALFEASIBLES)
      )
   )
)

(defun D-Final (config)
;;
;;   Returns true if the given list of states contains at least one
;;   final state
;;
   (cond
      ((null config) t)       ;; all are final states
      ((eq (caar config) 'COMMIT) nil);;an incomplete COMMIT is nonfinal
      ((D-FinalP (car config))   ;; final state
         (D-Final (cdr config))
      )
      (t nil)        ;; mis match of final state
   )
)

(defun D-Terminal (config)
;;
;;   Checks to see if any states in the config are terminal states
;;   returns t if one is nil otherwise
;;
   (cond
      ((null config) nil)
      ((D-TerminalP (car config)) t)
      (t (D-Terminal (cdr config)))
   )
)

(defun D-Tokenize (word)
;;
;; returns a list of the letters in the word with the initial config as car
;;
   (cons   
      nil     ;; initial automata configuration
      (append
	 (D-SplitIntoChars word)
	 (list (DK-ENDMARKER))
      ))
)

(defun D-FindPossibles (config surf)
;;
;;  returns a list of all the possible lexical characters that can
;;  match the given surf and configuration
;;
;;  that is find all simple states that are prelicence
;;  and also all the unrestricted pairs
;;
   (let ( (possibles (assq surf D-POSSIBLEUNRESTRICTED)) )
      (mapc
	 #'(lambda (lexcharlist)
	    (setq possibles
               (D-AddPossibleLexChar
		  lexcharlist possibles)))
	 (mapcan
	    #'(lambda (state)
	       (cond
		 ((eq (car state) 'COMMIT)
		    nil)
		 ((D-PreLicenceP state)
		    (ncons (D-WillLicence state)))
		 (t nil)))
	    config))
      possibles)
)
    

