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

(defvar *rules* (make-hash-table :test #'eq))
(defvar *data* nil)
(defvar *valid-rule-types* '(DICTIONARY CFG CFG-TABLE CFG-GRAMMAR-TABLE
					GPSG GPSG-TABLE GPSG-GRAMMAR-TABLE
					SENTENCES))

(defun rule-set (name &optional type)
  (let ((rule-set (gethash name *rules*)))
    (if (or (not type) (eq type (second rule-set)))
	rule-set
	nil)))

(defun remove-rule-set (name)
  (setf (gethash name *rules*) nil)
  (setq *data* (remove name *data*))
  (msg t "~&Rule set ~S removed." name)
  (values))

(defun sort-rules (name)
  (if (rule-set name)
      (setf (third (rule-set name)) (sort (copy-list (third (rule-set name))) #'s<))
      (format t "~&Nonexistant rule set."))
  (values))

(defvar *display-table* nil)

(defun add-rule-set (name type)
  (cond ((and (member type *valid-rule-types*)
	      (not (rule-set name)))
	 (let ((rs (list name type nil)))
	   (setf (gethash name *rules*) rs)
	   (msg t "~&Rule set ~S added." name)
	   (setq *display-table* (list rs 0 nil))
	   (push name *data*)))
	(t (format t "~&Illegal name or type of rule set.")))
  (values))

(defun list-rules (name &optional (template '*))
  (let ((rs (rule-set name)))
    (cond ((member (second rs) '(CFG-TABLE GPSG-TABLE CFG-GRAMMAR-TABLE GPSG-GRAMMAR-TABLE))
	   (format t "~&~S is not a listable rule set." name))
	  (rs
	   (format t "~&~S rule set ~S:" (second rs) name)
	   (let ((to-display (sort (copy-list (filt (third rs) template)) #'s<)))
	     (setq *display-table* (list rs (length to-display) to-display))
	     (do ((to-do to-display (cdr to-do))
		  (n 1 (1+ n)))
		 ((null to-do))
	       (cond ((symbolp (car to-do)) (format t "~&~D.~5T~S" n (car to-do)))
		     ((stringp (car to-do)) (format t "~&~D.~6T~A" n (car to-do)))
		     (t (format t "~&~D.~5T~{ ~S~}" n (car to-do)))))))
	  (t (format t "~&No such rule set."))))
  (values))

(defun del (&rest nums)
  (if (or (null *display-table*) (= 0 (second *display-table*)))
      (format t "~&Use LIST-RULES to specify a rule set.")
    (mapc #'(lambda (i) (if (and (integerp i) (> i 0) (<= i (second *display-table*)))
			    (del-rule (first (first *display-table*))
				      (nth (1- i) (third *display-table*)))
			  (format t "~&A reference must be between 1 and ~D."
				  (second *display-table*))))
	  nums))
  (values))

(defun rpl (&rest nums-rules)
  (if (or (null *display-table*) (= 0 (second *display-table*)))
      (format t "~&Use LIST-RULES to specify a rule set.")
    (do ((to-do (copy-list nums-rules) (cddr to-do)))
	((or (null to-do) (null (cdr to-do))))
      (if (and (integerp (car to-do)) (> (car to-do) 0)
	       (<= (car to-do) (second *display-table*)))
	  (progn (del-rule (first (first *display-table*))
			   (nth (1- (car to-do)) (third *display-table*)))
		 (add-rule (first (first *display-table*))
			   (second to-do)))
	(format t "~&A reference must be between 1 and ~D."
		(second *display-table*)))))
  (values))

(defun add (&rest rules)
  (if (null *display-table*)
      (format t "~&Use LIST-RULES to specify a rule set.")
    (add-rule-list (first (first *display-table*)) (copy-list rules)))
  (values))

(defun list-all ()
  (format t "~%~%")
  (do ((n 1 (1+ n))
       (names *data* (cdr names)))
      ((null names) nil)
    (let ((rs (rule-set (car names))))
      (format t "~D.  ~5T~S~20T~S~40T~D~%" n (first rs) (second rs) (length (third rs)))))
  (values))

(defun add-rule (name rule)
  (let ((rs (rule-set name)))
    (cond ((null rs) (format t "~%Nonexistant rule set.~%"))
	  ((illegal-rule-p (second rs) rule)
	   (format t "~%Illegal format for ~S rule: ~S" (second rs) rule))
	  (t (setf (third rs) (adjoin rule (third rs) :test #'equal))
	     (msg t "~&Adding rule ~S to rule set ~S." rule name))))
	     ;)))
  nil)

(defun del-rule (name rule)
  (let ((rs (rule-set name)))
    (cond ((null rs) (format t "~%Nonexistant rule set.~%"))
	  ((illegal-rule-p (second rs) rule)
	   (format t "~%Illegal format for ~S rule." (second rs)))
	  (t (setf (third rs) (remove rule (third rs) :test #'equal))
	     (msg t "~&Deleting rule ~S from rule set ~S." rule name))))
	     ;)))
  nil)

(defun copy-rule-set (name-from name-to)
  (let ((rs1 (rule-set name-from))
	(rs2 (rule-set name-to)))
    (cond ((null rs1) (format t "~%~S does not exist.~%" name-from))
	  (rs2 (msg t "~&~S already exists." name-to))
	  (t (add-rule-set name-to (second rs1))
	     (direct-add-rule-list name-to (third rs1)))))
  nil)

(defun merge-rule-sets (name-from name-to)
  (let ((rs1 (rule-set name-from))
	(rs2 (rule-set name-to)))
    (cond ((null rs1) (format t "~&~S does not exist." name-from))
	  ((null rs2) (format t "~&~S does not exist." name-to))
	  ((not (eq (second rs1) (second rs2)))
	   (format t "~&~S and ~S are of different types." name-from name-to))
	  (t (direct-add-rule-list name-to (third rs1)))))
  nil)

(defun illegal-rule-p (rule-type rule)
  (cond ((eq rule-type 'RTN)
	 (check-syntax-of-rtn-rule rule))
	((eq rule-type 'SENTENCES)
	 (and (not (stringp rule))
	      (not (and (listp rule) (and-list (mapcar #'symbolp rule))))))
	((eq rule-type 'GPSG-TABLE)
	 (or (not (listp rule))
	     (not (= (length rule) 6))))
	((eq rule-type 'CFG-TABLE)
	 (or (not (listp rule))
	     (not (= (length rule) 5))))
	((eq rule-type 'CFG-GRAMMAR-TABLE) nil)
	((eq rule-type 'GPSG-GRAMMAR-TABLE) nil)
	((not (listp rule)) t)
	((eq rule-type 'DICTIONARY) (not (symbolp (car rule))))
	((not (eq (second rule) '==>)) t)
	((eq rule-type 'CFG)
	 (not (and-list (mapcar #'symbolp rule))))
	((eq rule-type 'GPSG)
	 (or (not (gpsg-exp (first rule)))
	     (not (and-list (mapcar #'gpsg-exp (cddr rule))))))
	(t t)))

(defun gpsg-exp (exp)
  (cond ((symbolp exp) t)
	((not (listp exp)) nil)
	((symbolp (car exp)) t)
	(t nil)))

(defun add-rule-list (name rule-list)
  (if (rule-set name)
      (mapc #'(lambda (rule) (add-rule name rule)) rule-list)
      (format t "~%Nonexistant rule set.~%"))
  nil)

(defun del-rule-list (name rule-list)
  (if (rule-set name)
      (mapc #'(lambda (rule) (del-rule name rule)) rule-list)
      (format t "~%Nonexistant rule set.~%"))
  nil)

(defun direct-add-rule-list (name rule-list)
  (if (rule-set name)
      (setf (third (rule-set name))
	    (union (third (rule-set name)) rule-list :test #'equal))
      (format t "~%Nonexistant rule set.~%"))
  nil)

(defun direct-del-rule-list (name rule-list)
  (let ((g (third (rule-set name))))
    (if g (setf g (apply #'nconc (mapcar #'(lambda (i) (if (member i rule-list
								   :test #'equal)
							   nil i))
					 g))))
    nil))

(defun filt (lst &optional (template '*))
  (remove-if-not #'(lambda (item) (filt-1 item template)) lst))

(defun filt-1 (item template)
  (cond ((eq template '*) t)
	((eq template '**) t)
	((eq item template) t)
	((not (listp item)) nil)
	((eq (car item) template) t)
	((symbolp template) nil)
	((eq (car template) '**) t)
	((and (filt-1 (car item) (car template))
	      (filt-1 (cdr item) (cdr template))) t)
	(t nil)))

(defun create-cfg-grammar (gram-name cfg-name root &optional cfg-special?
			     (transitive-closure t))
  (let ((cfg-set (rule-set cfg-name 'CFG)))
    (cond ((null cfg-set)
	   (format t "~%Bad name for CFG rule set.~%"))
	  ((rule-set gram-name)
	   (format t "~%Rule set ~S already exists.~%" gram-name))
	  (t (let* ((cfg (third cfg-set))
		    (non-terminals nil)
		    (Cpp (make-array (list (1+ (length cfg)))))
		    (Dp (make-array (list (1+ (length cfg)))))
		    (FIRSThash (make-hash-table :test #'eq))
		    (FIRST (make-array (list (1+ (length cfg)))))
		    (production-table (make-hash-table :test #'eq)))
	       (do ((p 0 (1+ p))
		    (productions cfg (cdr productions)))
		   ((null productions) nil)
		 ; The production table pairs off non-terminals N with rule numbers q s.t.
		 ;   Dq = N.
		 (push p (gethash (car (car productions)) production-table))
		 (setq non-terminals (adjoin (car (car productions)) non-terminals))
		 (setf (svref Cpp p) (cddr (car productions)))
		 (setf (svref Dp p) (car (car productions))))
	       (let ((firsts (cdr (make-first-table FIRST FIRSThash Dp Cpp (length cfg)
						    non-terminals))))
		 (add-rule-set gram-name 'CFG-GRAMMAR-TABLE)
		 (add-rule gram-name
			   (make-grammar-from-rtn firsts
			      (translate-cfg-to-rtn (cons `(*D0* ==> ,root $) (third cfg-set)))
			      cfg-special? transitive-closure))))))))

(defun create-gpsg-grammar (gram-name gpsg-name root &optional cfg-special?
			    (transitive-closure t))
  (let ((gpsg-set (rule-set gpsg-name 'GPSG)))
    (cond ((null gpsg-set)
	   (format t "~%Bad name for GPSG rule set.~%"))
	  ((rule-set gram-name)
	   (format t "~%Rule set ~S already exists.~%" gram-name))
	  (t (let* ((gpsg (get-gpsg (third gpsg-set)))
		    (non-terminals nil)
		    (Cpp (make-array (list (1+ (length (car gpsg))))))
		    (Dp (make-array (list (1+ (length (car gpsg))))))
		    (FIRSThash (make-hash-table :test #'eq))
		    (FIRST (make-array (list (1+ (length (car gpsg))))))
		    (production-table (make-hash-table :test #'eq)))
	       (do ((p 0 (1+ p))
		    (productions (car gpsg) (cdr productions)))
		   ((null productions) nil)
		 ; The production table pairs off non-terminals N with rule numbers q s.t.
		 ;   Dq = N.
		 (push p (gethash (car (car productions)) production-table))
		 (setq non-terminals (adjoin (car (car productions)) non-terminals))
		 (setf (svref Cpp p) (cddr (car productions)))
		 (setf (svref Dp p) (car (car productions))))
	       (let ((firsts (cdr (make-first-table FIRST FIRSThash Dp Cpp (length (car gpsg))
						    non-terminals))))
		 (add-rule-set gram-name 'GPSG-GRAMMAR-TABLE)
		 (direct-add-rule-list
		   gram-name (list
			       (make-grammar-from-rtn firsts
					 (translate-cfg-to-rtn (cons `(*D0* ==> ,root $)
								     (first gpsg)))
					 cfg-special? transitive-closure)
			       (second gpsg)))))))))

(defun save-to-lisp (path-name &rest particulars)
  (let ((to-save (if particulars
		     (mapcar #'(lambda (name) (rule-set name)) particulars)
		     (mapcar #'(lambda (name) (rule-set name)) *data*))))
    (with-open-file (out path-name :direction :output :if-exists :new-version)
      (format out ";;; -*- Mode: Lisp; Package: GPSG; Syntax: Common-Lisp; Base: 10 -*- ~%~%")
      (format out ";;; GRAMMAR DATA FILE~%")
      (mapc #'(lambda (rs)
		(cond ((member (second rs) '(CFG GPSG DICTIONARY RTN SENTENCES))
		       (format out "~%; Name: ~S  Type: ~S~%~%" (first rs) (second rs))
		       (format out "(add-rule-set '~S '~S)~%" (first rs) (second rs))
		       (format out "(add-rule-list '~S~%  '(~{~S~%    ~}))~%"
			       (first rs) (third rs))
		       (msg t "~&~S Saved." (first rs)))
		      (t (format t "~&Impossible to write ~S to Lisp file." (first rs)))))
	    to-save)))
  (values))

;; *******************************************
;;
;;  Dictionary
;;
;; *******************************************

(defun dictionary (dict word)
  ; The dictionary must return a symbol or list of symbols that represent the word's
  ; possible categories.
  (do ((defs nil defs)
       (d dict (cdr d)))
      ((null d) defs)
    (if (eq (caar d) word) (setq defs (append defs (cdar d))))))

;; *******************************************
;;
;;  Earley's Algorithm
;;
;; *******************************************

(defun create-cfg-table (table-name cfg-name root k)
  (let ((cfg (rule-set cfg-name 'CFG))
	(table (rule-set table-name)))
    (cond ((null cfg) (format t "~%There is no CFG named ~S.~%" cfg-name))
	  (table (format t "~%Illegal name for table.~%"))
	  ((not (or (integerp k) (= k 1) (= k 0)))
	   (format t "~%k must be either 0 or 1.~%"))
	  (t (add-rule-set table-name 'CFG-TABLE)
	     (let ((non-terminals nil)
		   (Cpp (make-array (list (1+ (length (third cfg))))))
		   (Dp (make-array (list (1+ (length (third cfg))))))
		   (FIRSThash (if (= k 1) (make-hash-table :test #'eq) nil))
		   (FIRST (if (= k 1) (make-array (list (1+ (length (third cfg)))))))
		   (production-table (make-hash-table :test #'eq)))
	       (do ((p 0 (1+ p))
		    (productions (cons `(*D0* ==> ,root $) (third cfg)) (cdr productions)))
		   ((null productions) nil)
		 ; The production table pairs off non-terminals N with rule numbers q s.t.
		 ;   Dq = N.
		 (push p (gethash (car (car productions)) production-table))
		 (setq non-terminals (adjoin (car (car productions)) non-terminals))
		 (setf (svref Cpp p) (cddr (car productions)))
		 (setf (svref Dp p) (car (car productions))))
	       (if (= k 1) (car (make-first-table FIRST FIRSThash Dp Cpp (length (third cfg))
					     non-terminals)))
	       (add-rule table-name (list production-table non-terminals Cpp Dp FIRST)))))
    nil))

(defun create-gpsg-table (table-name gpsg-name root k)
  (let ((gpsg (rule-set gpsg-name 'GPSG))
	(table (rule-set table-name)))
    (cond ((null gpsg) (format t "~%There is no GPSG named ~S.~%" gpsg-name))
	  (table (format t "~%Illegal name for table.~%"))
	  ((not (or (integerp k) (= k 1) (= k 0)))
	   (format t "~%k must be either 0 or 1.~%"))
	  (t (add-rule-set table-name 'GPSG-TABLE)
	     (let* ((gp (get-gpsg (third gpsg)))
		    (non-terminals nil)
		    (Cpp (make-array (list (1+ (length (car gp))))))
		    (Dp (make-array (list (1+ (length (car gp))))))
		    (FIRSThash (if (= k 1) (make-hash-table :test #'eq) nil))
		    (FIRST (if (= k 1) (make-array (list (1+ (length (car gp)))))))
		    (production-table (make-hash-table :test #'eq)))
	       (do ((p 0 (1+ p))
		    (productions (cons `(*D0* ==> ,root $) (car gp)) (cdr productions)))
		   ((null productions) nil)
		 ; The production table pairs off non-terminals N with rule numbers q s.t.
		 ;   Dq = N.
		 (push p (gethash (car (car productions)) production-table))
		 (setq non-terminals (adjoin (car (car productions)) non-terminals))
		 (setf (svref Cpp p) (cddr (car productions)))
		 (setf (svref Dp p) (car (car productions))))
	       (if (= k 1) (car (make-first-table FIRST FIRSThash Dp Cpp (length (car gp))
					     non-terminals)))
	       (add-rule table-name (list production-table non-terminals Cpp Dp FIRST
					  (second gp))))))
    nil))

(defun make-first-table (FIRST FIRSThash Dp Cpp size non-terminals)
  ; This computes the table FIRST, which matches symbols with all the terminals
  ; that could be leftmost in an arbitrary expansion of them.
  ;
  ; First compute simple emptys.
  (do ((p 0 (1+ p)))
      ((> p size) nil)
    (if (null (svref Cpp p))
	(setf (gethash (svref Dp p) FIRSThash) '(*EMPTY*))))
  ; Now do complicated stuff until no members are added to FIRST(Dp).
  (do ((i 1 (1+ i))
       (some-added 0 some-added))
      ((> 0 some-added) nil)
    (msg t "~%Round ~D. ~D added." i some-added)
    (setq some-added -1)
    (do ((p 0 (1+ p)))
	((> p size) nil)
      (let ((D (svref Dp p))
	    (Cp (svref Cpp p))
	    (FIRST-Dp (gethash (svref Dp p) FIRSThash)))
	(cond ((null Cp) nil)
	      (t (do ((Cpq Cp (cdr Cpq)))
		     ((or (null Cpq) ; End of expansion
			  (not (member '*EMPTY* (gethash (car Cpq) FIRSThash)))); Cpq not empty
		      (cond ((null Cpq)) ; Expansion can be empty.
			    ((not (member (car Cpq) non-terminals)) ; Cpq is a terminal
			     (cond ((not (member (car Cpq) FIRST-Dp))
				    (setf (gethash D FIRSThash) (cons (car Cpq) FIRST-Dp))
				    (incf some-added))))
			    (t ; Cpq not empty
			     (let* ((FIRST-Cpq (gethash (car Cpq) FIRSThash))
				    (c (union FIRST-Dp FIRST-Cpq :test #'eq)))
			       (cond ((= (length FIRST-Dp) (length c)))
				     (t (setf (gethash D FIRSThash) c)
					(incf some-added)))))))
		   ; Cpq is a non-terminal which can be empty.
		   (let* ((FIRST-Cpq (gethash (car Cpq) FIRSThash))
			  (c (union FIRST-Dp FIRST-Cpq :test #'eq)))
		     (cond ((= (length FIRST-Dp) (length c))) ; Nothing has been added.
			   (t (setq FIRST-Dp c) ; Something has been added.
			      (setf (gethash D FIRSThash) FIRST-Dp)
			      (incf some-added))))))))))
  ; Now create FIRST from FIRSThash
  (do ((p 0 (1+ p)))
      ((> p size) (cons FIRST FIRSThash))
    (setf (svref FIRST p)
	  (do ((res nil res)
	       (lst (svref Cpp p) (cdr lst))
	       (stop nil stop))
	      ((or stop (null lst))
	       (if (null (svref Cpp p))
		   (push '*EMPTY* res))
	       res)
	    (let ((res+ (if (member (car lst) non-terminals)
			    (gethash (car lst) FIRSThash)
			  (list (car lst)))))
	      (if (not (member '*EMPTY* res+ :test #'eq))
		  (setq stop t))
	      (setq res (append res+ res)))))))

(defvar state-table nil)
(defun earley-parse (g gd words &optional (use-lookahead-if-available t)
		    (print-states nil))
  ; This algorithm differs from Jay Earley's in that it only allows k = 0 or k = 1
  ; (either zero or one token lookahead).  Thus a state item is only a triple and not a
  ; quadruple.  In practice 1 is the most efficient value for k.
  ;
  ; To make the algorithm a parser instead of just a recognizer, we add one more bit of
  ; information to each item, making it a quadruple.  Thus an item I is (p, j, f, cw).
  ; The cw [completed with] is the list of items which allowed the completion operator to
  ; create this item.
  ;
  ; We add one more optimisation to the Earley routine, checking whether
  ; a category has been predicted before, before we go through and predict
  ; everything again.
  ;
  (cond ((or (not (or (rule-set g 'CFG-TABLE) (rule-set g 'GPSG-TABLE)))
	     (not (rule-set gd 'DICTIONARY)))
	 (format t "~&Either ~S is not a CFG-TABLE or a GPSG-TABLE, " g)
	 (format t "or ~S is not a DICTIONARY." gd)
	 nil)
	((member nil (mapcar #'(lambda (w) (dictionary (third (rule-set gd)) w)) words))
	 (format t "~&One or more words in ~S were unknown." words)
	 nil)
	(t
	 (let* ((g* (car (third (rule-set g))))
		(gd* (third (rule-set gd)))
		(production-table (first g*))
		(non-terminals (second g*))
		(Cpp (third g*))
		(Dp (fourth g*))
		(FIRST (if use-lookahead-if-available (fifth g*)))
		(gpsg-table (sixth g*))
		(n (length words))
		(Predicted nil)
		(CompTable (make-array (+ n 2)))
		(l-vector (make-array (+ n 1) :initial-contents
				      (append words '($))))
		(defs (append (mapcar #'(lambda (w) (dictionary gd* w)) words) '(($))))
		(d-vector (make-array (+ n 1) :initial-contents defs))
		(w-vector (make-array (+ n 1) :initial-contents
				      (mapcar #'(lambda (w)
						  (mapcar #'(lambda (d)
							      (if (symbolp d) d (car d)))
							  w))
					      defs)))
		(empty-vector (make-array (+ n 2) :initial-element nil))
		(s-vector (make-array (+ n 2) :initial-element nil)))
	   (do ((i 0 (1+ i)))
	       ((> i (1+ n)) nil)
	     (setf (svref s-vector i)
		   (cons nil (make-array (1+ i) :initial-element nil))
		   (svref CompTable i)
		   (make-hash-table :test #'eq)))
	   (add-state s-vector 0 0 0 0 CompTable Cpp Dp)
	   ;;
	   ;; Main Earley loop, i goes from 1 to n.
	   ;;
	   (do ((i 0 (1+ i)))
	       ((or (> i n) (null (get-state-list s-vector i))) nil)
	     (setq Predicted (make-hash-table :test #'eq))
	     ;;
	     ;; Process states in order.
	     ;;
	     (do ((states (get-state-list s-vector i) (cdr states)))
		 ((null states) nil)
	       (cond ((predictor (car states) i s-vector Cpp w-vector non-terminals
				 production-table FIRST CompTable Dp Predicted empty-vector))
		     ((completer (car states) i s-vector Cpp Dp CompTable empty-vector))
		     (t (scanner (car states) i s-vector Cpp w-vector l-vector CompTable
				 Dp d-vector))))
	     ;
	     ; Print out all states.
	     ;
	     (if print-states
		 (mapc #'(lambda (o) (print-state i (first o) (second o) (third o) Dp Cpp))
		       (get-state-list s-vector i))))

	   (if print-states
	       (progn (mapc #'(lambda (o) (print-state n (first o) (second o)
						       (third o) Dp Cpp))
			    (get-state-list s-vector n))
		      (mapc #'(lambda (o) (print-state (1+ n) (first o) (second o) (third o)
						       Dp Cpp))
			    (get-state-list s-vector (1+ n)))))
	   ;
	   ; Check for success.
	   ;
	   ;; If Si+1 = |(0,2,0)|, return acceptance.
	   (cond ((and (= 1 (length (get-state-list s-vector (1+ n))))
		       (item-equal '(0 2 0) (car (get-state-list s-vector (1+ n)))))
		  (setq state-table (list (second (rule-set g)) n Dp s-vector gpsg-table))
		  t)
		 (t (setq state-table (list (second (rule-set g)) n Dp s-vector gpsg-table))
		    nil))))
	(t (format t "~%Bad name for the table or dictionary, or unknown words.~%"))))

(defun retrieve-parses (&optional (template '*) &key print-states)
  ; This function retrieves parses from the last Earley parse that match the given template.
  (cond ((eq (first state-table) 'CFG-TABLE)
	 (let ((n (second state-table))
	       (Dp (third state-table))
	       (s-vector (fourth state-table)))
	   (let ((root-items (mapcar #'car (production-lists (first (get-state-list s-vector
										    (1+ n)))
						     Dp))))
	     (get-template-parses root-items Dp s-vector template nil
				  (make-hash-table :test #'eq)))))
	((eq (first state-table) 'GPSG-TABLE)
	 (let ((n (second state-table))
	       (Dp (third state-table))
	       (s-vector (fourth state-table))
	       (gpsg-table (fifth state-table)))
	   (let* ((root-items (mapcar #'car (production-lists (first (get-state-list s-vector
									    (1+ n)))
							 Dp))))
	     (gpsg-template-parses root-items Dp s-vector template nil
				   (make-hash-table :test #'eq) gpsg-table
				   print-states))))
	((or (eq (first state-table) 'CFG-GRAMMAR-TABLE)
	     (eq (first state-table) 'GPSG-GRAMMAR-TABLE))
	 (let ((result
		(filt (mapcar #'second
			      (let ((phrases nil))
				(mapc #'(lambda (item)
					  (let ((q (first item)) (j (second item)))
					    (if (and (= j 0)
						     (aref (seventh (seventh state-table)) q)
						     (= (aref (fourth state-table) q)
							(fifth state-table)))
						(setq phrases
						      (append phrases
							      (recover-phrases
							       0 (length (sixth state-table))
							       q
							       (sixth state-table)
							       (second state-table)
							       (seventh state-table)
							       (eighth state-table)))))))
				      (aref (second state-table)
					    (third state-table)))
				phrases))
		      template)))
	   (if (eq (first state-table) 'CFG-GRAMMAR-TABLE) result
	     (gpsg-filt result (ninth state-table) (tenth state-table)
			(make-hash-table :test #'eq) print-states))))
	(t (msg t "~%The parse data is not available.~%") nil)))

(defun store-state-table (&rest data)
  (setq state-table (copy-list data)))

(defun predictor (state i s-vector Cpp w-vector non-terminals production-table FIRST
			CompTable Dp Predicted empty-vector)
  (if (not (final-p state Cpp)) ;; If s is a nonfinal state
      (let ((Cpj+1 (nth (second state) (svref Cpp (car state)))))
	(cond ((and (member Cpj+1 non-terminals) ;; and Cp(j+1) is a non-terminal,
		    (not (gethash Cpj+1 Predicted)))
	       ;; and Cpj+1 has not been predicted before
	       ;; then for each q s.t. Dq = Cp(j+1) add (q,0,i) to Si
	       ;; if Dq can possible expand into Xi.
	       (progn
		 (mapc #'(lambda (q)
			    (if (or (not FIRST)
				    (member '*EMPTY* (svref FIRST q) :test #'eq)
				    (apply #'append
					   (mapcar #'(lambda (w) (member w (svref FIRST q)
									 :test #'eq))
						   (svref w-vector i))))
			      (add-state s-vector i q 0 i CompTable Cpp Dp)))
		       (gethash Cpj+1 production-table))
		 (setf (gethash Cpj+1 Predicted) t)
		 t))
	      ((let ((m (assoc Cpj+1 (svref empty-vector i))))
		 (if m (completer-add-state s-vector i (car state) (1+ (second state))
					    (third state) (list state (cdr m))
					    CompTable Cpp Dp))
		 nil))))))

(defun completer (state i s-vector Cpp Dp CompTable empty-vector)
  (if (final-p state Cpp) ; If s is a final state
      ; Then for each (q,l,g) in Sf (after all states have been added to Sf) such that
      ; Cq(l+1) = Dp, add (q,l+1,g) to Si.
      (let* ((D (svref Dp (car state)))
	     (States (gethash D (svref CompTable (third state)))))
	(cond ((= i (third state))
	       (push (cons (svref Dp (car state)) state) (aref empty-vector i))))
	(mapc #'(lambda (Sf)
		   (completer-add-state s-vector i (car Sf) (1+ (second Sf))
					(third Sf) (list Sf state) CompTable Cpp Dp))
	      States))))

(defun scanner (state i s-vector Cpp w-vector l-vector CompTable Dp d-vector)
  (cond ((not (final-p state Cpp)) ;; If s is a nonfinal state
	 (let ((Cpj+1 (nth (second state) (svref Cpp (car state)))))
	   ;; and Cp(j+1) is terminal, then if Cp(j+1) = Xi+1, add (p,j+1,f) to Si+1.
	   (if (or (eq Cpj+1 (svref w-vector i))
		   (and (consp (svref w-vector i))
			(member Cpj+1 (svref w-vector i) :test #'eq)))
	       (completer-add-state s-vector (1+ i) (car state) (1+ (second state))
				    (third state) (list state (list Cpj+1
								    (svref l-vector i)
								    (svref d-vector i)))
				    CompTable Cpp Dp))))))

(defun final-p (state Cpp)
  ; A final state is one in which j = (number of symbols on right side of production)
  (= (second state) ; j
     (length (svref Cpp (car state)))))

(defun add-state (state-set set-num p j f CompTable Cpp Dp)
;;  (print-state set-num p j f Dp Cpp) (princ '--)
  (let* ((state (list p j f nil))
	 (states (svref state-set set-num))
	 (begin-and-end-pointer (car states))
	 (sf-vect (cdr states)))
    (cond ((member state (svref sf-vect f) :test #'item-equal) nil)
	  ((null begin-and-end-pointer) ; No state items in state set yet.
	   (push state (svref sf-vect f)) ; Put state in vector for quick lookup.
	   (let ((first-item (cons state nil)))
	     (rplaca states (cons first-item first-item)))
	   (push state (gethash (nth j (svref Cpp p)) (svref CompTable set-num))))
	  (t (push state (svref sf-vect f)) ; Put state in vector for quick lookup.
	     (let ((new-end (cons state nil))) ; Put state at end of table for general search.
	       (rplacd (cdr begin-and-end-pointer) new-end)
	       (rplacd begin-and-end-pointer new-end))
	     (push state (gethash (nth j (svref Cpp p)) (svref CompTable set-num)))))
    nil))

(defun completer-add-state (state-set set-num p j f cw CompTable Cpp Dp)
;;  (print-state set-num p j f Dp Cpp) (princ '--)
  ; When the completion operator creates new states, many of them are equal, since
  ; an item may be completed in an ambiguous manner.  To record all parses however, we
  ; need to record each completion.  This function handles such cases.
  (let* ((state (list p j f (list cw)))
	 (states (svref state-set set-num))
	 (begin-and-end-pointer (car states))
	 (sf-vect (cdr states))
	 (m (member state (svref sf-vect f) :test #'item-equal)))
    (cond (m ; state is already stored, but must have this new cw added to it.
	   ; each cw is of the form (a b) where a is the item this new item was created from,
	   ; and b is the item that caused the creation.
	   (rplaca (cdddr (car m)) ; gives us the old list of cw's
		   (adjoin cw (item-cw (car m)) :test #'cw-item-equal)))
	  ((null begin-and-end-pointer) ; No state items in state set yet.
	   (push state (svref sf-vect f)) ; Put state in vector for quick lookup.
	   (let ((first-item (cons state nil)))
	     (rplaca states (cons first-item first-item)))
	   (push state (gethash (nth j (svref Cpp p)) (svref CompTable set-num))))
	  (t (push state (svref sf-vect f)) ; Put state in vector for quick lookup.
	     (let ((new-end (cons state nil))) ; Put state at end of table for general search.
	       (rplacd (cdr begin-and-end-pointer) new-end)  
	       (rplacd begin-and-end-pointer new-end))
	     (push state (gethash (nth j (svref Cpp p)) (svref CompTable set-num)))))
    nil))

(defun get-state-list (state-set set-num)
  (car (car (svref state-set set-num))))

(defun item-equal (i1 i2)
  (and (= (car i1) (car i2)) (= (cadr i1) (cadr i2)) (= (caddr i1) (caddr i2))))

(defun get-template-parses (items Dp s-vector template trail already-done)
  (if (or (eq template '*) (eq template '**)) (get-all-parses items Dp s-vector trail
							      already-done)
      (apply #'append
	     (mapcar #'(lambda (item)
		  (cond ((not (integerp (car item)))
			 (if (eq template (car item)) ;; Item is a lexical item
			     (list (list (first item) (second item)))
			     nil))
			((symbolp template)
			 (if (eq template (svref Dp (car item)))
			     (get-all-parses (list item) Dp s-vector trail
					     already-done)
			     nil))
			((or (eq (car template) (svref Dp (car item)))
			     (eq (car template) '*) (eq (car template) '*))
			 (cond ((gethash item already-done))
			       ((member item trail :test #'eq)
				(list (format nil "recursive-~D"
					      (position item trail :test #'eq))))
			       (t (setf (gethash item already-done)
				     (mapcan #'(lambda (prod-items)
			       (do ((parses (list (list (svref Dp (car item)))) ps)
				    (tmplt (cdr template) (if (eq (car tmplt) '**)
							      tmplt (cdr tmplt)))
				    (ps nil nil)
				    (exp-items prod-items (cdr exp-items)))
				   ((or (null exp-items) (null parses))
				    (if (or (null tmplt) (eq (car tmplt) '**)) parses nil))
				 (let ((deep-parses
					 (get-template-parses (list (car exp-items))
							      Dp s-vector
								(if (eq (car tmplt) '**)
								    '* (car tmplt))
							        (cons item trail)
								already-done)))
				   (mapc #'(lambda (p)
					     (mapc #'(lambda (deep-parse)
						       (push (append p (list deep-parse)) ps))
						   deep-parses))
					 parses))))
					     (production-lists item Dp))))))
			(t nil)))
		  items))))

(defun get-all-parses (items Dp s-vector trail already-done)
  (apply #'append
	 (mapcar #'(lambda (item)
	      (cond ((not (integerp (car item)))
		     (list (list (first item) (second item))))
		    ((member item trail :test #'eq)
		     (list (format nil "recursive-~D"
				   (position item trail :test #'eq))))
		    ((gethash item already-done))
		    (t (setf (gethash item already-done)
			   (mapcan #'(lambda (prod-items)
			     (do ((parses (list (list (svref Dp (car item)))) ps)
				  (ps nil nil)
				  (exp-items prod-items (cdr exp-items)))
				 ((or (null exp-items) (null parses)) parses)
			       (let ((deep-parses (get-all-parses (list (car exp-items)) Dp
								  s-vector
								  (cons item trail)
								  already-done)))
				 (mapc #'(lambda (p)
					   (mapc #'(lambda (deep-parse)
						     (push (append p
								   (list deep-parse))
							   ps))
						 deep-parses))
				       parses))))
				   (production-lists item Dp))))))
	      items)))
 
(defun production-lists (item Dp)
  ; Go backwards getting previous items this one was completed from.
  (production-lists-1 (list (list item)) Dp))

(defun production-lists-1 (lists Dp)
  (cond ((= 0 (second (car (car lists))))
	 (mapcar #'cdr lists))
	(t (production-lists-1
	     (mapcan #'(lambda (l)
			 (mapcar #'(lambda (new-cw) (cons (car new-cw) (cons (cadr new-cw)
									     (cdr l))))
				 (item-cw (car l))))
		     lists)
	     Dp))))

(defun completed-because-of (item)
  (mapcar #'second (item-cw item)))

(defun completed-from (item)
  (mapcar #'car (item-cw item)))

(defun item-cw (item)
  (fourth item))

(defun cw-item-equal (i1 i2)
  (and (item-equal (first i1) (first i2))
       (item-equal (second i1) (second i2))))

(defun print-state (i p j f Dp Cpp)
  (format t "~&~D  ~D   ~S ==>~{ ~S~} .~{ ~S~}"
	  i f (svref Dp p) (subseq (svref Cpp p) 0 j) (subseq (svref Cpp p) j)))

(defvar *gram* nil)
(defvar *dict* nil)
(defun p (sentence &key (template '*) grammar dictionary (use-lookahead t)
	  print-states file sentence-set)
  (if grammar (setq *gram* grammar))
  (if dictionary (setq *dict* dictionary))
  (cond ((null (rule-set *dict* 'DICTIONARY))
	 (format t "~&Please specify a DICTIONARY.")
	 (format t "~&(p sentence &key (template '*) grammar dictionary ")
	 (format t "(use-lookahead t) print-states) file sentence-set"))
	((and sentence-set (null (rule-set sentence-set 'SENTENCES)))
	 (format t "~&~S is not a SENTENCES rule set." sentence-set))
	((null (or (rule-set *gram* 'CFG-GRAMMAR-TABLE)
		   (rule-set *gram* 'GPSG-GRAMMAR-TABLE)
		   (rule-set *gram* 'GPSG-TABLE)
		   (rule-set *gram* 'CFG-TABLE)))
	 (format t "~&Please specify either a CFG-TABLE, a GPSG-TABLE, a CFG-GRAMMAR-TABLE,")
	 (format t " or a GPSG-GRAMMAR-TABLE.")
	 (format t "~&(p sentence &key (template '*) grammar dictionary ")
	 (format t "(use-lookahead t) print-states) file sentence-set"))
	(t (let ((sents (if sentence-set
			  (if sentence
			    (cons (listify sentence)
				  (mapcar #'listify (third (rule-set sentence-set))))
			    (mapcar #'listify (third (rule-set sentence-set))))
			  (list (listify sentence)))))
	     (cond
	       (file
		(with-open-file (out file :direction :output :if-exists :new-version)
		  (format out "~%~%~%*** PARSE RESULTS ***~%")
		  (mapc #'(lambda (sent)
			     (format out "~%~%Sentence: ~{~S ~}" sent)
			    (let ((res
				    (if (or (rule-set *gram* 'CFG-GRAMMAR-TABLE)
					    (rule-set *gram* 'GPSG-GRAMMAR-TABLE))
				      (parse *gram* *dict* sent use-lookahead print-states)
				      (earley-parse *gram* *dict* sent use-lookahead
						    print-states))))
			    (let ((results (if res (retrieve-parses template
								    :print-states print-states)
					     nil)))
			      (format out "~%Number of parses: ~S~%" (length results))
			      ;;(format out "~{~%~S~%~}" results)
                              (dolist (result results)
                                (terpri out)
				(pprint result out))
			      )))
			sents)))
	       (sentence-set
		(mapcar #'(lambda (sent)
			    (format t "~&Sentence: ~S" sent)
			    (let ((res 
				    (if (or (rule-set *gram* 'CFG-GRAMMAR-TABLE)
					    (rule-set *gram* 'GPSG-GRAMMAR-TABLE))
				      (parse *gram* *dict* sent use-lookahead print-states)
				      (earley-parse *gram* *dict* sent
						    use-lookahead print-states))))
			      (cons sent
				    (if res (retrieve-parses template :print-states
							     print-states) nil))))
			sents))
	       (t
		(let ((res (if (or (rule-set *gram* 'CFG-GRAMMAR-TABLE)
				   (rule-set *gram* 'GPSG-GRAMMAR-TABLE))
			     (parse *gram* *dict* (car sents) use-lookahead print-states)
			     (earley-parse *gram* *dict* (car sents) use-lookahead
					   print-states))))
		  (if res (retrieve-parses template :print-states print-states)))))))))