;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;  SPS (simple production system) 
;;;  by Gerhard Strube and Lars Konieczny (1988, 2001)
;;;  Version 1.4.5 (7. 5. 2004)
;;;
;;;  Release notes
;;;  New in 1.4:
;;;  - added rule-names
;;;  - "assert-new" changed to "assert-in-wm"
;;;  - satisfied-p permits evaluation of LISP-predicate
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Some global parameters for printing

(defparameter *print-new-assertions* t)
(defparameter *print-goal-stack* t)
(defparameter *print-cycle* t)
(defparameter *print-rule-name* t)
(defparameter *print-rule-test* t)

(defun print-details (flag)
  (setf *print-new-assertions* flag)
  (setf *print-goal-stack* flag)
  (setf *print-cycle* flag)
  (setf *print-rule-name* flag)
  (setf *print-rule-test* flag)
  )

;;; SPS starting here 
; GOAL-STACK is a list

(defparameter goal-stack nil)

; WM (working memory)
; items are stored in an assoc-list ((feature . value) ...)

(defparameter wm nil)

(defun add-or-change-wme (feature value)
  (let ((property (assoc feature wm)))
    (cond ((null property)
           (setf wm (cons (cons feature value)
                          wm)))
          (t
           (setf (rest property) value)))))

(defun clear-wm ()
  (setf goal-stack nil)
  (setf wm nil))

(defun push-goal (goal)
  (push goal goal-stack)
  ;(setf goal-stack (cons goal goal-stack))
  (add-or-change-wme 'goal goal))

(defun pop-goal ()
  (pop goal-stack)
  ;(setf goal-stack (rest goal-stack))
  (add-or-change-wme 'goal (first goal-stack)))

(defun assert-in-wm (item &optional (value t))
  (format *print-new-assertions* "Item ~s set to ~s.~%" item value)
  (add-or-change-wme item value))

(defun recall (feature)
  (rest (assoc feature wm)))

; RULES (the list of rules)
; each rule is a list (name lhs rhs)
; the LHS (left-hand side, conditions)  is an association list, i.e., a list of (key value) sublists
; the RHS (right-hand side) is a list of actions, i.e. a list of function calls to be evaluated.

(defvar rules nil)


(defun clear-rules ()
  (setf rules nil))

(defun add-rule (lhs rhs &optional (name (gensym)))
  ;(push (cons lhs (list rhs)) rules))
  (push (list name lhs rhs) rules))

(defun rule-name (rule)
  (first rule))

(defun rule-conditions (rule)
  (second rule))

(defun rule-actions (rule)
  (third rule))

;;; auxiliary funtions for printing rules

(defun print-rule (rule)
  (format t "Rule ~s~%" (rule-name rule))
  (format t "  IF~%")
  (mapc #'(lambda (condition)
            (format t "    ~s ~s ~s.~%" 
              (first condition)
              (if (third condition)  ; for negation
                  'n=
                  '==)
              (second condition)))
    (rule-conditions rule))
  (format t "  THEN~%")
  (mapc #'(lambda (action)
            (format t "    ~s.~%" action))
    (rule-actions rule)))

(defun print-rules ()

  (let ((rule-count 0))
    (mapc #'(lambda (rule)
              (format t "~%Production-rule ~d:~%" (incf rule-count))
              (print-rule rule))
      rules))
  nil)

;;;
;;; the interpreter
;;;

(defun interpret (&optional (max 1000) (n 0))
  ; the interpretation loop. The heart of the PS.
  (format *print-cycle* "~%CYCLE ~d:~%" (1+ n)) 
  (format *print-goal-stack* "Goal stack: ~s~%" goal-stack)
  (format *print-goal-stack* "Current goal: ~s~%" (recall 'goal))
  ;(pprint wm)
  (cond ((and (> max 0)
              (enact (select-maximum (test-rules))))  ; the main part, perform actions of best rule      
         (interpret (1- max) (1+ n)))                 ; enter next cycle in loop
        (t (format t "Interpreter halted after ~s cycles.~%~%" n))))


(defun test-rules ()
  ; test-rule assigns a numeric "quality" value to each rule
  (mapcar #'(lambda (rule)
              (let ((result (test-proc (rule-conditions rule) 0)))
                (format *print-rule-test* 
                    "Testing rule ~s: ~s~%" (rule-name rule) result)
                (list result
                      (rule-name rule)
                      (rule-actions rule))))
    rules))

(defun test-proc (conditions ok)
  ; tests the lhs of a single rule. 
  ; If at least one condition fails to match the wm, 0 is returned.
  ; Otherwise, the value returned is the number of conditions matching.
  ; (The more specific, the better)
  (cond ((null conditions)
         ok)
        ((satisfied-p (first conditions))
         (test-proc (rest conditions) (1+ ok)))
        (t 0)))

(defun satisfied-p (condition)
  (cond ((eq '!eval! (first condition))
         (eval (second condition)))
        ((eq (recall (first condition))
             (second condition)))))

 ; select-maximum picks rules (i.e their actions) with highest rank;
 ; if there are several rules left, select-maximum picks one randomly.
 ; rules with rank 0 are ignored.

(defun select-maximum (v-list &optional (comp 0) result)
  (let* ((first-rule (first v-list))
         (rank (first first-rule)))
    (cond ((null v-list)
           (when result
             (nth (random (length result)) result)))
          ((or (= rank 0)
               (< rank comp))
           (select-maximum (rest v-list) comp result))
          ((= rank comp)
           (select-maximum (rest v-list) comp (cons first-rule result)))
          (t (select-maximum (rest v-list) rank (list first-rule))))))

(defun perform-actions (action-list)
  (mapc #'eval action-list))
      
(defun enact (v-actions)
  (cond ((null v-actions)
         (format t "No matching rule found.~%")
         nil)
        (t 
         (format *print-rule-name* "Rule ~s firing ...~%" (second v-actions))
         (perform-actions (third v-actions)))))