; -*- mode:     CL -*- ------------------------------------------------- ;
; File:         zebu-closure.lisp
; Description:  Conversion to CL of the original Scheme program by (W M Wells)
; Author:       Joachim H. Laubsch
; Created:      31-Oct-90
; Modified:     Tue Aug  2 16:11:09 1994 (Joachim H. Laubsch)
; Language:     CL
; Package:      ZEBU
; Status:       Experimental (Do Not Distribute) 
; RCS $Header: /logon/CVS/logon/uib/lisp/lib/zebu/zebu-closure.lisp,v 1.1 2005/06/08 08:40:00 paul Exp $
;
; (c) Copyright 1990, Hewlett-Packard Company
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Revisions:
; RCS $Log: zebu-closure.lisp,v $
; RCS Revision 1.1  2005/06/08 08:40:00  paul
; RCS Files necessary for cgp
; RCS
; RCS Revision 1.1.1.1  2001/05/09 14:46:36  paul
; RCS Zebu 3.3.5 with Rudi Schlatte's adaptation to mk-defsytem
; RCS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;             Copyright (C) 1989, by William M. Wells III
;;;                         All Rights Reserved
;;;     Permission is granted for unrestricted non-commercial use.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package "ZEBU")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;               Calculate the closure of an lr(0) set of items
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun closure (I)
  (declare (type oset I))
  (let ((eset 
	 (make-oset :order-fn #'item-order-function)
	  ))
    ;; I is an oset of items.
    ;; This is non-destructive.
    ;; See Fig. 4.33 of Dragon
    (labels ((closure-insert-item! (item)
	       ;; Add an item to an oset of items. Add his pals too if he wasn't
	       ;; there already.
	       (when (oset-insert! item eset)
		 (unless (dot-at-right-end? item)
		   (dolist (production 
			     (the list 
				  (g-symbol-own-productions
				   (symbol-after-dot item)))
			    nil)
		     (let ((new (new-item production)))
		       (closure-insert-item! new)))
		   ))))
      (dolist (x (oset-item-list I)) (closure-insert-item! x))
      eset)))

#||
(defun closure (I)
  (declare (type oset I))
  (let ((eset (make-oset :order-fn #'item-order-function)))
    ;; I is an oset of items.
    ;; This is non-destructive.
    ;; See Fig. 4.33 of Dragon
    (labels ((closure-insert-item! (item)
	       ;; Add an item to an oset of items. Add his pals too if he wasn't
	       ;; there already.
	       (when (oset-insert! item eset)
		 (unless (dot-at-right-end? item)
		   (dolist (production (g-symbol-own-productions
					(symbol-after-dot item)))
		     (closure-insert-item! 
		      (the item (new-item production))))))))
      (dolist (x (oset-item-list I)) (closure-insert-item! x))
      eset)))
||#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Calculate the lr(1) closure of a set of lr(1) items.
;;; Currently, find the closure of a set of one lr(1) item.
;;;
;;; An lr(1) item data structure with a set of lookaheads
;;; actually stands for a set of lr(1) items which are the
;;; same except for each having one lookahead from the set.

(defun single-item-closure-1 (lr0-item look-ahead)
  (let ((eset (make-oset :order-fn #'item-order-function)))
    (closure-1-insert-item! lr0-item look-ahead eset)
    eset))


;;; Destructively take the lr(1) closure of an item set
;;; (actually an oset of items... not an item-set structure).
;;; Empty out the set and re-insert the contents with closures.

(defun closure-1! (item-set)
  (let ((item-list (oset-item-list item-set)))
    (setf (oset-item-list item-set) nil)
    (dolist (item item-list)
      (let ((the-look-aheads (item-look-aheads item)))
	(setf (item-look-aheads item) 
	      (make-oset :order-fn #'g-symbol-order-function))
	(dolist (look-ahead (oset-item-list the-look-aheads))
	  (closure-1-insert-item! item look-ahead item-set))))))

;----------------------------------------------------------------------------;
; closure-1-insert-item!
;-----------------------
; See Dragon Fig. 4.38
; 

(defun closure-1-insert-item! (lr0-item look-ahead item-set)
  (declare (type item lr0-item))
  (labels ((closure-1-insert-item-aux (lr0-item look-ahead)
	     (multiple-value-bind (item-not-there-already the-item)
		 (oset-insert-2! lr0-item item-set)
	       (when (or (oset-insert! look-ahead (item-look-aheads the-item))
			 item-not-there-already)
		 ;; Item wasn't already there with that lookahead
		 ;; so insert his buddies too.
		 (unless (dot-at-right-end? lr0-item)
		   (let* ((prod (item-production lr0-item))
			  (rhs  (rhs prod))
			  (after-dot-rhs
			   (nthcdr (the fixnum (item-after-dot lr0-item))
				   (the cons rhs)))
			  (gs-list (oset-item-list
				    (first-seq-1
				      ;; This gets the list corresponding to the
				      ;; part of the item beyond the symbol after
				      ;; the dot.
				      (cdr (the cons after-dot-rhs))
				      look-ahead))))
		     (dolist (prod (g-symbol-own-productions
				    (car (the cons after-dot-rhs))))
		       (dolist (gs gs-list)
			 (let ((new (new-item prod)))
			   (closure-1-insert-item-aux new gs))))))))))
    (closure-1-insert-item-aux lr0-item look-ahead)))

#|
(defun closure-1-insert-item! (lr0-item look-ahead item-set)
  (declare (type item lr0-item))
  (labels ((closure-1-insert-item-aux (lr0-item look-ahead)
	     (multiple-value-bind (item-not-there-already the-item)
		 (oset-insert-2! lr0-item item-set)
	       (when (or (oset-insert! look-ahead (item-look-aheads the-item))
			 item-not-there-already)
		 ;; Item wasn't already there with that lookahead
		 ;; so insert his buddies too.
		 (unless (dot-at-right-end? lr0-item)
		   (let* ((prod (item-production lr0-item))
			  (rhs  (rhs prod))
			  (after-dot-rhs
			   (nthcdr (the fixnum (item-after-dot lr0-item))
				   (the cons rhs)))
			  (gs-list (oset-item-list
				    (first-seq-1
				      ;; This gets the list corresponding to the
				      ;; part of the item beyond the symbol after
				      ;; the dot.
				      (cdr (the cons after-dot-rhs))
				      look-ahead))))
		     (dolist (prod (g-symbol-own-productions
				    (car (the cons after-dot-rhs))))
		       (dolist (gs gs-list)
			 (closure-1-insert-item-aux
			  (new-item prod) gs)))))))))
    (closure-1-insert-item-aux lr0-item look-ahead)))
|#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; test:
#||
(set-working-directory *ZEBU-test-directory*)
(zb::load-grammar "ex1.zb")
(zb::compile-slr-grammar "ex1.zb")
(zebu-load-file "ex1.tab")
(calculate-empty-string-derivers)
(calculate-first-sets)
(setq f-item (new-item (car (reverse *productions*))))
(setq f-i-set (single-item-closure-1
	       f-item *the-end-g-symbol*))
(item-list-print (oset-item-list f-i-set))
||#

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                              End of closure1.l
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;