; 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


;;;; -*- Mode: Lisp; Syntax: Common-Lisp -*-
;;; Code from Paradigms of Artificial Intelligence Programming
;;; Copyright (c) 1991 Peter Norvig

;;; ==============================

(defun random-elt (choices)
  "Choose an element from a list at random."
  (elt choices (randi (length choices))))

(defun one-of (set)
  "Pick one element of set, and make a list of it."
  (list (random-elt set)))


(defun mappend (fn list)
  "Append the results of calling fn on each element of list.
  Like mapcon, but uses append instead of nconc."
  (apply #'append (mapcar fn list)))

(defun combine-all (xlist ylist)
  "Return a list of lists formed by appending a y to an x.
  E.g., (combine-all '((a) (b)) '((1) (2)))
  -> ((A 1) (B 1) (A 2) (B 2))."
  (mappend #'(lambda (y)
               (mapcar #'(lambda (x) (append x y)) xlist))
           ylist))

;;; ==============================

(defun rule-lhs (rule)
  "The left hand side of a rule."
  (first rule))

(defun rule-rhs (rule)
  "The right hand side of a rule."
  (rest (rest rule)))

(defun rewrites (category)
  "Return a list of the possible rewrites for this category."
  (rule-rhs (assoc category *grammar*)))

;;; ==============================

(defun generate (phrase)
  "Generate a random sentence or phrase"
  (cond ((listp phrase)
         (mappend #'generate phrase))
        ((rewrites phrase)
         (generate (random-elt (rewrites phrase))))
        (t (list phrase))))

;;; ==============================

(defun generate-tree (phrase)
  "Generate a random sentence or phrase,
  with a complete parse tree."
  (cond ((listp phrase)
         (mapcar #'generate-tree phrase))
        ((rewrites phrase)
         (cons phrase
               (generate-tree (random-elt (rewrites phrase)))))
        (t (list phrase))))

;;; ==============================

(defun generate-all (phrase)
  "Generate a list of all possible expansions of this phrase."
  (cond ((null phrase) (list nil))
        ((listp phrase)
         (combine-all (generate-all (first phrase))
                      (generate-all (rest phrase))))
        ((rewrites phrase)
         (mappend #'generate-all (rewrites phrase)))
        (t (list (list phrase)))))

(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)

(defun triggered (l facts)
  (or (atom l)
      (not (eql (first l) '$!))
      (and (? (first l) facts)
	   (triggered (rest l) facts))))

(defun any-triggereds (ors facts)
  (or (shuffle
       (select #'(lambda (one)
		   (triggered one facts))
	       ors))
      (throw :retry nil)))