;;;<pre>
;;; =====
;;; Model
;;; =====

;;; Parameters

(defvar *ans* 0.25)
(defvar *rt* -3.75)
(defvar *lf* 0.125)
(defvar *mp* 1.5)
(defvar *io* 0.2)
(defvar *count-set-ratio* 10.0)
(defvar *count-delay-ratio* 1.0)

(defun output-parameters (&optional (output t))
  (format output "~%ANS: ~6,3F~CRT: ~6,3F~CLF: ~6,3F~CMP: ~6,3F~%~
                   IO: ~6,3F~CCOUNT SET: ~6,3F~CCOUNT DELAY: ~6,3F~%"
          *ans* #\tab *rt* #\tab *lf* #\tab *mp*
          *io* #\tab *count-set-ratio* #\tab *count-delay-ratio*))

;;; Odds conversion utility

(defun display-odds (probabilities &optional (ratio 1.0) (format "~6,3F"))
  (dolist (probability probabilities)
    (format t "~?~%" format (list (/ 1.0 (- (/ ratio probability) 1.0))))))

;;; Frequency tables

(defun output-frequency-table (frequencies &optional (format " ~5,3F"))
  "Prints a two-dimensional square array of frequencies."
  (format t "FREQUENCIES:~%")
  (let ((n (array-dimension frequencies 0)))
    (dotimes (i n)
      (dotimes (j n)
        (format t format (aref frequencies i j)))
      (format t "~%"))))

(defun linear-frequency (n delta)
  (let ((frequencies (make-array n :initial-element 1.0)))
    (dotimes (i n frequencies)
      (decf (aref frequencies i) (* delta (- i (/ (1- n) 2)))))))

(defun even-frequency-table (n delta)
  "Generates the frequency table for a n x n table.
   Delta specifies the constant frequency differential
   between adjacent problems, as an absolute percentage."
  (let ((frequencies (make-array (list n n) :initial-element 0.0))
        (average (/ 1.0 n n)))
    (dotimes (i n)
      (dotimes (j n)
        (setf (aref frequencies i j)
              (+ average (* delta (- n 1 i j))))))
    frequencies))

;;; Problem sets

(defun generate-linear-problems (m n frequencies)
  "Generates a set of m problems to n frequencies."
  (let ((set nil)
        (probabilities 0.0)
        (problems 0))
    (dotimes (i n)
      (incf probabilities (aref frequencies i))
      (let ((copies (- (round (* probabilities (/ m n))) problems)))
        (setf set (nconc set (make-list copies :initial-element i)))
        (incf problems copies)))
    set))

(defun generate-problems (m n frequencies)
  "Generates a set of m problems to n x n frequencies."
  (let ((set nil)
        (probabilities 0.0)
        (problems 0))
    (dotimes (i n)
      (dotimes (j n)
        (incf probabilities (aref frequencies i j))
        (let ((copies (- (round (* probabilities m)) problems)))
          (setf set (nconc set
                           (make-list copies :initial-element
                                      (cons i j))))
          (incf problems copies))))
    set))

(defun select-linear-problem (n set)
  "Selects a problem among n in set."
  (let ((problem (nth (random n) set)))
    (values problem (delete problem set :test #'eq :count 1))))

(defun select-problem (n set)
  "Selects a problem among n in set."
  (let ((problem (nth (random n) set)))
    (values (car problem) (cdr problem)
            (delete problem set :test #'eq :count 1))))

;;; Corrections

(defun correct-cycles (correct)
  "Determines the number of corrections from the value of correct."
  (cond ((numberp correct)
         (multiple-value-bind (cycles probability)
                              (truncate correct)
           (+ cycles (if (< (random 1.0) probability) 1 0))))
        (correct 1)
        (t 0)))

;;; Numbers, facts, and how to access them

(defvar *numbers* (make-array 100 :initial-element nil)
  "Caches the two-digit numbers.")

(defun get-number (i)
  "Returns the chunk for number i < 100.  Gets it from the cache *numbers*
   or extracts it from declarative memory.  Creates it if necessary."
  (or (aref *numbers* i)
      (no-output
       (let ((number (first (sdm-fct (list 'isa 'number 'value i)))))
         (unless number
           (setf number (first (add-dm-fct
                                (list (list (intern (format nil "N~D" i))
                                            'isa 'number
                                            'tens (get-number (truncate i 10))
                                            'units (get-number (mod i 10))
                                            'value i))
                                :reset-ia nil))))
         (setf (aref *numbers* i) number)))))

(defun get-number-value (number)
  "Given a chunk returns the associated number, or number if it is a number."
  (when number (chunk-slot-value-fct number 'value)))

(defvar *count-facts* (make-array 20 :initial-element nil)
  "Caches the count facts.")

(defun get-count-fact (i)
  "Returns the counting fact for i->i+1.  Gets it from the cache *count-facts*
   or extracts it from declarative memory.  Creates it if necessary." 
  (or (aref *count-facts* i)
      (no-output
       (let ((fact (first (sdm-fct (list 'isa 'count 'from (get-number i))))))
         (unless fact
           (setf fact (first (add-dm-fct (list (list (gentemp "C") 'isa 'count
                                                     'from (get-number i)
                                                     'to (get-number (1+ i))))
                                         :reset-ia nil))))
         (setf (aref *count-facts* i) fact)))))

(defvar *addition-facts* (make-array '(10 10) :initial-element nil)
  "Caches the single-digit addition table.")

(defun get-addition-fact (i j)
  "Returns the correct addition fact for i+j.  Gets it from the cache
   *addition-facts* or extracts it from declarative memory.
   Creates it if necessary."
  (or (aref *addition-facts* i j)
      (no-output
       (let* ((fact-list (list 'isa 'arithmetic
                               'first (get-number i)
                               'operator '+
                               'second (if (= i j) 'double
                                           (get-number j))
                               'result (get-number (+ i j))))
              (fact (first (sdm-fct fact-list))))
         (unless fact
           (setf fact (first (add-dm-fct (list (cons (gentemp "A") fact-list))
                                         :reset-ia nil))))
         (setf (aref *addition-facts* i j) fact)))))

(defvar *multiplication-facts* (make-array '(10 10) :initial-element nil)
  "Caches the single-digit multiplication table.")

(defun get-multiplication-fact (i j)
  "Returns the correct multiplication fact for i*j.  Gets it from the cache
   *multiplication-facts* or extracts it from declarative memory.
   Creates it if necessary."
  (or (aref *multiplication-facts* i j)
      (no-output
       (let* ((fact-list (list 'isa 'arithmetic
                               'first (get-number i)
                               'operator '*
                               'second (if (= i j) 'double
                                           (get-number j))
                               'result (get-number (* i j))))
              (fact (first (sdm-fct fact-list))))
         (unless fact
           (setf fact (first (add-dm-fct (list (cons (gentemp "A") fact-list))
                                         :reset-ia nil))))
         (setf (aref *multiplication-facts* i j) fact)))))

(defun reset-facts ()
  (setf *numbers* (make-array 100 :initial-element nil))
  (setf *count-facts* (make-array 20 :initial-element nil))
  (setf *addition-facts* (make-array '(10 10) :initial-element nil))
  (setf *multiplication-facts* (make-array '(10 10) :initial-element nil)))

(reset-facts)

;;; Number similarities

(defun ratio-similarity (value1 value2)
  (if (and (zerop value1) (zerop value2)) 1.0
      (coerce (/ (min value1 value2) (max value1 value2)) 'float)))

(defvar *similarity-function* 'ratio-similarity)

(defun set-number-similarities (&optional (numbers 10))
  (no-output
   (let ((similarities nil))
     (dotimes (first numbers)
       (dotimes (second numbers)
         (let ((similarity (funcall *similarity-function* first second)))
           (when similarity
             (push (list (get-number first) (get-number second) similarity)
                   similarities)))))
     (set-similarities-fct similarities))))

;;; Counting facts history

(defun set-count-focused-differential-history (&key (repeat 1) (delay 1)
                                                    (difference 0.05) (n 19))
  (no-output
   (let ((frequency (linear-frequency n difference)))
     (dotimes (i n)
       (rehearse-chunk-fct (list (list (get-count-fact i) (get-number i)))
                           :repeat (* repeat (aref frequency i))
                           :force t :cycle 1 :time delay)))))

(defun set-count-unfocused-differential-history (&key (repeat 1) (delay 1)
                                                      (difference 0.05) (n 19))
  (no-output
   (let ((frequency (linear-frequency n difference)))
     (dotimes (i n)
       (rehearse-chunk-fct (list (list (get-count-fact i)
                                       (get-number i) (get-number (1+ i))))
                           :repeat (* repeat (aref frequency i))
                           :force t :cycle 1 :time delay)))))

;;; Count sampling

(defun deterministic-count-sampling (n &key (output t))
  (no-output
   (format output "~%Count Retrievals:~%")
   (let* ((results (make-array (list n (1+ n)) :initial-element 0.0))
          (rt (first (sgp :rt)))
          (noise (first (sgp :ans)))
          (temperature (* (sqrt 2.0) noise)))
     (sgp :ans nil)
     (unless (dm test-count)
       (add-dm-fct '((test-count isa count)) :reset-ia nil))
     (goal-focus test-count)
     (dotimes (i n)
       (let ((sum (exp (/ rt temperature)))
             (number (get-number i)))
         (mod-focus-fct (list 'from number))
         (setf (aref results i n) sum)
         (dotimes (j n)
           (let* ((count (get-count-fact j))
                  (prob (exp (/ (- (first (first (sdp-fct (list count :activation))))
                                   (* *mismatch-penalty*
                                      (- 1.0 (similarity-fct number
                                                             (chunk-slot-value-fct count 'from)))))
                                temperature)))
                  (to (chunk-slot-value-fct count 'to)))
             (when to (setf to (get-number-value to)))
             (incf (aref results i (or to n)) prob)
             (incf sum prob)))
         (dotimes (j (1+ n))
           (setf (aref results i j) (/ (aref results i j) sum))
           (format output "~5,1F~C" (* 100 (aref results i j)) #\tab))
         (format output "~%")))
     (sgp-fct (list :ans noise))
     (unless output (values results)))))

;;; Count training

(defstruct count from answer latency retrievals)

(defvar *count-feedback* t)

(defvar *count-answer* nil)

(defvar *count-retrievals* 0)

(defun get-count-result (from)
  (get-number (1+ (get-number-value from))))

(defun count-problem (i)
  (no-output
   (setf *count-answer* nil)
   (setf *count-retrievals* 0)
   (let ((goal (first (add-dm-fct (list (list (gentemp "C") 'isa 'count
                                              'from (get-number i)))
                                  :reset-ia nil))))
     (goal-focus-fct (list goal))
     (let ((latency (run 1)))
       (setf *count-answer* (get-number-value *count-answer*))
       (make-count :from i :answer *count-answer* :latency latency
                   :retrievals *count-retrievals*)))))

(defun analyze-count-errors (counts set n &key (output t))
  (let ((total-retrievals (length counts))
        (total-errors 0)
        (odds 0.0)
        (totals (make-array n :initial-element 0))
        (errors (make-array n :initial-element 0)))
    (dolist (count counts)
      (let ((from (count-from count))
            (answer (count-answer count)))
        (incf (aref totals from) 1)
        (unless (and (numberp answer) (= answer (1+ from)))
          (incf total-errors 1)
          (incf (aref errors from) 1))))
    (setf odds (/ (- set (- total-retrievals total-errors))
                  (- total-retrievals total-errors)))
    (format output "COUNT RETRIEVALS: ~D~CERRORS: ~D~C PERCENTAGE: ~6,1F~CLOG ODDS: ~6,3F~%ERRORS:"
            total-retrievals #\tab total-errors #\tab
            (* 100.0 (/ total-errors total-retrievals)) #\tab
            (if (= odds 0.0) odds (log odds)))
    (dotimes (from n)
      (format output " ~3D" (aref errors from)))
    (format output "~%PERCNT:")
    (dotimes (from n)
      (format output " ~3D" (if (zerop (aref totals from)) 0
                                (round (* 100 (/ (aref errors from)
                                                 (aref totals from)))))))
    (format output "~%")
    total-retrievals))

(defun count-problems (&key (difference 0.05) (n 19)
                            (delay 1500.0) (runs 10) (set 1000)
                            (reset t) (output t))
  (output-parameters output)
  (when reset (reset) (eval reset) (reset-facts))
  (no-output
   (let ((problems (generate-linear-problems set n (linear-frequency n difference))))
     (dotimes (run runs)
       (format output "~%COUNT RUN ~D~%" (1+ run))
       (let ((problems (copy-seq problems))
             (from nil)
             (result nil)
             (results nil))
         (dotimes (problem set)
           (multiple-value-setq (from problems)
             (select-linear-problem (- set problem) problems))
           (setf result (count-problem from))
           (unless (zerop (count-retrievals result))
             (push result results))
           (when delay (actr-time-fct delay)))
         (analyze-count-errors results set n :output output))))))

;;; Run a single addition problem

(defstruct problem first operator second answer latency retrievals computations)

(defvar *feedback* t)

(defvar *addition-answer* nil)

(defvar *repeated-answer* nil)

(defvar *multiplication-answer* nil)

(defvar *addition-retrievals* 0)

(defvar *multiplication-retrievals* 0)

(defvar *addition-computations* 0)

(defvar *multiplication-computations* 0)

(defun get-addition-result (first second)
  (get-number (+ (get-number-value first)
                 (get-number-value (if (eq second 'double) first second)))))

(defun addition-problem (i j &optional (max -1))
  (no-output
   (setf *addition-answer* nil)
   (setf *addition-retrievals* 0)
   (setf *addition-computations* 0)
   (let ((goal (first (add-dm-fct
                       (list (list (gentemp "A") 'isa 'arithmetic
                                   'first (get-number i)
                                   'operator '+
                                   'second (get-number j)))
                       :reset-ia nil))))
     (goal-focus-fct (list goal))
     (let ((latency (run-fct max)))
       (clear-goal-stack)
       (setf *addition-answer* (get-number-value *addition-answer*))
       (make-problem :first i :operator '+ :second j
                     :answer *addition-answer* :latency latency
                     :retrievals *addition-retrievals*
                     :computations *addition-computations*)))))

;;; Analyze errors and latencies of a list of problems

(defun analyze-errors (problems n &key (operator '+) (output t))
  (let ((total-errors 0)
        (totals (make-array (list (1+ n) (1+ n)) :initial-element 0))
        (errors (make-array (list (1+ n) (1+ n)) :initial-element 0))
        (retrievals 0)
        (computations 0))
    (format output "~%Errors: ")
    (dolist (problem problems)
      (let ((first (problem-first problem))
            (second (problem-second problem))
            (answer (problem-answer problem)))
        (incf (aref totals first second) 1)
        (unless (and (numberp answer) (= answer (funcall operator first second)))
          (incf total-errors 1)
          (incf (aref errors first second) 1))
        (incf retrievals (problem-retrievals problem))
        (incf computations (problem-computations problem))))
    (format output "~D~%" total-errors)
    (dotimes (first n)
      (dotimes (second n)
        (format output "~3D~C" (aref errors first second) #\tab)
        (incf (aref totals n second) (aref totals first second))
        (incf (aref totals first n) (aref totals first second))
        (incf (aref errors n second) (aref errors first second))
        (incf (aref errors first n) (aref errors first second)))
      (unless (zerop (aref totals first n))
        (setf (aref errors first n) (/ (aref errors first n) (aref totals first n))))
      (format output "~C~3D~%" #\tab (round (* 100 (aref errors first n)))))
    (format output "~%")
    (dotimes (second n)
      (unless (zerop (aref totals n second))
        (setf (aref errors n second) (/ (aref errors n second) (aref totals n second))))
      (format output "~3D~C" (round (* 100 (aref errors n second))) #\tab))
    (format output "~%Retrievals: ~D~%Computations: ~D~%" retrievals computations)
    (values retrievals computations)))

(defun analyze-latencies (problems n &key (cutoff n) (operator '+) (output t))
  (format output "~%Latencies:~%")
  (let ((zeroes (make-array (list (* 2 n) 2) :initial-element 0.0))
        (ties (make-array (list (* 2 n) 2) :initial-element 0.0))
        (by-sum (make-array (list (* 2 n) 2) :initial-element 0.0))
        (by-size (make-array (list 2 2) :initial-element 0.0)))
    (dolist (problem problems)
      (unless (and (zerop (problem-retrievals problem))
                   (zerop (problem-computations problem)))
        (let* ((first (problem-first problem))
               (second (problem-second problem))
               (sum (funcall operator first second))
               (size (if (>= sum cutoff) 1 0))
               (array (cond ((or (zerop first) (zerop second)) zeroes)
                            ((= first second) ties)
                            (t by-sum)))
               (latency (+ *io* (problem-latency problem))))
          (incf (aref array sum 0) latency)
          (incf (aref array sum 1) 1.0)
          (incf (aref by-size size 0) latency)
          (incf (aref by-size size 1) 1.0))))
    (dotimes (size 2)
      (when (> (aref by-size size 1) 0.0)
        (setf (aref by-size size 0)
              (/ (aref by-size size 0) (aref by-size size 1)))))
    (dotimes (sum (* 2 n))
      (dolist (array (list zeroes ties by-sum))
        (when (> (aref array sum 1) 0.0)
          (setf (aref array sum 0) (/ (aref array sum 0) (aref array sum 1)))
          (format output "~6,3F" (aref array sum 0)))
        (format output "~C" #\tab))
      (format output "~%"))
    (format output "~%Small: ~6,3F~%Large: ~6,3F~%"
            (aref by-size 0 0) (aref by-size 1 0))))

;;; Run a series of addition problems

(defun addition-problems (&key (difference 0.0005) (n 10) (max nil)
                               (delay 7500.0) (correct nil) (teach nil)
                               (runs 20) (set 2000) (feedback 1.0)
                               (reset t) (output t) (multiplication nil))
  (output-parameters output)
  (when reset
    (reset)
    (eval reset)
    (reset-facts)
    (set-count-unfocused-differential-history :repeat (/ set *count-set-ratio*)
                                              :delay (/ delay *count-delay-ratio*)))
  (no-output
   (let ((problems (generate-problems set n (even-frequency-table n difference)))
         (addition-feedback feedback)
         (multiplication-feedback feedback))
     (dotimes (run runs addition-feedback)
       (when (and (numberp multiplication) (>= run multiplication))
         (setf multiplication-feedback
               (multiplication-problems :difference difference :n n :max max
                                        :offset (- run multiplication)
                                        :delay delay :correct correct :teach teach
                                        :runs 1 :set set :feedback multiplication-feedback
                                        :output output)))
       (format output "~%ADDITION RUN ~D~%FEEDBACK PROBABILITY ~6,3F~%" (1+ run)
               addition-feedback)
       (let ((problems (copy-seq problems))
             (first nil)
             (second nil)
             (result nil)
             (retrieval-results nil)
             (computation-results nil))
         (dotimes (problem set)
           (setf *feedback* (< (random 1.0) addition-feedback))
           (multiple-value-setq (first second problems)
             (select-problem (- set problem)
                             problems))
           (setf result (addition-problem first second (or max (* 3 (+ second 3)))))
           (unless (zerop (problem-retrievals result))
             (push result retrieval-results))
           (unless (zerop (problem-computations result))
             (push result computation-results))
           (let ((cycles (correct-cycles teach)))
             (unless (equal (problem-answer result) (+ first second))
               (incf cycles (correct-cycles correct)))
             (when (> cycles 0)
               (rehearse-chunk-fct (list (list (get-addition-fact first second)
                                               (get-number first) '+
                                               (if (= first second)
                                                 'double (get-number second))))
                                   :force t :cycle cycles :time 1.0)))
           (when delay (actr-time-fct delay)))
         (setf addition-feedback
               (* feedback (- 1.0 (/ (analyze-errors retrieval-results n :output output) set))))
         (analyze-latencies retrieval-results n :output output)
         (analyze-errors computation-results n :output output)
         (analyze-latencies computation-results n :output output))))))

;;; Run a series of multiplication-by-repeated-addition problems

(defun repeated-addition-problem (i j &optional (max -1))
  (no-output
   (setf *repeated-answer* nil)
   (setf *addition-retrievals* 0)
   (setf *addition-computations* 0)
   (let ((goal (first (add-dm-fct
                       (list (list (gentemp "M") 'isa 'iterate-add
                                   'count 'n0 'limit (get-number i)
                                   'increment (get-number j)
                                   'tens 'n0 'units 'n0))
                       :reset-ia nil))))
     (goal-focus-fct (list goal))
     (let ((latency (run-fct max)))
       (clear-goal-stack)
       (setf *repeated-answer* (get-number-value *repeated-answer*))
       (make-problem :first i :operator '* :second j
                     :answer *repeated-answer* :latency latency
                     :retrievals *addition-retrievals*
                     :computations *addition-computations*)))))

(defun repeated-addition-problems (&key (difference 0.0) (n 10) (max nil)
                                        (delay 150.0) (samples 100) (output t))
  (no-output
   (let* ((problems (generate-problems samples n (even-frequency-table n difference)))
          (first nil)
          (second nil)
          (results nil))
     (format output "~%Multiplication as repeated addition: ")
     (dotimes (problem samples)
       (multiple-value-setq (first second problems)
         (select-problem (- samples problem) problems))
       (push (repeated-addition-problem first second (or max (* 15 (1+ first)))) results)
       (when delay (actr-time-fct delay)))
     (analyze-errors results n :operator '* :output output))))

;;; Multiplication

(defun get-multiplication-result (first second)
  (get-number (* (get-number-value first)
                 (get-number-value (if (eq second 'double) first second)))))
  
(defun multiplication-problem (i j &optional (max -1))
  (no-output
   (setf *multiplication-answer* nil)
   (setf *multiplication-retrievals* 0)
   (setf *multiplication-computations* 0)
   (let ((goal (first (add-dm-fct
                       (list (list (gentemp "A") 'isa 'arithmetic
                                   'first (get-number i)
                                   'operator '*
                                   'second (get-number j)))
                       :reset-ia nil))))
     (goal-focus-fct (list goal))
     (let ((latency (run-fct max)))
       (clear-goal-stack)
       (setf *multiplication-answer* (get-number-value *multiplication-answer*))
       (make-problem :first i :operator '* :second j
                     :answer *multiplication-answer* :latency latency
                     :retrievals *multiplication-retrievals*
                     :computations *multiplication-computations*)))))

(defun multiplication-problems (&key (difference 0.0005) (n 10) (max nil) (offset 0)
                                     (delay 7500.0) (correct nil) (teach nil)
                                     (runs 20) (set 2000) (feedback 1.0) (output t))
  (no-output
   (let ((problems (generate-problems set n (even-frequency-table n difference)))
         (multiplication-feedback feedback))
     (dotimes (run runs multiplication-feedback)
       (format output "~%MULTIPLICATION RUN ~D~%FEEDBACK PROBABILITY ~6,3F~%"
               (+ run 1 offset) multiplication-feedback)
       (let ((problems (copy-seq problems))
             (first nil)
             (second nil)
             (result nil)
             (retrieval-results nil)
             (computation-results nil))
         (dotimes (problem set)
           (setf *feedback* (< (random 1.0) multiplication-feedback))
           (multiple-value-setq (first second problems)
             (select-problem (- set problem) problems))
           (setf result (multiplication-problem first second (or max (* 15 (1+ first)))))
           (unless (zerop (problem-retrievals result))
             (push result retrieval-results))
           (unless (zerop (problem-computations result))
             (push result computation-results))
           (let ((cycles (correct-cycles teach)))
             (unless (equal (problem-answer result) (* first second))
               (incf cycles (correct-cycles correct)))
             (when (> cycles 0)
               (rehearse-chunk-fct (list (list (get-multiplication-fact first second)
                                               (get-number first) '*
                                               (if (= first second)
                                                 'double (get-number second))))
                                   :force t :cycle cycles :time 1.0)))
           (when delay (actr-time-fct delay)))
         (setf multiplication-feedback
               (* feedback (- 1.0 (/ (analyze-errors retrieval-results n :operator '*
                                                     :output output) set))))
         (analyze-latencies retrieval-results n :output output)
         (analyze-errors computation-results n :operator '* :output output)
         (analyze-latencies computation-results n :output output))))))

;;; Top level simulation function

(defun lifetime ()
  (addition-problems :multiplication 2))

;;; =====
;;; Model
;;; =====

(clear-all)

(sgp-fct (list :era t
               :bll 0.5
               :al 1.0
               :ans *ans*
               :rt *rt*
               :lf *lf*
               :pm t
               :mp *mp*
               :v nil))

(chunk-type operator function)

(chunk-type number tens units value)

(chunk-type count from to)

(chunk-type arithmetic first operator second result)

(chunk-type iterate-count count limit result)

(chunk-type iterate-add count limit increment tens units)

(chunk-type split number tens units)

(add-dm
 ;;; symbols
 (+ isa operator function #'+)
 (double isa operator function #'+)
 (* isa operator function #'*)
 ;;; numbers
 (n0 isa number tens n0 units n0 value 0)
 (n1 isa number tens n0 units n1 value 1)
 (n2 isa number tens n0 units n2 value 2)
 (n3 isa number tens n0 units n3 value 3)
 (n4 isa number tens n0 units n4 value 4)
 (n5 isa number tens n0 units n5 value 5)
 (n6 isa number tens n0 units n6 value 6)
 (n7 isa number tens n0 units n7 value 7)
 (n8 isa number tens n0 units n8 value 8)
 (n9 isa number tens n0 units n9 value 9)
 (n10 isa number tens n1 units n0 value 10)
 (n11 isa number tens n1 units n1 value 11)
 (n12 isa number tens n1 units n2 value 12)
 (n13 isa number tens n1 units n3 value 13)
 (n14 isa number tens n1 units n4 value 14)
 (n15 isa number tens n1 units n5 value 15)
 (n16 isa number tens n1 units n6 value 16)
 (n17 isa number tens n1 units n7 value 17)
 (n18 isa number tens n1 units n8 value 18)
 (n19 isa number tens n1 units n9 value 19)
 )

;; prevent mismatches between + and *
(set-similarities (+ * -10.0))

(set-number-similarities)

;;; ===================
;;; counting production
;;; ===================

(p count-up
   =goal>
      isa count
      from =from
      to nil
   =fact>
      isa count
      from =from
      to =to
==>
   !output! ("Counting from ~S to ~S" =from =to)
   !eval! (progn (setf *count-answer* =to) (incf *count-retrievals*))
   =goal>
      to =to
   !pop!)

;;; feedback production

(p solve-count
   =goal>
      isa count
      from =from
      to nil
   !eval! *count-feedback*
==>
   !bind! =to (get-count-result =from)
   !eval! (setf *count-answer* =to)
   =goal>
      to =to
   !pop!)

;;; ======================
;;; arithmetic productions
;;; ======================

(p done-arithmetic
   =goal>
      isa arithmetic
      first =first
      operator =operator
      second =second
      result =result
==>
   !output! ("Result ~S ~S ~S = ~S" =first =operator =second =result)
   !eval! (if (equal =operator '+)
            (setf *addition-answer* =result)
            (setf *multiplication-answer* =result))
   !pop!)

(p first-plus-zero
   =goal>
      isa arithmetic
      first =first
      operator +
      second n0
      result nil
==>
   !output! ("~S + 0 = ~S" =first =first)
   =goal>
      result =first)   

(p zero-plus-second
   =goal>
      isa arithmetic
      first n0
      operator +
      second =second
      result nil
==>
   !output! ("0 + ~S = ~S" =second =second)
   =goal>
      result =second)

(spp (first-plus-zero zero-plus-second) :effort 0.7)

(p double-recoding
   =goal>
      isa arithmetic
      first =first
      operator =operator
      second =first
      result nil
==>
   !output! ("Recoding ~S ~S ~S as ~S ~S Double"
             =first =operator =first =first =operator)
   =subgoal>
      isa arithmetic
      first =first
      operator =operator
      second double
      result =result
   !push! =subgoal
   =goal>
      result =result)

(p arithmetic-retrieval
   =goal>
      isa arithmetic
      first =first
      operator =operator
      second =second
      result nil
   =fact>
      isa arithmetic
      first =first
      operator =operator
      second =second
      result =result
==>
   !output! ("Retrieving ~S" =fact)
   !eval! (if (equal =operator '+)
            (incf *addition-retrievals*)
            (incf *multiplication-retrievals*))
   =goal>
      result =result)   

;;; ====================
;;; Addition Computation
;;; ====================

;;; feedback production

(p solve-addition
   =goal>
      isa arithmetic
      first =first
      operator +
      second =second
      result nil
   !eval! *feedback*
==>
   !bind! =result (get-addition-result =first =second)
   =goal>
      result =result)

(p double-counting
   =goal>
      isa arithmetic
      first =first
      operator +
      second double
      result nil
==>
   =subgoal>
      isa iterate-count
      count n0
      limit =first
      result =first
      result =result
   !push! =subgoal
   !output! ("Subgoaling ~S" =subgoal)
   !eval! (incf *addition-computations*)
   =goal>
      result =result)

(p addition-counting
   =goal>
      isa arithmetic
      first =first
      operator +
      second =second
      result nil
==>
   =subgoal>
      isa iterate-count
      count n0
      limit =second
      result =first
      result =result
   !push! =subgoal
   !output! ("Subgoaling ~S" =subgoal)
   !eval! (incf *addition-computations*)
   =goal>
      result =result)

;;; iterate-count productions

(p done-count
   =goal>
      isa iterate-count
      count =count
      limit =count
      result =result
==>
   !output! ("Done with count ~S and result ~S" =count =result)
   !pop!)

(p iterate-count
   =goal>
      isa iterate-count
      count =count
    - limit =count
      result =result
    - result failure
==>
   !output! ("Incrementing ~S and ~S" =count =result)
   =subgoal1>
      isa count
      from =count
      to =next-count
   =subgoal2>
      isa count
      from =result
      to =next-result
   !push! =subgoal2
   !push! =subgoal1
   =goal>
      count =next-count
      result =next-result)

(spp iterate-count :effort 0.5)

;;; ==========================
;;; Multiplication Computation
;;; ==========================

;;; feedback production

(p solve-multiplication
   =goal>
      isa arithmetic
      first =first
      operator *
      second =second
      result nil
   !eval! *feedback*
==>
   !bind! =result (get-multiplication-result =first =second)
   =goal>
      result =result)

(p double-adding
   =goal>
      isa arithmetic
      first =first
      operator *
      second double
      result nil
==>
   =subgoal>
      isa iterate-add
      count n0
      limit =first
      increment =first
      tens n0
      units n0
      units =result
   !push! =subgoal
   !output! ("Subgoaling ~S" =subgoal)
   !eval! (incf *multiplication-computations*)
   =goal>
      result =result)

(p multiplication-adding
   =goal>
      isa arithmetic
      first =first
      operator *
      second =second
      result nil
==>
   =subgoal>
      isa iterate-add
      count n0
      limit =first
      increment =second
      tens n0
      units n0
      units =result
   !push! =subgoal
   !output! ("Subgoaling ~S" =subgoal)
   !eval! (incf *multiplication-computations*)
   =goal>
      result =result)

;;; iterate-add productions

(p construct-result
   =goal>
      isa iterate-add
      count =count
      limit =count
      tens =tens
    - tens failure
      units =units
    - units failure
==>
   !output! ("Constructing the result from tens ~S and units ~S"
             =tens =units)
   !bind! =value (+ (* 10 (chunk-slot-value-fct =tens 'value))
                    (chunk-slot-value-fct =units 'value))
   =number>
      isa number
      tens =tens
      units =units
      value =value
   !push! =number
   =goal>
      tens nil
      units =number)

(p done-add
   =goal>
      isa iterate-add
      count =count
      limit =count
      tens nil
      units =answer
==>
   !output! ("The answer is ~S" =answer)
   !eval! (setf *repeated-answer* =answer)
   !pop!)

(p iterate-add
   =goal>
      isa iterate-add
      count =count
    - limit =count
      increment =increment
      tens =tens
      units =units
==>
   !output! ("Incrementing ~S and adding ~S to tens ~S and units ~S"
             =count =increment =tens =units)
   =count-subgoal>
      isa arithmetic
      first =count
      operator +
      second n1
      result =next-count
   =add-subgoal>
      isa arithmetic
      first =units
      operator +
      second =increment
      result =answer
   =split-goal>
      isa split
      number =answer
      tens =carry
      units =new-units
   =carry-goal>
      isa arithmetic
      first =tens
      operator +
      second =carry
      result =new-tens
  !push! =carry-goal
  !push! =split-goal
  !push! =add-subgoal
  !push! =count-subgoal
   =goal>
      count =next-count
      tens =new-tens
      units =new-units)

;;; Split production

(p split
   =goal>
      isa split
      number =number
      tens nil
      units nil
==>
   !bind! =tens (chunk-slot-value-fct =number 'tens)
   !bind! =units (chunk-slot-value-fct =number 'units)
   !output! ("Splitting ~S into tens ~S and units ~S" =number =tens =units)
   =goal>
      tens =tens
      units =units
   !pop!)

;;; Number creation upon merging

(p merge-numbers
   =goal>
      isa number
      tens =tens
      units =units
      value =value
==>
   !output! ("Number ~S has value ~S" =goal =value)
   !pop!)