#| 
 
2b, OO-based grammer
Tim Menzies
 
|#
 
(defparameter *phrase* (klass (*object*) register act head cache))
(defparameter *rule* (klass (*phrase*) body))
(defparameter *terminal* (klass (*phrase*)))
 
;;;; cache management facilities
(let (cache)
  ; globally, everyone can zap the cache
  (defun zap  () 
    (setf cache (make-hash-table)))
  ; inside each method, you can access the cache
  (defmeth cache *phrase* (self)
	   cache)
)
 
;;;; methods for runtime generation
 
; for "rules", call "act" recursively on
; one RHS item, selected at random
(defmeth act *rule* (self)
	 (labels ((recurse (one)
		    (act (gethash one (cache self)))))
	   (let ((one (random-elt (body self))))
	     (if (atom one)
		 (recurse one)
		 (mapcar #'recurse one)))))
 
; for "terminals" just return the head of your self
(defmeth act *terminal* (self)
	 (head self))
 
;;;; instance creation methods
;; 1) insert yourself into the cache at your head
;; 2) remember your head
;; 3) also, if you are a "rule", also remember your body
(defmeth register *terminal* (self lhs)
	 (setf (gethash lhs (cache self)) self ; #1
	       (head self) lhs)                ; #2
	 self)
 
(defmeth register *rule* (self lhs rhs)
	 (setf (gethash lhs (cache self)) self ; #1
	       (head self) lhs                 ; #2
	       (body self) rhs)                ; #3
	 self)
 
;;;; instance creation functions
(defun phrases->instances (phrases)
  (mapcar #'phrase->instance phrases))
 
(defun phrase->instance (phrase)
  (register (inst *rule*) (car phrase) (cddr phrase)))
 
;;;; add terminals
;; pass 1: find rhs symbols which are not heads
;; pass 2: create one "terminal" for everything found in pass 1
;; note: this was *fiendishy* complex till i remembered "visit-r"
(defun add-terminals (cache)
  (let (terminals)
    (labels ((worker (lhs rule)
	       (declare (ignore lhs))
	       (visit-r (body rule) #'collect))
	     (collect (one)
	       (unless (gethash one cache)
		 (push one terminals))))
      ; pass 1
      (maphash #'worker cache)
      ; pass 2
      (dolist (terminal (delete-duplicates terminals))
	(register (inst  *terminal*) terminal)))))
 
;;;;; utils
;; not you again!
(defun visit-r (thing fn)
  (if (atom thing)
      (funcall fn thing)
      (dolist (one thing)
	(visit-r one fn))))
 
(defun list! (x)
  (if (listp x)
      x
      (list x)))
 
(defun random-elt (choices)
  (elt choices (randi (length choices))))
 
(defmeth init *phrase* (self) self)
 
;;;; main
;; assume that the first lhs is the start of the grammar
(defun main (phrases)
  (zap)
  (let ((first (phrase->instance (car phrases))))
    (phrases->instances (cdr phrases))
    (add-terminals (cache first))
    (flatten (act first))
    ))
 
(deftest !main ()
  (reset-seed)
  (let ((g '((sentence -> (noun-phrase verb-phrase))
	     (noun-phrase -> (Article Noun))
	     (verb-phrase -> (Verb noun-phrase))
	     (Article -> the a)
	     (Noun -> man ball woman table)
	     (Verb -> hit took saw liked)
	     )))
    (dotimes (i 10)
      (print (main g)))))
#|
(THE WOMAN SAW A MAN) 
(THE WOMAN SAW A TABLE) 
(A BALL SAW A MAN) 
(A TABLE HIT A BALL) 
(A TABLE SAW A BALL) 
(THE BALL HIT THE BALL) 
(A TABLE SAW THE BALL) 
(A MAN HIT THE WOMAN) 
(A WOMAN SAW A MAN) 
(THE MAN HIT THE WOMAN)
|#