;;; -*- Mode:Lisp; Package:DYPAR; Base:10; -*-

;;;		  LastEditDate =  14:53:14  Thu, 04-May-89  -- Mark Boggs

;;; ----------------------------------------------------------------
;;; 
;;; 		(c) Copyright, 1989,
;;; 			by Mark Boggs
;;; 			All rights reserved
;;; 
;;; ----------------------------------------------------------------

;;; OPTIMIZE.LSP

;;; HISTORY
; 04-May-89  Mark Boggs (boggs) at Rank Xerox, Spain
;	Created.
;
;;; Compiler declarations

(in-package "DYPAR" :use '("LISP" "USER"))

(eval-when (compile)
    (if (not (boundp '*macros-loaded*)) (load "macros"))
    (if (not (boundp '*struc-loaded*)) (load "struc")))


;;; This function will replace occurances of '?' with '&o' wherever
;;; possible. To do this we need to recursively walk the pattern tree
;;; looking for optional sub-patterns which do not intersect with the
;;; next sub-pattern (or sub-patterns when the next one is also optional).
(defun optimize-optionality (pat)
  (do ((pattern (cdr pat) (cdr pattern))
       (p (car pat) (car pattern)))
      ((null p))
    (cond
      ;; Are we looking at an operator?
      ((listp p)
       (case (car p)
	 (? (if (and pattern
		     (null (intersectp (local-terms p)
				       (find-firsts pattern))))
		;; With no intersection we can change the operator.
		(progn (format t "~S~&" p)
		       (rplaca p '&o))))
	 ;; We have another operator and need to recurse.
	 ((&u &ui &bu &o * &s &n + ~)
	  (optimize-optionality (cdr p)))
	 ((! !! &c) (mapc #'optimize-optionality (cdr p)))
	 ((:= &i ^)
	  (optimize-optionality (cddr p)))
	 ((&a = &m &sc))
	 (t nil)))
      ;; Are we looking at a nonterminal?
      ((nontermp p)
       (cond
	 ;; It isn't defined so we quit
	 ((null (get-rule-hash p)))
	 (t (optimize-optionality (get-pattern p)))))
      ;; Symbols cannot be optimized.
      (t nil))))

(defun find-firsts (pat)
  (do ((pattern (cdr pat) (cdr pattern))
       (p (car pat) (car pattern))
       (firsts) (fwild)
       (first-flag t))
      ((or (null p) (null first-flag)) 
       (values firsts fwild first-flag))
    (cond
      ((listp p)
       (multiple-value-bind (f fw ff)
	   (pattern-firsts p)
	 (if first-flag
	     (setq firsts (append f firsts)
		   fwild (or fw fwild))
	 (setq first-flag (and first-flag ff)))))
      ((nontermp p)
       (cond ((null (get-rule-hash p)))
	     ((get-first p)
	      (if first-flag
		  (setq firsts (append (get-first p) firsts)
			fwild (or (get-fwild p) fwild)
			first-flag (get-opt p))))))
      ((or (member p '($ $r $d $w))
	   (eql (get p :symbol) '$))
       (if first-flag
	   (setq firsts (cons '$ firsts)
		 fwild t
		 first-flag nil)))
      ((or (numberp p) (eql (get p :symbol) '$n))
       (if first-flag
	   (setq firsts (cons '$n firsts)
		 first-flag nil)))
      (t (if first-flag
	     (setq firsts (cons p firsts)
		   first-flag nil))))))

(defun pattern-firsts (pat)
  (case (car pat)
    ((&u &bu)
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cdr pat))
       (declare (ignore fwild optional-p))
       (setq firsts (cons '$ firsts))
       (values firsts t t)))
    (&ui     
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cdr pat))
       (declare (ignore fwild))
       (setq firsts (cons '$ firsts))
       (values firsts t optional-p)))
    (&n (values nil nil t))
    (&s (values nil nil t))
    (~ (values (list '$) t nil))
    (&m (values (cdr pat) nil nil))
    (&sc (values (list '$) t nil))
    ((? &o *)
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cdr pat))
       (declare (ignore optional-p))
       (values firsts fwild t)))
    (+ 
      (multiple-value-bind (firsts fwild optional-p)
	  (find-firsts (cdr pat))
	(values firsts fwild optional-p)))
    ((! !!)
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cadr pat))
       (dolist (p (cddr pat)
		  (values firsts fwild optional-p))
	 (multiple-value-bind (f fw op)
	     (find-firsts p)
	   (setq firsts (append f firsts)
		 fwild (or fw fwild)
		 optional-p (or optional-p op))))))
    (&c
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cadr pat))
       (setq optional-p t)		 ; for the first cycle
       (dolist (p (cddr pat)
		  (values firsts fwild optional-p))
	 (multiple-value-bind (f fw op)
	     (find-firsts p)
	   (setq firsts (append f firsts)
		 fwild (or fw fwild)
		 optional-p (and optional-p op))))))
    (= (values (list '$) t nil))
    (:=
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cddr pat))
       (values firsts fwild optional-p)))
    (&i
     (multiple-value-bind (firsts fwild optional-p)
	 (find-firsts (cddr pat))
       (if (null firsts)
	   (setq fwild t optional-p t))
       (values firsts fwild optional-p)))
    (^
      (multiple-value-bind (firsts fwild optional-p)
	  (find-firsts (cddr pat))
	(values firsts fwild optional-p)))
    (&a (values nil t t))
    (t (if pat
	   (if (member (car pat) !!non-pattern-operators)
	       (values (list (get (car pat) :symbol)) t nil)
	       (values nil nil nil))))))

(defun pattern-terminals (pat)
  (case (car pat)
    ((&u &bu &ui) (cons '$ (local-terms (cdr pat))))
    ((&n &s ~ &sc =) (list '$))
    (&m (cdr pat))
    ((? &o * +) (local-terms (cdr pat)))
    ((! !! &c) (mapcan #'local-terms (cdr pat)))
    ((:= &i ^) (local-terms (cddr pat)))
    (t (if pat
	   (if (member (car pat) !!non-pattern-operators)
	       (list '$))))))

(defun local-terms (pat)
  (do ((pattern (cdr pat) (cdr pattern))
       (p (car pat) (car pattern))
       (terms))
      ((null p) terms)
    (cond
      ((listp p)
       (setq terms (append (pattern-terminals p) terms)))
      ((nontermp p)
       (cond ((null (get-rule-hash p)))
	     (t (setq terms (append (get-terminals p) terms)))))
      ((or (member p '($ $r $d $w))
	   (eql (get p :symbol) '$))
       (setq terms (cons '$ terms)))
      ((or (numberp p) (eql (get p :symbol) '$n))
       (setq terms (cons '$n terms)))
      (t (setq terms (cons p terms))))))

(defvar *optimize-loaded* t)