;;; New production learning for ACT-R
;;; version 1.0b
;;; Niels Taatgen
;;; 7 mar 2000 

;;; Last additions: 

;;; version 1.0.1b
;;; Change to b parameter: the learned b parameter is now always equal to the b-parameter
;;;     of the first rule minus the penalty
;;; Fourth specialize option: specialize-only
;;; version 1.0b
;;; Added three options for *specialize*: restricted, first and all
;;; version 0.2a: 
;;; - Added decreading noise
;;; - fixed bug in using assoc 
;;; version 0.1.1a: added naming scheme function

(defvar *proc-odds* 100
  "Probability that proceduralization occurs, range 0-100")
(defvar *proc-threshold* -10.0
  "Minimum activation of the specialized chunk")
(defvar *initial-experience* 10
  "How many intial experiences does a new rule have")
(defvar *cost-penalty* 1.0
  "What is the initial extra cost of a rule")
(defvar *experience-threshold* 20
  "How many experiences should the parent rules have before proceduralizing")
(defvar **prev-inst**
  "Used to store the previous instantiation")
(defvar *production-name-scheme* nil
  "Function generates a name for the new rule given its parents and the instantiation")
(defvar *noise-factor* 1.0
  "Additional noise for new rules that gradually decays to egs-noise")
(defvar *initial-decay-noise* nil
  "Is noise decay also applied to the initial productions of the model?")
