;;;<pre>
;;; Reversal-shift learning, child model
;;; Use (do-it-kendler n) to run an experiment, with n the number of virtual subjects
;;; Model by Niels Taatgen
;;; n.a.taatgen@bcn.rug.nl
;;; http://tcw2.ppsw.rug.nl/~niels
;;;


;;;
;;; Lisp code to run experiments
;;;

(defvar *result* nil)
(defvar *status* 'initial)
(defvar *answer*)
(defvar *count* nil)
(defvar *v* nil)
(defvar *egs*)
(defvar *egs-s* 1.3)
(defvar *egs-f* 0.35)
(defvar *runs* 1)

(defparameter *kendler-exp-results* '(6.0 15.8 24.4 9.0))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; This section contains the interface for the WWW using the
;;; ACT-R on the Web application by Elmar Schwarz

(defvar *WWW-interface*)

(setf  *WWW-interface* 
      '((:heading "Kendler and Kendler Experiment Model" 2)
        (:table)
        
        (:table)
        "Expected gain S (fast): "  (:string :sy *egs-f* 0.35)  (:new-row)
        "Expected gain S (slow): "  (:string :sy *egs-s* 1.3)   (:new-row)
        "Number of runs (1-20): "   (:string :sy *runs*  1)
        (:table-end)
        
        (:table)
        (:checkbox "Trace" :sy *v*  nil) 
#| (:new-row)
        (:checkbox "Text output" :sy *text*  t) (:new-row)
        (:checkbox "Graphic output" :sy *graphic*  nil) (:new-row)
        (:checkbox "Show simulation and experiment data on one graph" :sy *overlay*  nil) 
|#       
        (:table-end)
        
        (:table-end)
        (:new-para)
        (:button "Show Experiment Results" "(display-kendler *kendler-exp-results* nil)")
       
        
        (:new-para)
        
        (:button "Run model" "(if (and (numberp *egs-f*) (numberp *egs-s*) (numberp *runs*))
                                  (do-it-kendler (min 20 (max 1 *runs*)))
                                  (format *standard-output* \"All parameters must be numbers~%\"))")
        (:reset "Default values")
        (:button "Production Rules" "(let ((prods (no-output (pp))))
                                       (dolist (x prods)
                                         (pp-fct (list x))
                                         (spp-fct (list x))
                                         (format *standard-output* \"~%\")))")
        (:button "Chunk types" "(chunk-type)")
        (:button "Chunks" "(dm)")
        (:new-para)
         "TIME and SIZE:"
        (:new-para)
        "- It usually takes less than 1 minute for 1 run of the model"
        (:new-line)
        "- The trace of 1 run is approximatly 70k (40 pages) in size"
        (:new-para)))








(defun add-success-kendler () 
  (setf *result* '+))

(defun add-failure-kendler () 
  (setf *result* '-))

(defun random-color-kendler ()
  (nth (random 2) '(red green)))

(defun random-size-kendler ()
  (nth (random 2) '(large small)))

(defun check-answer-kendler (color size)
  (cond
   ((eq *status* 'initial)
    (if (eq color 'red) 'yes 'no))
   ((eq *status* 'reversal)
    (if (eq color 'green) 'yes 'no))
   ((eq *status* 'non-reversal)
    (if (eq size 'large) 'yes 'no))))

(defun random-goal-kendler-f ()
     (let ((color (random-color-kendler))
           (size (random-size-kendler))
           (ob1 (gentemp "O")))
       (setf *answer* (check-answer-kendler color size))
       (addwm-fct 
        (list (list ob1 'isa 'object)
              (list (gentemp "P") 'isa 'property 'of ob1 'type 'psize 'value size)
              (list (gentemp "P") 'isa 'property 'of ob1 'type 'pcolor 'value color)))
       (addwm-fct 
        (list (list (gentemp "CAT") 'isa 'gen-goal-f 'object ob1)))))

(defun random-goal-kendler-s ()
  (let ((color (random-color-kendler))
        (size (random-size-kendler)))
    (setf *answer* (check-answer-kendler color size))
    (addwm-fct 
     (list (list (gentemp "CAT") 'isa 'gen-goal-s 'prop1 size 'prop2 color)))))

(defun do-random-kendler (which)
  (setf *result* nil)
  (wmfocus-fct (funcall which))
  (run))

(defun do-ten-ok-kendler (which &optional (n 10)(x 0))
  
  (if (and (> n 0) (< x 100))
      (progn (do-random-kendler which)
	     (if (eq *result* '+)
                 (do-ten-ok-kendler which (- n 1)(+ x 1))
		 (do-ten-ok-kendler which 10 (+ x 1))))
      x))

(defun do-reversal-experiment-kendler (n conditie which)
  (setf *count* nil)
  (let (res)
    (dotimes (i n)
      (reset)
      (sgp-fct (list  :era t :pl 0.5 :er t :ans 0.1 :egs *egs* :v *v*))
      (setup-dependency-production-kendler which)
      (setf *status* 'initial)
      (setf res (- (do-ten-ok-kendler which) 10))
      (when (not (= res 90))
	(setf *status* conditie)
	(setf res (- (do-ten-ok-kendler which) 10))
	  (when (not (= res 90))
            (push res *count*))))))

(defun setup-dependency-production-kendler (which)
  (if (equal which #'random-goal-kendler-f)
      (pdisable-fct (list 'build-dependency))
      (pdisable-fct (list 'pop-dependency))))

(defun do-it-kendler (n)
  (let ((rev nil))
    (setf *egs* *egs-f*)
    (when *v*
      (format *standard-output* "~%~%Fast child simulation of reversal:~%~%"))
    (do-reversal-experiment-kendler n 'reversal #'random-goal-kendler-f)
    (if *count*
        (push (/ (apply #'+ *count*) (length *count*)) rev)
        (push -1 rev))
    (when *v*
      (format *standard-output* "~%~%Fast child simulation of extra-dimensional:~%~%"))
    (do-reversal-experiment-kendler n 'non-reversal #'random-goal-kendler-f)
    (if *count*
        (push (/ (apply #'+ *count*) (length *count*)) rev)
        (push -1 rev))
    (setf *egs* *egs-s*)
    (when *v*
      (format *standard-output* "~%~%Slow child simulation of reversal:~%~%"))
    (do-reversal-experiment-kendler n 'reversal #'random-goal-kendler-s)
    (if *count*
        (push (/ (apply #'+ *count*) (length *count*)) rev)
        (push -1 rev))
    (when *v*
      (format *standard-output* "~%~%Slow child simulation of extra-dimensional:~%~%"))
    (do-reversal-experiment-kendler n 'non-reversal #'random-goal-kendler-s)
    (if *count*
        (push (/ (apply #'+ *count*) (length *count*)) rev)
        (push -1 rev))
    (display-kendler (reverse rev) t)))

(defun display-kendler (data simulation)
  (format *standard-output* "~%~A Data:~%~%" (if simulation "Simulation" "Experimental"))

  (when simulation
    (format *standard-output* "Parameters for run: (~S ~S ~S)~%" *egs-s* *egs-f* *runs*))

  (format *standard-output* "~%Mean Number of Trials to Criterion of 10 Correct Classification~%")
  (format *standard-output* "                  Type of Transfer~%")
  (format *standard-output* "              Reversal       Extra-Dimensional~%")
  (format *standard-output* "Fast Child     ~4,1f                 ~4,1f~%" (nth 0 data) (nth 1 data))
  (format *standard-output* "Slow Child     ~4,1f                 ~4,1f~%" (nth 2 data) (nth 3 data)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;<a name="model">
;;;;;;;;;;;;;;;;;;;;;;;;;;;;</a>

(clearall)

;;; Parameters

(sgp :era t				; rational analysis
     :pl 0.5				; parameters learning
     :er t				; randomness enabled
     :ans 0.1				; activation noise
     :egs 0.35                           ; expected gain noise
     )

(set-analogized-parameters :successes 10 :failures 0 :eventual-successes 10
			 :eventual-failures 0)

;;; Chunk-types

(chunk-type gen-goal-f object property answer ptype tried)
(chunk-type konstant)
(chunk-type property of type value)
(chunk-type property-type label)
(chunk-type object did-retry)

(chunk-type gen-goal-s prop1 prop2 answer)
(chunk-type tried object value)

;;; Initial declarative memory

(set-dm
 (red isa konstant)
 (green isa konstant)
 (large isa konstant)
 (small isa konstant)
 (yes isa konstant)
 (no isa konstant)
 (t isa konstant)
 (dont-know isa konstant)
 (pcolor isa property-type label CL)
 (psize isa property-type label SZ)
 (CL isa konstant)
 (SZ isa konstant))


;;;
;;; Start of productions
;;;

(p select-property-type
"
 select a property of the task to focus on
 this rule will compete with any learned rules
"
   =goal>
      isa gen-goal-f
      property nil
      ptype nil

   =ptype>
      isa property-type
==>   
   =goal>
      ptype =ptype
)

(parameters select-property-type :r-alpha 20 :r-beta 2)


(p select-other-type
"
 If a property is selected for which there is already a
 dependency, try another.
 The tried-flag prohibits endless loops.
 This production has the failure-parameter set to T, since it marks
 failure for the original selection.
"
   =goal>
      isa gen-goal-f
      ptype =type
      property nil
    - tried t

   =dependency>
      isa dependency
      specifics =type

   =type>
      isa property-type
      label =l1

   =newtype>
      isa property-type
    - label =l1
==>
   =goal>
      ptype =newtype
      tried t
)

(parameters select-other-type :q-alpha 100 :q-beta 0 :r-alpha 100 :r-beta 0 
:failure t)


(p create-property-dependencies
"
 Create a dependency that is an example of retrieving the property
"
   =goal>
      isa gen-goal-f
      object =object
      property nil
      ptype =label

   =property>
      isa property
      of =object
      type =label
      value =value
==>
   =goal>
      property =value
      tried nil

   =oldgoal>
      isa gen-goal-f
      object =object

   =newgoal>
      isa gen-goal-f
      object =object
      property =value
      ptype =label

   =dependency>
      isa dependency
      goal =oldgoal
      modified =newgoal
      constraints =property
      specifics =label

   !push! =dependency
)

(parameters create-property-dependencies :r-alpha 10 :r-beta 50 :b-b 40 :b-v 40)


(p answer-dont-know-f
"
 If there is no rule that can give an answer, give don't know as an answer
 the dummy retrieval allows analogy to beat this production.
"
   =goal>
      isa gen-goal-f
    - property nil
      answer nil

   =dummy>
      isa konstant
==>
   =goal>
      answer dont-know
)

(parameters answer-dont-know-f :r-alpha 2 :r-beta 10)


(p evaluate-answer-correct-f
"
 If the expected answer is equal to the real answer, pop with success.
"
   =goal>
      isa gen-goal-f
      answer =answer

   !eval! (equal =answer *answer*)
==>
   !output! ("The answer is ~S, which is correct" =answer)

   !eval! (add-success-kendler)

   !pop!
)

(parameters evaluate-answer-correct-f :success t)


(p evaluate-answer-false-f
"
 If the expected answer differs from the real answer, create a
 dependency that is an example of giving the right answer.
"
   =goal>
      isa gen-goal-f
      object =ob
      property =prop
      ptype =ptype
      answer =answer

   !eval! (not (equal  =answer *answer*))
==>
   =goal>
      answer (!eval! *answer*)

   !output! ("The answer given is ~S, but should have been ~S" =answer 
             *answer*)

   !eval! (add-failure-kendler)

   =oldgoal>
      isa gen-goal-f
      object =ob
      property =prop
      ptype =ptype

   =dependency>
      isa dependency
      goal =oldgoal
      modified =goal
      specifics =prop

   !focus-on! =dependency     
)

(parameters evaluate-answer-false-f :failure t :r-alpha 100)

(p pop-dependency
   =goal>
      isa dependency
==>
   !pop!
)


;;;
;;; Start of productions
;;;


(p answer-dont-know
"
 If there is no rule that can give an answer, give don't know as an answer
 the dummy retrieval allows analogy to beat this production.
"
   =goal>
      isa gen-goal-s
      answer nil
==>
   =goal>
      answer dont-know
)

(parameters answer-dont-know :r-alpha 2 :r-beta 10)


(p evaluate-answer-correct
"
 If the expected answer is equal to the real answer, pop with success.
"
   =goal>
      isa gen-goal-s
      answer =answer

   !eval! (equal =answer *answer*)
==>
   !output! ("The answer is ~S, which is correct" =answer)

   !eval! (add-success-kendler)

   !pop!
)

(parameters evaluate-answer-correct :success t)


(p evaluate-answer-false
"
 If the expected answer differs from the real answer, create a
 dependency that is an example of giving the right answer.
"
   =goal>
      isa gen-goal-s
      prop1 =p1
      prop2 =p2
      answer =answer

   !eval! (not (equal =answer *answer*))
==>
   !output! ("The answer given is ~S, but should have been ~S" =answer 
             *answer*)

   !eval! (add-failure-kendler)

   =goal>
      answer (!eval! *answer*)

   =dependency>
      isa dependency
      modified =goal

   !focus-on! =dependency
)

(parameters evaluate-answer-false :failure t :r-alpha 100 
	    :r-beta 100)


(p build-dependency
   =dependency>
      isa dependency
      modified =end-goal

   =end-goal>
      isa gen-goal-s
      prop1 =p1
      prop2 =p2
      answer =answer
==>
   =start-goal>
      isa gen-goal-s
      prop1 =p1
      prop2 =p2

   =dependency>
      goal =start-goal
      specifics (!eval! (list =p1 =p2))

   !pop!
)