; -*- Mode: Lisp; Package: GPSG; Base: 10; Syntax: Common-Lisp -*-
;; (in-package 'gpsg :use '(lisp))

(defmacro name (element)
  `(car ,element))

(defmacro index (element)
  `(cadr ,element))

(defun fs (l)
  (cond ((null l) nil)
	((stringp (car l)) l)
	(t (fs (cdr l)))))

;;; Routines to build tables used by the Earley parser

(defun make-state-name (head pre post)
 (append (list head '==>) pre '(".") post))

(defun get-state-name-array-and-table (rtn)
  (msg t "~&Build state name array and table.")
  (let ((state-name-table (make-hash-table :test #'equal)))
    (do ((states rtn (cdr states))
	 (stateno 0 (1+ stateno)))
	((null states)
	 (let ((state-name-array (make-array stateno)))
	   (mapc #'(lambda (element)
		     (setf (aref state-name-array (index element))
			   (name element)))
		 (list-hash-table state-name-table))
	   (list state-name-array state-name-table)))
      (let ((state (car states))
	    (state-name (caar states)))
	(cond ((gethash state-name state-name-table)
	       (error "This is a duplicated state." state))
	      (t (setf (gethash state-name state-name-table) stateno)))))))

(defun stateno-of (state-name state-name-table)
 (let ((stateno (gethash state-name state-name-table)))
  (if (null stateno)
      (error "There is no such state." state-name)
      stateno)))

; If there are no categories defined in the RTN, this routine
; creates an array of size 1 in order to get around the Maclisp
; requirement that arrays have dimensions greater than 0.

(defun get-category-name-array-and-table (rtn)
  (msg t "~&Creating category name array and table.")
  (let ((category-name-table (make-hash-table :test #'eq))
	(categoryno 0))
    (mapc #'(lambda (state)
	      (mapc #'(lambda (arc)
			(if (eq (first arc) 'category)
			    (let ((category-name (second arc)))
			      (cond ((not (gethash category-name category-name-table))
				     (setf (gethash category-name category-name-table)
					   categoryno)
				     (incf categoryno))))))
		    (second state)))
	  rtn)
    (list (let ((category-name-array (make-array categoryno)))
	    (mapc #'(lambda (element)
		      (setf (aref category-name-array (index element))
			    (name element)))
		  (list-hash-table category-name-table))
	    category-name-array)
	  category-name-table)))

(defun categoryno-of (category-name category-name-table)
  (gethash category-name category-name-table))

(defun categorynos-of (word-name dictionary)
 (gethash word-name dictionary))

; This routine assumes that there is at least one state and at least
; one category in the RTN.

(defun build-delta-category (rtn state-name-array state-name-table
				 category-name-array category-name-table)
  (msg t "~&Building delta-category.")
  (let* ((nostates (first (array-dimensions state-name-array)))
	 (nocategories (first (array-dimensions category-name-array)))
	 (delta-category (make-array (list nostates nocategories) :initial-element nil)))
    (mapc #'(lambda (state)
	      (let ((stateno (stateno-of (first state) state-name-table))
		    (arcs (second state)))
		(mapc #'(lambda (arc)
			  (if (eq (first arc) 'category)
		      (let* ((category-name (second arc))
			     (categoryno
			      (categoryno-of category-name category-name-table))
			     (next-state-name (third arc))
			     (next-stateno
			      (stateno-of next-state-name state-name-table)))
			(if (not (member next-stateno
					 (aref delta-category
					       stateno categoryno) :test #'equal))
			    (setf (aref delta-category stateno categoryno)
				  (cons next-stateno
					(aref delta-category
					      stateno categoryno)))))))
		      arcs)))
	  rtn)
    delta-category))

(defun build-delta-push (rtn state-name-table)
  (msg t "~&Building delta-push.")
  (let ((delta-push (make-hash-table :test #'equal)))
    (mapc #'(lambda (state)
	      (let ((stateno (stateno-of (first state) state-name-table))
		    (arcs (second state)))
		(mapc #'(lambda (arc)
			  (if (eq (first arc) 'push)
		      (let* ((push-state-name (second arc))
			     (push-stateno
			      (stateno-of push-state-name state-name-table))
			     (next-state-name (third arc))
			     (next-stateno
			      (stateno-of next-state-name state-name-table))
			     (entry
			      (gethash (list stateno push-stateno) delta-push)))
			(if (not (member next-stateno entry :test #'equal))
			    (setf (gethash (list stateno push-stateno) delta-push)
				  (cons next-stateno entry))))))
		      arcs)))
	  rtn)
    delta-push))

(defun trace-h (h stateno h-stateno delta-category delta-push state-name-array)
 (let ((nostates (first (array-dimensions delta-category)))
       (nocategories (second (array-dimensions delta-category)))
       (h-next-stateno (aref h stateno)))
  (cond ((null h-next-stateno)
         (setf (aref h stateno) h-stateno)
	 (do ((categoryno 0 (1+ categoryno)))
	     ((= categoryno nocategories))
	   (mapc #'(lambda (next-stateno)
		     (trace-h h next-stateno h-stateno delta-category
			      delta-push state-name-array))
		 (aref delta-category stateno categoryno)))
	 (do ((push-stateno 0 (1+ push-stateno)))
	     ((= push-stateno nostates))
	   (mapc #'(lambda (next-stateno)
		     (trace-h h next-stateno h-stateno delta-category
			      delta-push state-name-array))
		 (gethash (list stateno push-stateno) delta-push))))
        ((not (= h-stateno h-next-stateno))
         (error "This state has an ambiguous parent."
                 (aref state-name-array stateno))))))

(defun build-h (delta-category delta-push state-name-array)
  (msg t "~&Building build-h.")
  (let* ((nostates (first (array-dimensions delta-category)))
	 (nocategories (second (array-dimensions delta-category)))
	 (h (make-array nostates :initial-element nil))
	 ;; push-state?[stateno] is t if stateno can be pushed to
	 (push-state?
	   (do ((push-state? (make-array nostates :initial-element nil) push-state?)
		(push-stateno 0 (1+ push-stateno)))
	       ((>= push-stateno nostates) push-state?)
	     (do ((stateno 0 (1+ stateno))
		  (quit nil quit))
		 ((or (>= stateno nostates) quit))
	       (if (not (null (gethash (list stateno push-stateno) delta-push)))
		   (setf (aref push-state? push-stateno) t quit t)))))
	 ;; next-state?[stateno] is t if stateno can be reached as a next state
	 (next-state?
	  (do ((next-state? (make-array nostates :initial-element nil))
	       (stateno 0 (1+ stateno)))
	      ((= stateno nostates) next-state?)
	    (do ((categoryno 0 (1+ categoryno)))
		((= categoryno nocategories))
	      (mapc #'(lambda (next-stateno)
			(setf (aref next-state? next-stateno) t))
		    (aref delta-category stateno categoryno)))
	    (do ((push-stateno 0 (1+ push-stateno)))
		((= push-stateno nostates))
	      (mapc #'(lambda (next-stateno)
			(setf (aref next-state? next-stateno) t))
		    (gethash (list stateno push-stateno) delta-push))))))
    ;; all states which can be pushed to or which are not next states
    ;; have themselves as parents
    (do ((stateno 0 (1+ stateno)))
	((= stateno nostates))
      (if (or (aref push-state? stateno) (not (aref next-state? stateno)))
	  (trace-h h stateno stateno delta-category delta-push state-name-array)))
    h))

; This routine assumes that there is at least one arc in the RTN.

(defun build-h-cfg-special (rtn state-name-table)
  (msg t "~&Building h-cfg-special.")
  (let ((h (make-array (length rtn))))
    (mapc #'(lambda (element)
	      (setf (aref h (stateno-of (name element) state-name-table))
		    (if (symbolp (name element))
			(stateno-of (name element) state-name-table)
		      (stateno-of (first (name element)) state-name-table))))
	  (list-hash-table state-name-table))
    h))

; This routine assumes that there is at least one state in the RTN.

(defun build-l* (rtn state-name-array state-name-table
		     &optional (transitive-closure? t))
  (msg t "~&Building l*.")
  (let* ((nostates (first (array-dimensions state-name-array)))
	 (l* (make-array nostates :initial-element nil)))
    (mapc #'(lambda (state)
	      (let ((stateno (stateno-of (first state) state-name-table))
		    (arcs (second state)))
		(setf (aref l* stateno)
		      (make-hash-table :test #'eq))
		(mapc #'(lambda (arc)
			  (if (eq (first arc) 'push)
			      (setf (gethash (stateno-of (second arc) state-name-table)
					     (aref l* stateno)) t)))
		      arcs)))
	  rtn)
    (if transitive-closure?
	(do ((count 0 (1+ count))
	     (again? t again?))
	    ((not again?))
	  (setq again? nil)
	  (do ((stateno 0 (1+ stateno)))
	      ((= stateno nostates))
	    (let ((l*-stateno (aref l* stateno)))
	      (mapc #'(lambda (element1)
			(mapc #'(lambda (element2)
				  (if (not (gethash (car element2)
						    l*-stateno))
				      (setf (gethash (car element2)
						     l*-stateno)
					    t again? t)))
			      (list-hash-table (aref l* (car element1)))))
		    (list-hash-table l*-stateno))))))
    (do ((stateno 0 (1+ stateno)))
	((= stateno nostates) l*)
      (setf (aref l* stateno)
	    (mapcar #'car (list-hash-table (aref l* stateno)))))))

; This routine assumes that there is at least one state in the RTN.

(defun build-final? (rtn state-name-array state-name-table)
  (msg t "~&Build final?.")
  (let ((final? (make-array (first (array-dimensions state-name-array))
			    :initial-element nil)))
    (mapc #'(lambda (state)
	      (let ((stateno (stateno-of (first state) state-name-table))
		    (arcs (second state)))
		(if (member '(pop) arcs :test #'equal)
		    (setf (aref final? stateno) t))))
	  rtn)
    final?))


;;; The Earley parser proper begins here.

(defun print-item (item i state-name-array)
  (format t "~&~D  ~D   ~A" i (second item) (aref state-name-array (first item))))

(defun print-item-set (i item-set state-name-array)
  (mapc #'(lambda (item) (print-item item i state-name-array)) item-set))

(defun recover-phrases (j i q words item-set-array grammar word-categories &optional trail)
  (let* ((state-name-array (nth 0 grammar))
	 (delta-category (nth 2 grammar))
	 (delta-push (nth 3 grammar))
	 (h (nth 4 grammar))
	 (final? (nth 6 grammar))
	 (category-name-array (nth 8 grammar)))
  (cond
   ((and (= j i) (= (aref h q) q))
    (list (list (aref state-name-array q))))
   ((member (list j i q) trail :test #'equal)
    (list (list (format nil "recursive-~D" (position (list j i q) trail :test #'equal)))))
   (t (append
       (if (= i 0)
	   '()
	 (let ((items (aref item-set-array (1- i)))
	       (collect nil))
	   (mapc #'(lambda (item)
		 (let ((q-prime (first item))
		       (j-prime (second item))
		       (cs (aref word-categories (1- i)))
		       (word-cat nil))
		   (if (and (= j-prime j)
			    (do ((c cs (cdr c)))
				((null c) nil)
			      (cond ((member q (aref delta-category q-prime
						     (car c)) :test #'equal)
				     (setq word-cat (aref category-name-array (car c)))
				     (return t)))))
		       (mapc #'(lambda (phrase)
				 (push (append phrase
					       (list (list word-cat (nth (1- i) words))))
				       collect))
			     (recover-phrases
			      j (1- i) q-prime
			      words item-set-array grammar
			      word-categories
			      (cons (list j i q) trail))))))
		 items)
	   collect))
       (let ((some-phrases nil)
	     (items (aref item-set-array i)))
	 (mapc #'(lambda (item)
		   (let ((q-prime (first item))
			 (j-prime (second item)))
		     (if (aref final? q-prime)
			 (mapc #'(lambda (item1)
				   (let ((q-double-prime (first item1))
					 (j-double-prime (second item1)))
				     (if (and (= j-double-prime j)
					      (member q (gethash (list q-double-prime
								       (aref h q-prime))
								 delta-push)
						      :test #'equal))
					 (mapc #'(lambda (phrase2)
						   (mapc #'(lambda (phrases1)
							     (push (append phrase2
									   (list phrases1))
								   some-phrases))
							 (recover-phrases
							  j-prime i q-prime
							  words item-set-array grammar
							  word-categories
							  (cons (list j i q) trail))))
					       (recover-phrases
						j j-prime q-double-prime
						words item-set-array grammar
						word-categories
						(cons (list j i q) trail))))))
			       (aref item-set-array j-prime)))))
		      items)
		some-phrases))))))


(defun parse (gram dict sentence &optional (use-lookahead t) (print-states nil))
  (cond ((and (or (rule-set gram 'CFG-GRAMMAR-TABLE)
		  (rule-set gram 'GPSG-GRAMMAR-TABLE))
	      (rule-set dict 'DICTIONARY))
	 (let* ((gd* (cons '($ $) (third (rule-set dict))))
		(grammar (car (third (rule-set gram))))
		(words (append sentence '($)))
		(state-name-array (nth 0 grammar))
		(state-name-table (nth 1 grammar))
		(delta-category (nth 2 grammar))
		(delta-push (nth 3 grammar))
		(h (nth 4 grammar))
		(l* (nth 5 grammar))
		(final? (nth 6 grammar))
		(firsts (nth 7 grammar))
		(category-name-table (nth 9 grammar))
		(n (length words))
		(root-stateno (stateno-of '*D0* state-name-table))
		(item-set-array (make-array (+ 2 n) :initial-element nil))
		(word-cats (make-array (1+ n)))
		(word-categories (make-array (1+ n))))

	   (do ((i 0 (1+ i)))
	       ((= i n))
	     (setf (aref word-cats i)
		   (mapcar #'gcar (dictionary gd* (nth i words))))
	     (setf (aref word-categories i)
		   (mapcar #'(lambda (c) (categoryno-of c category-name-table))
			   (aref word-cats i))))

	   (setf (aref item-set-array 0) (list (list root-stateno 0)))

	   (do* ((i 0 (1+ i))
		 (new-items (aref item-set-array i) (aref item-set-array i))
		 (newer-items nil nil))
		((or (> i n) (null new-items))
		 (if print-states
		     (do ((i 0 (1+ i)))
			 ((> i n))
		       (print-item-set i (aref item-set-array i) state-name-array)))
		 (cond ((aref item-set-array n)
			(store-state-table (second (rule-set gram)) item-set-array n h
					   root-stateno words grammar word-categories
					   (second (third (rule-set gram))) gd*)
			t)
		       (t nil)))
      
	     ;; 2.2 closure operations
	     (do ()
		 ((null new-items))
	       (mapc #'(lambda (new-item)
			 (let ((q (first new-item)))

		 ;; 2.2a pushing down

			   (mapc #'(lambda (q-prime)
				     (let ((new-item (list q-prime i)))
				       (if (and (not (member new-item
							     (aref item-set-array i)
							     :test #'equal))

;; The following test allows the state to be pushed
;; if there is an intersection between the category of the next word
;; and the possible left terminal categories for the state being pushed.

						(or (not use-lookahead)
						    (= i n)
						    (let ((r (gethash (aref state-name-array
									    q-prime)
								      firsts)))
						      (or (member '*EMPTY* r)
							  (intersection (aref word-cats i)
									r)))))
					   (setf (aref item-set-array i)
						 (cons new-item
						       (aref item-set-array i))
						 newer-items (cons new-item newer-items)))))
				 (aref l* q))))
		     new-items)

	       (mapc #'(lambda (new-item)
			 (let ((q (first new-item))
			       (j (second new-item)))

		 ;; 2.2b popping up

			   (if (aref final? q)
			       (mapc #'(lambda (item)
					 (let ((q-prime (first item))
					       (j-prime (second item)))
					   (mapc #'(lambda (q-double-prime)
						     (let ((new-item (list q-double-prime
									   j-prime)))
						       (if (and (not (member new-item
									(aref item-set-array i)
									:test #'equal))
								(let ((r (gethash (cadr (fs (aref state-name-array q-double-prime))) firsts)))
								  (or (null r)
								      (not use-lookahead)
								      (member '*EMPTY* r)
								      (intersection
									(aref word-cats i)
									r))))

							   (setf (aref item-set-array i)
								 (cons
								  new-item            
								  (aref item-set-array i))
								 newer-items
								 (cons new-item newer-items)))))
						 (gethash (list q-prime (aref h q))
							  delta-push))))
				     (aref item-set-array j)))))
		     new-items)
	       (setq new-items newer-items)
	       (setq newer-items '()))

	     (if (< i n)
		 (let ((cs (aref word-categories i)))
		   ;; 2.1 transitions
		   (setf (aref item-set-array (1+ i))
			 (let ((collect nil))
			   (mapc #'(lambda (item)
				     (let ((q (first item))
					   (j (second item)))
				       (mapc #'(lambda (c)
						 (mapc #'(lambda (q-prime)
							   (push (list q-prime j)
								 collect))
						       (aref delta-category q c)))
					     cs)))
				 (aref item-set-array i))
			   collect)))))))

	(t (format t "~&Either ~S is not a CFG-GRAMMAR-TABLE or a GPSG-GRAMMAR-TABLE," gram)
	   (format t " or ~S is not a DICTIONARY." dict))))