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

(defun get-gpsg (lst)
  (let ((rule-lst nil) (rule-table (make-hash-table :test #'equal)))
    (do ((r lst (cdr r)))
	((null r) (list rule-lst rule-table))
      (let ((rule (mapcar #'gcar (car r))))
	(setq rule-lst (adjoin rule rule-lst :test #'equal))
	(push (car r) (gethash rule rule-table))))))

(defun gpsg-template-parses (items Dp s-vector template trail already-done gpsg-table
			     print-states)
  (if (or (eq template '*) (eq template '**))
      (gpsg-all-parses items Dp s-vector trail already-done gpsg-table print-states)
      (apply #'append
	     (mapcar 
	       #'(lambda (item)
		   (cond ((not (integerp (car item)))
			  (if (eq template (car item))
			      (lexicalize-item item)
			      nil))
			 ((symbolp template)
			  (if (eq template (svref Dp (car item)))
			      (gpsg-all-parses (list item) Dp s-vector trail
					       already-done gpsg-table print-states)
			      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) '**))
						  (gpsg-handle parses gpsg-table print-states)
						  nil))
					   (let ((deep-parses
						   (gpsg-template-parses
						       (list (car exp-items)) Dp s-vector
						       (if (eq (car tmplt) '**)
							   '* (car tmplt))
						       (cons item trail)
						       already-done gpsg-table
						       print-states)))
					     (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 gpsg-all-parses (items Dp s-vector trail already-done gpsg-table print-states)
  (apply #'append
	 (mapcar #'(lambda (item)
	      (cond ((not (integerp (car item)))
		     (lexicalize-item item)) ;; At the lexical level
		    ((member item trail :test #'eq)
		     (list (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))
				(gpsg-handle parses gpsg-table print-states))
			     (let ((deep-parses (gpsg-all-parses (list (car exp-items)) Dp
								 s-vector
								 (cons item trail)
								 already-done
								 gpsg-table
								 print-states)))
			       (mapc #'(lambda (p)
					 (mapc #'(lambda (deep-parse)
						   (push (append p
								 (list deep-parse))
							 ps))
					       deep-parses))
				     parses))))
				   (production-lists item Dp))))))
		 items))) 

(defun lexicalize-item (item)
  ;; item = (cat word (defs))
  (mapcar #'(lambda (d) (list (glist d) (second item)))
	  (remove-if-not #'(lambda (a)
			      (cond ((symbolp a)
				     (eq a (car item)))
				    (t (eq (car a) (car item)))))
			 (third item))))

(defun lexicalize-item2 (item dict)
  ;; item = (cat word)
  (mapcar #'(lambda (d) (list (glist d) (second item)))
	  (remove-if-not #'(lambda (a)
			      (cond ((symbolp a)
				     (eq a (car item)))
				    (t (eq (car a) (car item)))))
			 (dictionary dict (second item)))))

(defun gpsg-handle (parses gpsg-table print-states)
  (do ((ps nil ps)
       (p parses (cdr p)))
      ((null p) (remove-duplicates
		  ps :test #'(lambda (a b) (equal (mapcar #'car a) (mapcar #'car b)))))
    (let* ((rule (cons (caar p) (cons '==> (mapcar #'caar (cdar p)))))
	   (rules (gethash rule gpsg-table)))
      (mapc #'(lambda (rule)
		(cond (print-states
		       (format t "~&~&Rule: ~S~&RHS: ~S" rule (mapcar #'car (cdr (car p))))))
		(let ((result (g-handle (car p) rule)))
		  (if print-states (if result (format t "~&LHS: ~S" (car result))
				     (format t "~&LHS: Failure.")))
		  (if result (push result ps))))
	    rules))))

(defun g-handle (p rule)
  (let ((unification (list '**Unify)))
    (do ((fail nil fail)
	 (q (cdr p) (cdr q))
	 (r (cddr rule) (cdr r)))
	((or fail (null q))
	 (if fail nil
	   (let ((val (g-expand (glist (car rule)) unification t)))
	     (if val (cons val (cdr p)) nil))))
      (setq fail (g-compare (caar q) (glist (car r)) unification)))))
      
(defun g-compare (to-test rule unify)
  (do ((r (cdr rule) (cddr r))
       (fail nil fail))
      ((or (null r) fail)
       (if (and (member '/ to-test) (not (member '/ rule)))
	   (if (assoc '/ (cdr unify))
	       (setq fail t)
	     (rplacd unify (cons (cons '/ (second (member '/ to-test))) (cdr unify)))))
       fail)
    (let ((val (cadr r)) (act-val (second (member (car r) (cdr to-test)))))
      (cond ((g-eq val act-val unify))
	    ((var-p val) ;; Variable
	     (if act-val
	       (let ((v (assoc val (cdr unify))))
		 (if v
		   (if (g-eq (cdr v) act-val unify) nil (setq fail t))
		   (rplacd unify (cons (cons val act-val) (cdr unify)))))
	       (if (eq (car r) '/)
		   (cond ((assoc val (cdr unify))
			  (if (eq (cdr (assoc val (cdr unify))) '++) nil
			      (setq fail t)))
			 (t (rplacd unify (cons (cons val '++) (cdr unify))))))))
	    ((null act-val) (if (eq (car r) '/) (setq fail t)))
	    (t (setq fail t))))))

(defun g-eq (a b unify) ;; Are these values equal
  (cond ((eq a b))
	((or (eq a '*) (eq b '*)))
	((and (symbolp a) (symbolp b)) nil)
	((and (symbolp a) (listp b)) (and (not (member '/ b)) (eq a (car b))))
	((and (symbolp b) (listp a)) (and (not (member '/ a)) (eq b (car a))))
	(t (not (g-compare b a unify)))))

(defun var-p (symbol)
  (and (symbolp symbol) (char= #\? (aref (string symbol) 0))))

(defun g-expand (cat unify &optional first)
  (do ((ps nil ps)
       (c (cdr cat) (cddr c)))
      ((null c)
       (let ((slash (assoc '/ (cdr unify)))
	     (sl (second (member '/ cat))))
	 (if (and first slash (not (eq (cdr slash) '++)))
	     (cond ((eq sl '*) (progn (push (cdr slash) ps)
				      (push '/ ps))
		    (cons (car cat) ps))
		   ((null sl) nil)
		   (t nil))
	   (cons (car cat) ps))))
    (if (var-p (second c))
	(cond ((eq (cdr (assoc (second c) (cdr unify))) '++))
	      ((cdr (assoc (second c) (cdr unify)))
	       (push (cdr (assoc (second c) (cdr unify))) ps)
	       (push (car c) ps)))
      (if (not (eq '* (second c)))
	  (progn (push (if (symbolp (second c))
			   (second c)
			 (g-expand (glist (second c)) unify))
		       ps)
		 (push (car c) ps))))))

(defun glist (s) (if (symbolp s) (list s) s))
(defun gcar (s) (if (symbolp s) s (car s)))

(defun gpsg-filt (items gpsg-table dict already-done print-states)
  (apply #'append
	 (mapcar #'(lambda (item)
	       (cond ((gethash item already-done))
		     ((and (= (length item) 2) (symbolp (second item))) ;; Lexical
		      (lexicalize-item2 item dict))
		     (t (setf (gethash item already-done)
			      (do ((parses (list (list (car item))) ps)
				   (ps nil nil)
				   (exp-items (cdr item) (cdr exp-items)))
				  ((or (null exp-items) (null parses))
				   (gpsg-handle parses gpsg-table print-states))
				(let ((deep-parses (gpsg-filt (list (car exp-items))
							      gpsg-table dict
							      already-done
							      print-states)))
				  (mapc #'(lambda (p)
					     (mapc #'(lambda (deep-parse)
							(push (append p (list deep-parse)) ps))
						   deep-parses))
					parses)))))))
	  items)))