(defvar *specialize* 'restricted
  "Determines under what conditions a rule is learned:
    restricted:      new rules are always based on two parents, if the retrievals of these
                     parents can be merged this will be done
    first:           new rules are always based on two parents, except when the first rule
                     does any goalstack or i/o operations, in that case specialization 
                     occurs based on one rule. The first rule is always specialized
    all:             new rules can be learned based on a single parent in any condition
    specialize-only: new rules are learned based on specialization only, never by merging")

(setf **prev-inst** nil)

;;; run-fct now includes a call to store-instantiation

(defun run-fct (&optional (cycles -1))
  (let ((start-time *time*)
        (start-cycle *cycle*)
        (matching-latency 0.0)
        (failed-latencies 0.0))
    (cond ((integerp cycles) (incf cycles *cycle*))
          ((floatp cycles) (incf cycles *time*))
          (t (signal-warn "ARGUMENT TO RUN COMMAND MUST BE A NUMBER.")))
    (loop
      (cond (*stop*
             (signal-output *command-trace* "Stop requested.")
             (setf *stop* nil)
             (return))
            ((null *wmfocus*)
             (signal-output *command-trace* "Top goal popped.")
             (return))
            ((and (integerp cycles) (= *cycle* cycles))
             (signal-output *command-trace* "Stopped at cycle ~D" *cycle*)
             (return))
            ((and (floatp cycles) (>= *time* cycles))
             (signal-output *command-trace* "Stopped at time ~6,3F" *time*)
             (return))
            (t))
      (save-state-change :run *time* *cycle* *spread-stamp* (make-random-state))
      ; Match
      (generate-all-instantiations)
      (when *matches-trace*
        (pprint-instantiations *conflict-set* *matches-trace* *matches-trace*))
      (setf *instantiation* nil)
      (when *conflict-set-hook-fn*
        (multiple-value-bind (instantiations latency)
                             (funcall *conflict-set-hook-fn* *conflict-set*)
          (declare (ignore latency))
          (when instantiations ; if returns nil, then continue unchanged
            (cond ((listp instantiations) ; if returns a list, then interpret as new cset
                   (setf *conflict-set* instantiations))
                  (t ; otherwise, restrict the conflict set to selected instantiation
                   (setf *conflict-set* (list instantiations)))))))
      (unless *instantiation*        
        (multiple-value-setq (*instantiation* matching-latency failed-latencies)
          (choose-instantiation)))
      ;;; Right-hand side
      (cond (*instantiation*
             (let* ((production (instantiation-production *instantiation*))
                    (action-latency (production-action-cost production))
                    (success (< (random 1.0)
                                (production-action-probability production))))
               (when (and *abort-instantiation* *enable-rational-analysis*
                          (floatp cycles)
                          (> (+ *time* matching-latency)
                             cycles))
                 (signal-output *command-trace* "Instantiation aborted at time ~6,3F." *time*)
                 (return))
               (when (or *base-level-learning* *associative-learning*
                         *strength-learning*)
                 (learn-matching))
               (signal-output *cycle-trace* "Cycle ~D  Time ~6,3F: ~A"
                              *cycle* *time* production)
               (when *enable-rational-analysis*
                 (signal-output *latency-trace* "Matching latency: ~6,3F"
                                matching-latency)
                 (incf *time* matching-latency))
               (signal-output *latency-trace* "Action latency: ~6,3F" action-latency)
               (when (member (production-name production) *break-productions*
                             :test #'eq)
                 (pprint-instantiation)
                 (break "Production ~S is about to fire.~%" production))
               (cond (success
                      (when *enable-rational-analysis*
                        (setf *z-n-1* (- (* *g* (production-r production))
                                         (production-b production))))
                      (when *firing-hook-fn*
                        (funcall *firing-hook-fn* *instantiation*))
                      (dolist (rhs-call (production-rhs production))
                        (simulate-call rhs-call))
                      (when *enable-rational-analysis*
                        (update-activation-spread)))
                     (t
                      (signal-output *cycle-trace* "Instantiation fails.")))
               (incf *time* action-latency)
               (when *parameters-learning*
                 (learn-parameters success :latency (+ (- matching-latency failed-latencies)
                                                       action-latency)))))
            ((and *enable-rational-analysis* *pop-upon-failure*)
             (let ((popped-goal *wmfocus*))
               (signal-output *cycle-trace* "Cycle ~D  Time ~6,3F: No valid instantiation found: popping subgoal in failure."
                              *cycle* *time*)
               (when *enable-rational-analysis*
                 (signal-output *latency-trace* "Matching latency: ~6,3F"
                                matching-latency)
                 (incf *time* matching-latency))
               (signal-output *latency-trace* "Action latency: ~6,3F" *default-action-time*)
               (when *goal-stack*
                 (dolist (return (goal-frame-return-values (first *goal-stack*)))
                   (set-slot-value *wmfocus* (first return)
                                   (get-wme-or-constant 'failure))))
               (pop-fct "failure")
               (incf *time* *default-action-time*)
               (when *parameters-learning*
                 (learn-parameters t :popped-goal popped-goal))))
            (t
             (signal-output *command-trace* "No instantiation found.")
             (return)))
      (signal-output *command-trace* "")
      (incf *cycle* 1)
      (when *cycle-hook-fn* (funcall *cycle-hook-fn* *instantiation*))
      (store-instantiation *instantiation*)
      (when *web-hook-fn* (funcall *web-hook-fn* *instantiation*)))
    (when *end-run-hook-fn* (funcall *end-run-hook-fn* (- *time* start-time)))
    (signal-output *latency-trace* "Run latency: ~6,3F" (- *time* start-time))
    (values (* 0.001 (round (- *time* start-time) 0.001)) (- *cycle* start-cycle))))

; clear-all resets **prev-inst**

(defun clear-all-fct (&optional (save-model t))
  "Clears everything."
  (setf *compile-eval-calls* nil)
  (when *load-pathname*
    (setf *model* (when save-model (list *load-pathname*)))
    (when (eq save-model t)
      (load-model-list *load-pathname*)))
  (setf *time* 0.0)
  (setf *default-action-time* 0.05)
  (setf *latency* 0.0)
  (setf *cycle* 0)
  (setf *spread-stamp* 0)
  (setf *wme-number* 0.0)
  (setf *declarative-memory* nil)
  (init-types)
  (setf *hash-names* (make-hash-table :test #'eq :size 1000))
  (setf *procedural-memory* nil)
  (setf *goal-activation* 1.0)
  (setf *goal-sources* nil)
  (setf *wmfocus* nil)
  (setf **prev-inst** nil)
  (setf *wmfocus-list* nil)
  (setf *goal-stack* nil)
  (setf *goal-depth* 1)
  (setf *g* 20.0)
  (setf *z-n-1* 0.0)
  (setf *exp-gain-noise* nil)
  (setf *previous-instantiations* nil)
  (setf *instantiation* nil)
  (setf *extra-instantiation* nil)
  (setf *conflict-set* nil)
  (setf *latency-factor* 1.0)
  (setf *latency-exponent* 1.0)
  (setf *base-level-constant* 0.0)
  (setf *activation-sources* nil)
  (setf *activation-noise* nil)
  (setf *permanent-activation-noise* nil)
  (setf *mismatch-penalty* 1.5)
  (setf *retrieval-threshold* nil)
  (setf *partial-matching* nil)
  (setf *break-productions* nil)
  (setf *failed-productions* nil)
  (setf *reinforce-analogized-production* nil)
  (setf *production-compilation-parameters* nil)
  (setf *enable-rational-analysis* nil)
  (setf *enable-randomness* nil)
  (setf *utility-threshold* 0.0)
  (setf *optimized-learning* t)
  (setf *base-level-learning* nil)
  (setf *associative-learning* nil)
  (setf *strength-learning* nil)
  (setf *parameters-learning* nil)
  (setf *command-trace* t)
  (setf *output-trace* t)
  (setf *cycle-trace* t)
  (setf *latency-trace* t)
  (setf *partial-matching-trace* nil)
  (setf *production-compilation-trace* t)
  (setf *activation-trace* nil)
  (setf *conflict-resolution-trace* nil)
  (setf *conflict-set-trace* nil)
  (setf *goal-trace* nil)
  (setf *dm-trace* nil)
  (setf *production-trace* nil)
  (setf *matches-trace* nil)
  (setf *exact-matching-trace* nil)
  (setf *verbose* t)
  (setf *abort-instantiation* t)
  (setf *parameter-sets* nil)
  (setf *similarity-hook-fn* nil)
  (setf *conflict-set-hook-fn* nil)
  (setf *firing-hook-fn* nil)
  (setf *cycle-hook-fn* nil)
  (setf *web-hook-fn* nil)
  (setf *end-run-hook-fn* nil)
  (setf *step-fn* 'step-fct)
  (setf *stop* nil)
  (setf *save-state-changes* nil)
  (setf *pop-upon-failure* t)
  (when *init-hook-fn* (funcall *init-hook-fn*)))

(defun compile-or-select-production (name type lhs rhs success failure)
  "Either create a new production or select an existing identical one."
  (dolist (production (wme-type-productions (get-safe-type type name))
                      (let ((new-production (compile-production name type lhs rhs)))
                        (signal-output *production-compilation-trace* "Compiling Production ~A." new-production)
                        new-production))
    (when (identical-productions (cons lhs rhs) (production-text production))
      (signal-output *production-compilation-trace* "Recreating Production ~A." production)
      (return nil))))

;;;
;;; Change in noise-function: noise decreases with practice
;;;
;;; Noise decreases for new rules: starts out at *cost-penalty* times *noise-factor*
;;; decreases towards :egs parameter
;;; If *noise-factor* is set to 0, no reduction in noise will occur
;;; A *noise-factor* higher than 1 is not recommended
;;; Rules that are present initially in the system do not have their noise
;;; changed: it is set to :egs noise right away
;;;

(defun egs-noise (p)
  (noise
   (if
     (and *parameters-learning* 
          (or *initial-decay-noise*
              (> (production-creation-time p) 0.0))
        )
     (+ (* *noise-factor* (/ (* *initial-experience* *cost-penalty*) 
             (+  
                (car (production-successes p))
                (car (production-failures p))
                (if (and *initial-decay-noise* (< (production-creation-time p) 0.1))
                  *initial-experience* 0)) ; in the case of an initial rule, we add initial experience
             ))
        *exp-gain-noise*)
     *exp-gain-noise*)))

(defun match-lhs (production)
  "Matches the lhs of a production."
  (let ((gain 0.0))
    (when *enable-rational-analysis*
      (setf gain (get-pg-c production))
      (when *exp-gain-noise*
        (incf gain (egs-noise production))))
    (if (and *utility-threshold* (< gain *utility-threshold*))
      (signal-output (or *exact-matching-trace* *partial-matching-trace*)
                     "Production ~S PG-C ~6,3F is below threshold: rejected."
                     production (production-pg-c production))
      (let ((i (production-size production))
            (lhs (production-lhs production)))
        (signal-output (or *exact-matching-trace* *partial-matching-trace*)
                       "Matching production ~S." production)
        (setf *instantiation* (production-instantiation production))
        (loop (decf i 1) (when (= i 0) (return))
              (setf (instantiation-variable *instantiation* i) nil))
        (setf (instantiation-variable *instantiation* *instantiation-slots*)
              *wmfocus*)
        (setf *extra-instantiation* (production-extra-instantiation production))
        ; FIX: call just the car of lhs if :era is enabled.
        (when *enable-rational-analysis*
          (setf (instantiation-gain *instantiation*) gain)
          (setf lhs (car lhs)))
        (simulate-call lhs)))
    *conflict-set*))

(defun add-instantiation-to-conflict-set (arguments)
  "Adds *instantiation* to conflict set, sorted by value or PG-C.
   No need to compute latencies."
  (declare (ignore arguments))
  (unless *enable-rational-analysis*
    (setf (instantiation-gain *instantiation*)
          (get-functional-parameter
           (production-value (instantiation-production *instantiation*))))
    (when *exp-gain-noise*
      (incf (instantiation-gain *instantiation*) 
            (egs-noise (instantiation-production *instantiation*)))))
  (let ((rest-cset *conflict-set*)
        (item nil)
        (index 0)
        (equals 0))
    (loop
      (setf item (pop rest-cset))
      (when (or (null item)
                (> (instantiation-gain *instantiation*) (instantiation-gain item)))
        (return))
      (if (= (instantiation-gain *instantiation*) (instantiation-gain item))
        (incf equals 1)
        (incf index 1)))
    (when (> equals 0)
      (incf index (if *enable-randomness* (random (+ equals 1)) equals)))
    (if (= index 0)
      (push *instantiation* *conflict-set*)
      (let ((previous (nthcdr (- index 1) *conflict-set*)))
        (push *instantiation* (cdr previous))))))


;;; ************** Proceduralization section ************************

(defstruct prule name goal-match retrieval misc-lhs new-goal goal-mod
  stack-action misc-action goal-inst retrieval-inst (legal t))

(defun parse-prule (inst rule)
  (let
    ((result (make-prule))
     (condition (first rule))
     (action (rest rule)))
    (setf (prule-name result) (first inst))
    (setf (prule-goal-match result) (first condition))
    (setf (prule-goal-inst result) (first (first (third inst))))
    (dolist 
      (x (rest condition))
      (if (headderp (first x))
        (if (null (prule-retrieval result))
          (setf (prule-retrieval result) x)
          (setf (prule-legal result) nil)) ; rule has more than one retrieval
        (setf (prule-misc-lhs result) (append (prule-misc-lhs result) (list x)))))
    (dolist
      (x (rest (third inst)))
      (when (headderp (first x))
        (setf (prule-retrieval-inst result) x)))
    (dolist
      (x action)
      (if (headderp (first x))
        (if (eq (first x)(first (prule-goal-match result)))
          (if (null (prule-goal-mod result))
            (setf (prule-goal-mod result) x)
            (setf (prule-legal result) nil))
          (if (null (prule-new-goal result))
            (setf (prule-new-goal result) x)
            (setf (prule-legal result) nil)))
        (if (member (first x) '(!pop! !focus-on! !push!))
          (if (null (prule-stack-action result))
            (setf (prule-stack-action result) x)
            (setf (prule-legal result) nil))   ; more than one !push! !pop! or !focus-on!
          (when (not (and (eq (first x) '!eval!) (eq (first (second x)) 'inc-strat)))
            ; this when clause is special for the Fincham-task !
            (setf (prule-misc-action result) (append (prule-misc-action result) (list x))))))
      )
    (when (and (prule-new-goal result) 
               (not (eq (headdere (first (prule-new-goal result))) 
                        (second (prule-stack-action result)))))
      (setf (prule-legal result) nil))  ; chunk in push or focus does not match newgoal on rhs
    result))
     
(defun replace-values (rule mapping)
  (setf (prule-goal-match rule) (substitute-vars (prule-goal-match rule) mapping)
        (prule-retrieval rule) (substitute-vars (prule-retrieval rule) mapping)
        (prule-misc-lhs rule) (substitute-vars (prule-misc-lhs rule) mapping)
        (prule-goal-mod rule) (substitute-vars (prule-goal-mod rule) mapping)
        (prule-new-goal rule) (substitute-vars (prule-new-goal rule) mapping)
        (prule-stack-action rule) (substitute-vars (prule-stack-action rule) mapping)
        (prule-misc-action rule) (substitute-vars (prule-misc-action rule) mapping))
)


(defun identical-productions (new old &optional (vars nil))
  "Checks whether the production bodies old and new are identical."
  (do ((rest-new new (rest rest-new))
       (rest-old old (rest rest-old)))
      ((or (null rest-new) (null rest-old))
       (when (and (null rest-new) (null rest-old)) vars))
    (let ((first-new (first rest-new))
          (first-old (first rest-old)))
      ;; Fix: make sure that it both ends with > AND starts with =
      (when (and (retrievalp first-new) (variablep first-new))
        (setf first-new (var>var first-new)))
      (when (and (retrievalp first-old) (variablep first-old))
        (setf first-old (var>var first-old)))
      (cond ((and (variablep first-new) (variablep first-old))
             (let ((first-new-assoc (cdr (assoc first-new vars :test #'eq)))
                   (first-old-assoc (car (rassoc first-old vars :test #'eq))))
               (if (or first-new-assoc first-old-assoc)
                 (unless (and (eq first-old first-new-assoc)
                              (eq first-new first-old-assoc))
                   (return nil))
                 (push (cons first-new first-old) vars))))
            ((and (listp first-new) (listp first-old))
             (unless (setf vars (identical-productions first-new first-old
                                                       vars))
               (return nil)))
            ((equal first-new first-old))
            (t (return nil))))))



(defun get-instantiation (&optional (instantiation *instantiation*)
                                       (trace *command-trace*)
                                       (format *production-trace*))
  "Pretty-prints an instantiation."
  (let ((production (instantiation-production instantiation)))
    (when (eq trace 'short) (setf trace t))
    (if (eq format 'short)
      (dolist (binding (production-bindings production))
        (signal-output trace "   ~A: ~A" (variable-name binding)
                       (if (integerp (variable-index binding))
                         (or (instantiation-variable instantiation (variable-index binding))
                             "VARIABLE STILL UNBOUND")
                         "RETURN VARIABLE STILL UNDETERMINED")))
      (let ((bindings nil)
            (text nil))
        (dolist (binding (production-bindings production))
          (when (integerp (variable-index binding))
            (let ((value (instantiation-variable instantiation (variable-index binding))))
              (when value
                (push (cons (variable-name binding) value) bindings)
                (push (cons (var-var> (variable-name binding))
                            (var-var> value))
                  bindings)))))
        (setf text (sublis bindings (production-text production)))
        text))))

;This is what evokes the proceduralization code:
(defun store-instantiation (*instantiation*) 
  (let (hold)
       (cond (*instantiation*
              (setf hold  (get-set *instantiation*))
              (when 
                     (< (random 100) *proc-odds*)
                     )
                (proceduralize-production hold **prev-inst**)
              (setf **prev-inst** hold)
             ))))

(defun get-set (ins) 
  (cond (ins
  (let ((list (get-instantiation ins)))
    (list (aref ins 0) (second (second (caar list)))
          (first list) (cdr list) nil)))
        (t nil)))

(defun proceduralize-one (p1 rule1)
  (let
    ((original-retrieval (first (prule-retrieval-inst rule1))))
    (when (and original-retrieval ; there must be something to specialize
      (let
        ((pl (first (no-output (sgp :pl)))))  ; check whether the rule has enough experience
        (cond 
         ((null pl) t) ; parameters learning is off
         (t    ; parameters learning is on
          (no-output
           (let
             ((suc1 (caaar (eval `(spp ,(prule-name rule1) :eventual-successes))))
              (fail1 (caaar (eval `(spp ,(prule-name rule1) :eventual-failures)))))
              (> (+ suc1 fail1) *experience-threshold*)))))))
      (when (Specialize rule1)
                    (let* ((condition
                  (remove-nil (Append (list (prule-goal-match rule1)
                                            (prule-retrieval rule1))
                                      (prule-misc-lhs rule1))
                                    ))
                 (action
                  (remove-nil (append (prule-misc-action rule1)
                                      (list 
                                       (prule-new-goal rule1)
                                       (prule-goal-mod rule1)
                                       (prule-stack-action rule1))
                                      )))
                 (production (compile-or-select-production
                              (gentemp (if *production-name-scheme* 
                                         (funcall *production-name-scheme* 
                                                  (production-name (prule-name rule1))
                                                  nil
                                                  (if (headderp original-retrieval)
                                                    (headdere original-retrieval)
                                                    original-retrieval))
                                           "PRODUCTION"))
                              (second (second (first condition)))
                              condition action nil nil)))
            (when production (finish-up-one production (car p1))))
        ))))

(defun proceduralize-production (p2 p1)
  (let* ((rule1-text (when p1 (production-text (get-safe-production (first p1)))))
         (rule2-tmp (production-text (get-safe-production (first p2))))
         (rule2-text (substitute-vars rule2-tmp (rename-variables rule2-tmp)))
         (rule1 (when p1 (parse-prule p1 rule1-text)))
         (rule2 (parse-prule p2 rule2-text))
         (original-retrieval (when p1 (first (prule-retrieval-inst rule1)))))
    (when (or
           (member *specialize* '(all specialize-only))
           (and (eq *specialize* 'first)
                (prule-legal rule2)
                (or (prule-stack-action rule2)
                    (prule-misc-action rule2)
                    (prule-misc-lhs rule2))))
      (proceduralize-one p2 rule2))
    (when
      (and (not (eq *specialize* 'specialize-only)) p1 (prule-legal rule1)(prule-legal rule2)  ; both rules are legal
           (let
             ((pl (first (no-output (sgp :pl)))))  ; check whether both rules have enough experience
             (cond 
              ((null pl) t) ; parameters learning is off
              (t    ; parameters learning is on
               (no-output
                (let
                  ((suc1 (caaar (eval `(spp ,(prule-name rule1) :eventual-successes))))
                   (fail1 (caaar (eval `(spp ,(prule-name rule1) :eventual-failures))))
                   (suc2 (caaar (eval `(spp ,(prule-name rule2) :eventual-successes))))
                   (fail2 (caaar (eval `(spp ,(prule-name rule2) :eventual-failures)))))
                  (and
                   (> (+ suc1 fail1) *experience-threshold*)
                   (> (+ suc2 fail2) *experience-threshold*)))))))
           (eq (first (first (third p1)))
             (first (first (third p2)))) ; they apply to the same goal
           (null (prule-stack-action rule1))   ; first rule does no stack actions
           (null (prule-misc-action rule1))   ; no misc actions in first rule
           (null (prule-misc-lhs rule1)) ; no misc conditions in first rule  
           )
      (let ((ok t)
            (specialize nil))
        (unify-variables 'goal rule1 rule2) ; rename variables in rule2 to match those in rule1
        (setf specialize ; check for special case when both retrievals are equal --> no specialization
              (not (and (eq (first (prule-retrieval-inst rule1)) (first (prule-retrieval-inst rule2))) 
                        (let* ((retrieve-var (headdere (first (prule-retrieval rule2))))
                               (retrieve-in-goal (assoc-second retrieve-var (rest (prule-goal-match rule2))))
                               (change-in-action (assoc-first (first retrieve-in-goal) (rest (prule-goal-mod rule1)))))
                          (eq (headdere (first (prule-retrieval rule1))) (slotcontent change-in-action))))))
        (dolist 
          (a (rest (prule-goal-mod rule1)) ok)
          (dolist 
            (c (rest (prule-goal-match rule2)))
            (when (eq (slotname c) (slotname a))
              (setf (prule-goal-match rule2)(remove c (prule-goal-match rule2) :test #'equal))
              (cond
               ((and (not (variable-check a)) (not (variable-check c))))
               ((negation-check c) (setf ok nil))
               ((not (variable-check c)) (replace-values rule1 (list (list (second a)(second c)))))
               (t (replace-values rule2 (list (list (second c)(second a)))))))))
        (when ok
          (when 
            (or
             (and (prule-retrieval rule1) (eq *specialize* 'first)) ; we always specialize the first condition if *specialize* is first
             (and (prule-retrieval rule1) (prule-retrieval rule2) specialize)   
             ; we specialize if both rules have a retrieval and there is no special case
             (and (prule-retrieval rule1) ; we also specialize if there is a collision between the conditions of the two rules
                  (let ((result nil))
                    (dolist 
                      (c2 (rest (rest (prule-goal-match rule2))) result)
                      (let ((c1 (assoc (first c2) (rest (prule-goal-match rule1)))))
                        (when (and c1 (variable-check c2)(variable-check c1)(not (equal c1 c2)))(setf result t)))))))
            (setf ok (specialize rule1 rule2)))
          (unify-variables 'retrieval rule1 rule2) ; rename variables in retrieval of rule2 to match those in rule1
          (when (and (prule-retrieval rule1) (not (variablep (first (prule-retrieval rule1)))))
            (setf ok (and ok (specialize rule1 rule2))))
          (when (and (prule-retrieval rule2) (not (variablep (first (prule-retrieval rule2)))))
            (setf ok (and ok (specialize rule2 rule1))))
          (when ok
            (let* ((condition
                  (remove-nil (Append (list (join-conditions rule1 rule2)
                                            (join-retrievals rule1 rule2))
                                      (prule-misc-lhs rule2))
                                    ))
                 (action
                  (remove-nil (append (prule-misc-action rule2)
                                      (list 
                                       (prule-new-goal rule2)
                                       (join-actions (prule-goal-mod rule2)(prule-goal-mod rule1))
                                       (prule-stack-action rule2))
                                      )))
                 (production (compile-or-select-production
                              (gentemp (if *production-name-scheme* 
                                         (funcall *production-name-scheme* 
                                                  (production-name (prule-name rule1))
                                                  (production-name (prule-name rule2))
                                                  (if (headderp original-retrieval)
                                                    (headdere original-retrieval)
                                                    original-retrieval))
                                           "PRODUCTION"))
                              (second (second (first condition)))
                              condition action nil nil)))
            (when production (finish-up production (car p1)(car p2))))
        ))))))
           
(defun remove-nil (l)
  (let ((l1 nil))
    (dolist (x l l1)
      (when x
        (setf l1 (append l1 (list x)))))))
    
(defun unify-variables (part r1 r2)
  (if (eq part 'goal) 
    (let ((mapping (get-unify-mapping (prule-goal-match r1) (prule-goal-match r2))))
      (replace-values r2 mapping))
    (when (and (prule-retrieval r1) (prule-retrieval r2))
      (let ((mapping (get-unify-mapping (prule-retrieval r1) (prule-retrieval r2))))
        (replace-values r2 mapping)))))

(defun get-unify-mapping (c1 c2)
  (let ((result (when 
                  (not (eq (first c1) (first c2))) 
                  (list (list (headdere (first c2))(headdere (first c1)))))))
    (dolist (x (rest c2) result)
      (let ((fil1 (slotcontent x))
            (fil2 (slotcontent (assoc (first x) (rest c1)))))   ; no assoc-first since we don't want to find negations
        (when (and fil2 (variablep fil1) (variablep fil2) (not (eq fil1 fil2)))
          (setf result (cons (list fil1 fil2) result)))))))

(defun specialize (r &optional r2) 
  (let ((mapping
         (when (variablep (first (prule-retrieval r)))
           (list (list (headdere (first (prule-retrieval r)))
                       (headdere (first (prule-retrieval-inst r))))))))
    (setf mapping
                    (do ((rulepart (rest (prule-retrieval r)) (rest rulepart))
                         (instpart (rest (prule-retrieval-inst r)) (Rest instpart)))
                        ((null rulepart) mapping)
                      (when (and (variable-check (first rulepart))
                                 (not (eq (first rulepart) (headdere (first (prule-goal-match r))))))
                        (setf mapping (cons (list (slotcontent (first rulepart))
                                                  (slotcontent (first instpart)))
                                            mapping)))))
    (replace-values r mapping)
    (when r2 (replace-values r2 mapping)))
  (when (> (no-output (caar (eval `(sdp ,(headdere (first (prule-retrieval-inst r))) :base-level)))) *proc-threshold*)
    (setf (prule-retrieval r) nil
          (prule-retrieval-inst r) nil)
    t)
  )
           
(defun slotname (pair)
  (if (= (length pair) 3) (second pair)
      (first pair)))

(defun slotcontent (pair)
    (if (= (length pair) 3) (third pair)
        (second pair)))

(defun setslotcontent (pair value)
  (if (= (length pair) 3) (list '- (second pair) value)
      (list (first pair) value)))

(defun rename-variables (rule &optional subslist)
  (cond ((null rule) subslist)
        ((and (variablep rule) (null (assoc (if (headderp rule) (headdere rule) rule) subslist)))
         (cons (list (if (headderp rule) (headdere rule) rule) (gentemp "=VAR")) subslist))
        ((listp rule)
         (dolist (x rule subslist)
           (setf subslist (rename-variables x subslist))))
        (t subslist)))

(defun assoc-first (key alist)
  "Searches for a slot name, and allows for negations"
  (cond ((null alist) nil)
        ((and (= (length (first alist)) 2) (eq key (first (first alist)))) (first alist))
        ((and (= (length (first alist)) 3) (eq key (second (first alist)))) (first alist))
        (t (assoc-first key (rest alist)))))

(defun assoc-second (key alist)
  "Searches for a slot filler, and allows for negations"
  (cond ((null alist) nil)
        ((and (= (length (first alist)) 2) (eq key (second (first alist)))) (first alist))
        ((and (= (length (first alist)) 3) (eq key (third (first alist)))) (first alist))
        (t (assoc-second key (rest alist)))))

(defun join-conditions (r1 r2)
  (let
    ((c1 (prule-goal-match r1))
     (c2 (prule-goal-match r2)))
    (cond 
     ((null c1) c2)
     ((null c2) c1)
     (t
      (let ((result c1)
            (y nil))      
        (dolist (x c2 result)
          (setf y (when (listp x) (assoc (slotname x) (rest c1))))   ; this leaves in all negations
          (cond ((and (listp x) (null y)) (setf result (append result (list x))))
                ((and (listp x) (not (variable-check x)) (variable-check y))
                 (setf result (append (remove y result :test #'equal) (list x))))
                ((and (listp x) (variable-check x)(not (variable-check y)))
                 (replace-values r2 (list (list (slotcontent x)(slotcontent y))))))))))))
    
(defun join-retrievals (r1 r2)
  (let
    ((c1 (prule-retrieval r1))
     (c2 (prule-retrieval r2)))
    (cond 
     ((null c1) c2)
     ((null c2) c1)
     (t
      (let ((result c1)
            (y nil))      
        (dolist (x c2 result)
          (setf y (when (listp x) (assoc (slotname x) (rest c1))))   ; this leaves in all negations
          (cond ((and (listp x) (null y)) (setf result (append result (list x))))
                ((and (listp x) (not (variable-check x)) (variable-check y))
                 (setf result (append (remove y result :test #'equal) (list x))))
                ((and (listp x) (variable-check x)(not (variable-check y)))
                 (replace-values r2 (list (list (slotcontent y)(slotcontent x))))))))))))

(defun join-actions (c1 c2)
  (cond 
   ((null c1) c2)
   ((null c2) c1)
   (t
    (let ((result c1))
      (dolist (x c2 result)
        (when (and (listp x)
                   (null (assoc (first x) (rest c1))))   ; this leaves in all negations
          (setf result (append result (list x)))))))))
  

;This finds the any chunks in the condition which are mentioned in the action and so are not candidates
;to proceduralize away

(defun named (chunk act)
  (do ((temp act (cdr temp)))
      ((null temp) nil)
    (cond ((and (member (caar temp) '(!push! !focus-on!))
                (equal (second (car temp)) chunk)) (return t)))))


(defun cons-check (a b)
  (cond ((assoc (car a) b) b)
        (t (cons a b))))

(defun variable-check (item)
  (and (listp item) (or (and (= (length item) 2) (variablep (second item)))
                        (and (= (length item) 3) (variablep (third item))))))

(defun negation-check (item)
  (eq (first item) '-))

;this does the mapping
(defun substitute-vars (sexp mapping)
  (cond ((null sexp) nil)
        ((atom sexp)
         (cond ((variable-map sexp mapping))
               (t sexp)))
        (t (cons (substitute-vars (car sexp) mapping)
                 (substitute-vars (cdr sexp) mapping)))))

(defun variable-map (term mapping)
  (cond ((variablep term)
         (cond ((headderp term) (setf term (headdere term))
                (cond ((assoc term mapping) (headder (cadr (assoc term mapping))))))
               ((assoc term mapping) (cadr (assoc term mapping)))))))

;this does final book-keeping
(defun finish-up (production old1 old2)
  (cond ((and *production-compilation-trace* *verbose*) (eval `(pp ,production))))
  (no-output
  (let*
    ((effort1 (caar (eval `(spp ,old1 :effort))))
     (effort2 (caar (eval `(spp ,old2 :effort))))
     (effort (+ effort1 effort2 (- *default-action-time*)))
     (a2 (caar (eval `(spp ,old2 :a))))
     (b2 (caar (eval `(spp ,old2 :b))))
     (q2 (caar (eval `(spp ,old2 :q))))
     (r2 (caar (eval `(spp ,old2 :r))))
     (b1 (caar (eval `(spp ,old1 :b))))
     (q1 (caar (eval `(spp ,old1 :q))))
     (r1 (caar (eval `(spp ,old1 :r))))
     (a  (+ a2 (- effort1 *default-action-time*)))
     (b (+ b2 *cost-penalty*))
;     (b (+ (max b1 b2) *cost-penalty*))   ;;; or just b2 ?
     (q (* q1 q2))
     (r (min r1 r2))
     (successes (* q *initial-experience*))
     (failures (- *initial-experience* successes))
     (eventual-successes (* r *initial-experience*))
     (eventual-failures (- *initial-experience* eventual-successes))
     (efforts a)
     (eventual-efforts b)
     (pl (first (no-output (sgp :pl)))))
    (cond ((eq pl t)
           (no-output
            (eval `(spp ,production
                        :effort ,effort
                        :efforts ,(* efforts *initial-experience*)
                        :eventual-efforts ,(* eventual-efforts *initial-experience*)
                        :successes ,successes
                        :failures ,failures	
                        :eventual-successes ,eventual-successes
                        :eventual-failures ,eventual-failures))))
          ((null pl)
           (no-output
            (eval `(spp ,production
                        :effort ,effort
                        :a ,a
                        :b ,b
                        :q ,q
                        :r ,r))))
          (t
           (no-output
            (eval `(spp ,production
                        :effort ,effort
                        :efforts ,efforts
                        :eventual-efforts ,eventual-efforts
                        :successes ,successes
                        :failures ,failures	
                        :eventual-successes ,eventual-successes
                        :eventual-failures ,eventual-failures)))))))
           
    (when (and *production-compilation-trace* *verbose*) (eval `(spp ,production)))
)

(defun finish-up-one (production old1)
  (cond ((and *production-compilation-trace* *verbose*) (eval `(pp ,production))))
  (no-output
  (let*
    ((effort (caar (eval `(spp ,old1 :effort))))
     (a (caar (eval `(spp ,old1 :a))))
     (b1 (caar (eval `(spp ,old1 :b))))
     (q (caar (eval `(spp ,old1 :q))))
     (r (caar (eval `(spp ,old1 :r))))
     (b (+ b1 *cost-penalty*))
     (successes (* q *initial-experience*))
     (failures (- *initial-experience* successes))
     (eventual-successes (* r *initial-experience*))
     (eventual-failures (- *initial-experience* eventual-successes))
     (efforts a)
     (eventual-efforts b)
     (pl (first (no-output (sgp :pl)))))
    (cond ((eq pl t)
           (no-output
            (eval `(spp ,production
                        :effort ,effort
                        :efforts ,(* efforts *initial-experience*)
                        :eventual-efforts ,(* eventual-efforts *initial-experience*)
                        :successes ,successes
                        :failures ,failures	
                        :eventual-successes ,eventual-successes
                        :eventual-failures ,eventual-failures))))
          ((null pl)
           (no-output
            (eval `(spp ,production
                        :effort ,effort
                        :a ,a
                        :b ,b
                        :q ,q
                        :r ,r))))
          (t
           (no-output
            (eval `(spp ,production
                        :effort ,effort
                        :efforts ,efforts
                        :eventual-efforts ,eventual-efforts
                        :successes ,successes
                        :failures ,failures	
                        :eventual-successes ,eventual-successes
                        :eventual-failures ,eventual-failures)))))))
           
    (when (and *production-compilation-trace* *verbose*) (eval `(spp ,production)))
)

;Utilities:
(defun get-condition (a)
  (first (production-text (get-safe-production (car a)))))


(defun get-action (a)
  (cdr (production-text (get-safe-production (car a)))))


(defun headderp (term) 
  (let ((string (string-sym term)))
    (equal (aref string (1- (length string))) #\>)))

(defun headdere (term)
  (let* ((string  (string-sym term))
         (bound (1- (length string)))
         (ans (make-string bound)))
    (do ((count 0 (1+ count)))
        ((equal count bound) (intern ans))
      (setf (aref ans count) (aref string count)))))

(defun string-sym (item)
  (cond ((symbolp item) (string item))
        (t (string (car (no-output (eval `(wm ,item))))))))

(defun headder (x) (intern (merge 'string (cond ((numberp x) (format nil "~d" x)) ((symbolp x) (string x))
                                              (t (string (car (no-output (eval `(wm ,x)))))) ) ">" 'eq)))


;;; Changes is learn-parameters:
;;; - learning of q is disabled (always success)
;;; - productions that fail still get their r's and b's updated

(defun learn-parameters (success &key (latency 0.0) (instantiation *instantiation*)
                                 (popped-goal nil))
  "Applies the parameters learning equations to instantiation.  The success of
   instantiation has already been evaluated and passed with the starting time."
  (let* ((production (when instantiation (instantiation-production instantiation)))
         (goal (if instantiation (instantiation-variable instantiation *instantiation-slots*) popped-goal))
         (no-change (and production (eq *wmfocus* goal)))
         (pop (and (not no-change) (not (member goal *goal-stack* :test #'eq :key #'goal-frame-focus)))))
    (cond ((or (null success) no-change pop)
           (when production
;             (when success (push (list goal production *time*) *previous-instantiations*))
             (push (list goal production *time*) *previous-instantiations*) ; always learn b and r parameters
             (add-reference (production-successes production) 
                            (not (numberp *parameters-learning*)))
;             (add-reference (if success (production-successes production) (production-failures production))
;                            (not (numberp *parameters-learning*)))
             (compute-q production)
             (add-reference (production-efforts production)
                            (not (numberp *parameters-learning*))
                            latency latency)
             (compute-a production)
             (pg-c production))
           (when pop
             (let ((eventual-success (and production (get-functional-parameter (production-success production))))
                   (eventual-failure (or (null production) (get-functional-parameter (production-failure production))))
                   (current-goal goal))
               (loop
                 (when (null *previous-instantiations*) (return))
                 (let* ((previous-firing (pop *previous-instantiations*))
                        (previous-production (second previous-firing)))
                   (cond ((not (eq current-goal (first previous-firing))) 
                          ;; pushing production
                          (setf current-goal (first previous-firing))
                          (cond ((eq current-goal *wmfocus*)
                                 (unless (and eventual-success eventual-failure)
                                   (add-reference (if eventual-failure (production-failures previous-production)
                                                      (production-successes previous-production))
                                                  (not (numberp *parameters-learning*)))
                                   (compute-q previous-production)
                                   (add-reference (production-efforts previous-production)
                                                  (not (numberp *parameters-learning*))
                                                  (- *time* (third previous-firing))
                                                  (- *time* (third previous-firing)))
                                   (compute-a previous-production)
                                   (pg-c previous-production))
                                 (push (list current-goal previous-production *time*)
                                       *previous-instantiations*))
                                (t
                                 (push previous-firing *previous-instantiations*)))
                          (return))
                         ;; just another production in the subgoal
                         (t
                          (unless (and eventual-success eventual-failure)
                            (add-reference (if eventual-failure (production-eventual-failures previous-production)
                                               (production-eventual-successes previous-production))
                                           (not (numberp *parameters-learning*))
                                           1.0 (third previous-firing))
                            (compute-r previous-production)
                            (add-reference (production-eventual-efforts previous-production)
                                           (not (numberp *parameters-learning*))
                                           (- *time* (third previous-firing))
                                           (- *time* (third previous-firing)))
                            (compute-b previous-production)
                            (pg-c previous-production)))))))))
          (t ; push occurred
           (when production
             (push (list goal production (- *time* latency))
                   *previous-instantiations*))))))


(format t "~%-------------------------------------~%~
           Production rule learning version 1.0.1b~%~
           7 march 2000 Niels Taatgen~%~
           -------------------------------------~%~
           Please send any bugs and comments to niels@tcw2.ppsw.rug.nl")