; from http://changingminds.org/disciplines/storytelling/plots/propp/propp.htm

; lint (used, set, loops)
; memoization
; compilation
; meta-interpreter for maths
; compile meta interpreter into lambda bodies

(defparameter *grammar1* 
'((story -->
	($and !(person you)
	  	initial introduction body donor theReturn))

(introduction  -->
	 absentation interdiction violation reconnaissance delivery trickery complicity)

(body  -->
	 villanyAndLack mediation counteraction departure)

(donor  -->
	 testing reaction acquitions guidance struggle branding victory resolution)

(theReturn --> return pursuit rescue arrival claim task solution 
              recognition exposure transfiguration punishment wedding )

;;;;;;;;;;;;;;

(initial --> ($or
				($and "Ice, ice, ice, covering the land."       ($! (temp cool)))
				($and "Global warning has flooded the islands." ($! (temp warm)))
				($and "It was harvest time in the valley."      ($! (temp mild)))))

;;;;;;;;;;;;;

(absentation  -->
	($or  departureElder
        	deathOfParent))

(departureElder -->
	($or "Grandma packed her bags and moved to Cleveland."
	     "Daddy done join the Navy."))

(deathOfParent -->
	($and "Grandaddy done got the black lung."))

(interdiction --> ($or warning invertedInterdiction))

(warning -->
	($or
	($and "You dare not look into this closet." 
	      ($! (bad (in you closest))) )
	($and "Take care of your little brother, do not venture from the courtyard." 
			($! (person littleBrother)) 
			($! (bad (not (in you courtyard))))))) ; note, it we needed from the courtyard, we'd need a "not"

(invertedInterdiction -->
	($or
		($and "Bring breakfast out into the field." (! (in you field)))
		($and "Take your brother with you to the woods." (! (in you field)) (! (in littleBrother field)))))

(defun badness (facts)
  (let* ((all  (mapcar #'cdr (select #'badp facts)))
	 (some (select #'(lambda (x) (member x all)) facts)))
    (if (and all some)
	(/ (length some) (length all)))))
	

(defun badp (x)
  (eql (car x) 'bad))

(defun notp (x)
  (eql (car x) 'not))

(defun select (selector-fn facts)
  (remove-if-not selector-fn facts))

(defun ? (what facts &optional negated)
  (if (notp what)
      (? (cdr what) facts (not negated))
      (if negated
	  (not (member what facts))
	  (member what facts))))
			
(defun ! (what facts)
  (unless 
      (member what facts)
    (push what facts))
  facts)