;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;<pre><xmp>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; ACT-R model of the Pigeon pecking experiment
;;; by Herrnstein (1961)

;;; to run the model call
;;; (run-peck ni na)
;;; where ni is the number of initial cycles
;;; to run the model, and na is the number of additional
;;; cycles to run, for which the data is reported

(defvar *left-pecks* 0)
(defvar *right-pecks* 0)
(defvar *left-reward* 0)
(defvar *right-reward* 0)
(defvar *old-left-pecks* 0)
(defvar *old-right-pecks* 0)
(defvar *old-left-reward* 0)
(defvar *old-right-reward* 0)

(defvar *left-switch* 0)
(defvar *left-state* 'not-running)
(defvar *left-start* 0)
(defvar *right-switch* 0)
(defvar *right-state* 'not-running)
(defvar *right-start* 0)
(defvar *food* nil)
(defvar *COD* 1)
(defvar *peck-action* 0.8)
(defvar *left-sched*)
(defvar *right-sched*)
(defvar *left-int*)
(defvar *right-int*)

(defvar *v* t)
(defvar *egt* .24)
(defvar *pl* .714)
(defvar *choice-g* 3.0)
(defvar *text*)
(defvar *graphic*)
(defvar *overlay*)

(setf *v* t)
(setf *egt* .24)
(setf *pl* .714)
(setf *choice-g* 3.0)
(setf *text* t)
(setf *graphic* nil)
(setf *overlay* nil)

(defun set-array-peck (llis)
(let ((arr (make-array '(5 40))))
  (do ((x llis (cdr x))(r 0 (+ 1 r)))
      ((null x))
    (do ((cntr (- (length (car x)) 1)(- cntr 1))
         (lis (reverse (car x)) (cdr lis)))
        ((< cntr 0))
      (setf (aref arr r cntr) (car lis))))
  arr))

;; list of randome poisson #s for lambda = 5, 10, 15, 25

(defparameter *schedules-peck* (set-array-peck
                               '((3 6 7 6 6 6 8 3 6 6 3 8 4 5 6 4 3 3 8 7 4 3 1 3 2 5 5 4 4 7 7 6 9 4 8 6 6 4 2 7)
                                 (14 7 10 7 4 2 10 11 15 11 12 10 9 12 7 10 15 11 13 12 8 8 11 9 14 13 5 12 11 18 9 10 8 11 12 7 11 11 6 5 )
                                 (18 15 17 11 20 10 12 20 17 18 12 15 10 21 12 14 16 13 10 9 12 9 8 17 13 11 15 15 16 12 8 14 16 14 13 18 14 15 12 18)
                                 ()
                                 (25 22 33 29 22 27 33 21 22 26 25 27 26 37 28 27 27 26 26 21 25 22 33 29 22 27 33 21 22 26 25 27 26 37 28 27 27 26 26 21))))

(defvar *left-sched* 5)
(defvar *right-sched* 10)
(defvar *i-cycles* 200)
(defvar *a-cycles* 200)

(defparameter *pigeon-peck-results* 
'(
  ((5 5) (.54 .49))
  ((5 10) (.68 .67))
  ((5 25) (.83 .86))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; 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 "The Pigeon Pecking Model" 2)
        (:table)

        (:table)
        "Decay parameter (0.0 - 1.0): "     (:string :sy *pl*   0.714)       (:new-row)
        "Expected Gain Noise (t): "            (:string :sy *egt*  .24)          (:new-row)
        "G: " (:string :sy *choice-g* 3.0) (:new-row)
        "Initial cycles (50-500)"    (:string :sy *i-cycles* 200)  (:new-row)
        "Additional cycles (50-200)"    (:string :sy *a-cycles* 200)
        (: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" "(model-output-peck *pigeon-peck-results* nil)   ")
        (:new-para)
        (:button "Run model" "(if (and (numberp *choice-g*) (numberp *pl*) (numberp *egt*)
                                                 (numberp *i-cycles*) (numberp *a-cycles*))
                                  (if (and (>= *pl* 0) (<= *pl* 1))

                                  (run-peck (min 500 (max 50 *i-cycles*)) (min 200 (max 50 *a-cycles*)))
                                  (format *standard-output* \"~%Parameters must be in the specified ranges.~%\"))
                                  (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 about 3 minutes for 1 run of 400 total cycles"
        (:new-line)
        "- The trace of 1 run of 400 total cycles is approximatly 150k (100 pages) in size"
        ))

(defun smart-ratio-peck (a b)
  (if (zerop (+ a b)) 0.0 (/ a (+ a b))))

(defun run-peck (i a)
  (let ((res nil))
    (dolist (x '((5 25) (5 10) (5 5)))
      (new-schedule-peck (car x) (second x))
      (run-fct i)
      (old-schedule-peck)
      (run-fct a)
      (push (list x (list (smart-ratio-peck (- *left-pecks* *old-left-pecks*)(- *right-pecks* *old-right-pecks*))
                          (smart-ratio-peck (- *left-reward* *old-left-reward*)(- *right-reward* *old-right-reward*))))
            res))
    (model-output-peck res t)))

(defun run-single-peck (i a)
  (new-schedule-peck *left-sched* *right-sched*)
  (run-fct i)
  (old-schedule-peck)
  (run-fct a)
  (format *standard-output* "% Responses Left: ~1,2F     % Rewards Left: ~1,2F~%"
        (smart-ratio-peck (- *left-pecks* *old-left-pecks*)(- *right-pecks* *old-right-pecks*))
        (smart-ratio-peck (- *left-reward* *old-left-reward*)(- *right-reward* *old-right-reward*))))

(defun new-schedule-peck (x y)
  (reset)
  (sgp-fct (list :v *v* :pl *pl* :egs (/ *egt* (sqrt 2)) :g *choice-g* :ut nil :ol nil))

  (setf *cod* 1)
  (setf *peck-action* 0.8)

  (setf *left-pecks* 0)
  (setf *right-pecks* 0)
  (setf *left-reward* 0)
  (setf *right-reward* 0)
  (setf *old-left-pecks* 0)
  (setf *old-right-pecks* 0)
  (setf *old-left-reward* 0)
  (setf *old-right-reward* 0)
  (setf *left-switch* 0)
  (setf *left-state* 'not-running)
  (setf *left-start* 0)
  (setf *right-switch* 0)
  (setf *right-state* 'not-running)
  (setf *right-start* 0)
  (setf *food* nil)
  (setf *left-sched* x)
  (setf *right-sched* y)
  (setf *left-int* (new-int-peck *left-sched*))
  (setf *right-int* (new-int-peck *right-sched*)))

(defun old-schedule-peck ()
  (sgp-fct (list :v *v* :pl *pl* :egs (/ *egt* (sqrt 2)) :g *choice-g* :ut nil :ol nil))
  (setq *old-left-pecks* *left-pecks*)
  (setq *old-right-pecks* *right-pecks*)
  (setq *old-left-reward* *left-reward*)
  (setq *old-right-reward* *right-reward*)
  (setf *left-switch* 0)
  (setf *left-state* 'not-running)
  (setf *left-start* 0)
  (setf *right-switch* 0)
  (setf *right-state* 'not-running)
  (setf *right-start* 0)
  (setf *food* nil)
  (setf *left-int* (new-int-peck *left-sched*))
  (setf *right-int* (new-int-peck *right-sched*)))

(defun model-output-peck (data sim)
  (when sim
     (format *standard-output* "~%~%Parameters for run: (~S ~S ~S ~S ~S)~%~%"  *pl* *egt* *choice-g* *i-cycles* *a-cycles*))

  (when *text*

    (format *standard-output* "~%~%~a Results:~%" (if sim "Simulation" "Experimental"))
    (format *standard-output* "~%  CONDITION         RESULTS~%")
    (format *standard-output* "~%Left    Right    Left    Left")
    (format *standard-output* "~%Sched   Sched    Resp    Reward")
    (format *standard-output* "~%-----   -----    -----   ------")

    (dolist (x data)
      (format *standard-output* "~%~2s      ~2s" (caar x) (cadar x))
      (dolist (y (cdr x))
        (format *standard-output* "        ~4,2f    ~4,2f~%" (car y) (second y))))

    (when (and sim *overlay*)
      (format *standard-output* "~%~%Experimental Results:~%")
      (format *standard-output* "~%  CONDITION         RESULTS~%")
      (format *standard-output* "~%Left    Right    Left    Left")
      (format *standard-output* "~%Sched   Sched    Resp    Reward")
      (format *standard-output* "~%-----   -----    -----   ------")

      (dolist (x *pigeon-peck-results*)
        (format *standard-output* "~%~2s      ~2s" (caar x) (cadar x))
        (dolist (y (cdr x))
          (format *standard-output* "        ~4,2f    ~4,2f~%" (car y) (second y)))))

    (unless *graphic* (format *standard-output*
                              "~%</pre>If your browser supports JAVA, you 
                               can display the data in a graph by checking 
                               the Graphic output box on the interface page.<pre>~%~%")))
  (when *graphic*
    (format *standard-output* " 
        <applet 
        code = \"DansGraphs.class\" 
        width = 400 
        height = 400> 
        <PARAM name=\"title\" value=\"Data for Pigeon Pecking Experiment\">
        <PARAM name=\"xmin\" value=\"0\">
        <PARAM name=\"xmax\" value=\"1.0\">
        <PARAM name=\"ymax\" value=\"1.0\">
        <PARAM name=\"ymin\" value=\"0\">
        <PARAM name=\"ydiv\" value=\"0.1\">
        <PARAM name=\"yspacing\" value=\"0.2\">
        <PARAM name=\"xdiv\" value=\"0.1\">
        <PARAM name=\"xspacing\" value=\"0.2\">
        <PARAM name=\"xname\" value=\"% Reward Left\">
        <PARAM name=\"yname\" value=\"% Respond Left\">
        <PARAM name=\"numlines\" value=\"~s\">
        <PARAM name=\"longestline\" value=\"5\">
        <PARAM name=\"lcolor0\" value=\"0\">
        <PARAM name=\"lstyle0\" value=\"~s\">
        <PARAM name=\"name0\" value=\"~a\">" 
            (if (and *overlay* sim) 2 1)
            (if sim 2 6553)
            (if sim "Simulation Data" "Experiment Data"))
    
    
    (format *standard-output* "<PARAM name=\"xval0\" value=\"")

    (dolist (x data)
      (format *standard-output* "~5,3f;" (second (second x))))
    
    (format *standard-output* "\">")
    
    (format *standard-output* "<PARAM name=\"yval0\" value=\"")

    (dolist (x data)
      (format *standard-output* "~5,3f;" (first (second x))))
    
    (format *standard-output* "\">")
    

    (when (and *overlay* sim)
    (format *standard-output* "
              <PARAM name=\"lcolor1\" value=\"0\">
              <PARAM name=\"lstyle1\" value=\"6553\">
              <PARAM name=\"name1\" value=\"Experiment Data\">
              <PARAM name=\"xval1\" value=\"")

    (dolist (x *pigeon-peck-results*)
      (format *standard-output* "~5,3f;" (second (second x))))
    
    (format *standard-output* "\">")
    
    (format *standard-output* "<PARAM name=\"yval1\" value=\"")

    (dolist (x *pigeon-peck-results*)
      (format *standard-output* "~5,3f;" (first (second x))))
    
    (format *standard-output* "\">"))
    (format *standard-output* "
             <HR> Your browser does not support JAVA, so you cannot view the graphs.~%
             </HR></applet>")))



(defun new-int-peck (val)


  (aref *schedules-peck* (- (/ val 5) 1) (floor (random 40.0))))

(defun food-time-peck (reqd start switch)
  (if (> *COD* 0)
      (and (> (- (actr-time-fct) start) reqd)(> (- (actr-time-fct) switch) (- *COD* *peck-action*)))
      (> (- (actr-time) start) reqd))
)

(defun peck-update-peck (sched)

  (cond
  ((equal sched 'left)
   (and (incf *left-pecks*)
        (if (equal *left-state* 'not-running)
          (and (not *food*)
               (setq *left-state* 'running)(setq *left-start* (actr-time)))
          (and (food-time-peck *left-int* *left-start* *left-switch*)
               (setq *food* T)(setf *left-int* (new-int-peck *left-sched*))(setq *left-state* 'not-running)(modfocus food yes)))))
  ((equal sched 'right)
   (and (incf *right-pecks*)
        (if (equal *right-state* 'not-running)
          (and (not *food*)
               (setq *right-state* 'running)(setq *right-start* (actr-time)))
          (and (food-time-peck *right-int* *right-start* *right-switch*)
               (setq *food* T)(setf *right-int* (new-int-peck *right-sched*))(setq *right-state* 'not-running)(modfocus food yes))))))
  )

(defun switch-update-peck (sched)
 (cond
   ((equal sched 'left)
    (setq *left-switch* (actr-time)))
   ((equal sched 'right)
    (setq *right-switch* (actr-time)))))

(defun update-schedule-peck (sched act)
(cond
   ((equal act 'peck)(peck-update-peck sched))
   ((equal act 'switch2)(switch-update-peck sched))))

(defun eat-food-peck (ch)
  (setq *food* nil)
  (if (equal ch 'right) (incf *right-reward*) (incf *left-reward*)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</xmp><a name="model">
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;</a><pre>
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The ACT-R model

(clearall)
(sgp
:era t
:pl 0.714
:sl nil
:g 3.0
:egs .17
:ol NIL
:an nil
:ut nil
)

(WMEType topgoal my-loc new-loc)
(WMEType goal to just switch food my-loc new-loc)

(addwm (left isa chunk)
 (get-food isa chunk)
 (no isa chunk)
 (hungry isa chunk)
 (pecking isa chunk)
 (right isa chunk)
 (pecked isa chunk)
 (yes isa chunk)
 (top isa topgoal my-loc left))

(wmfocus top)

(p ADJUST
  =goal>
   isa topgoal
   new-loc =new
==>
  =goal>
   new-loc nil
   my-loc =new)

(p HUNGRY
  =goal>
   isa topgoal
   my-loc =location
   new-loc nil
==>
  =subgoal>
   isa goal
   to get-food
   food no
   just hungry
   my-loc =location
   new-loc =new
  =goal>
   new-loc =new
 !push! =subgoal)

(spp-fct (list 'hungry
    :creation-time -1000.0
    :successes (make-list 500 :initial-element -1000.0)
    :failures 0
    :efforts 25.0
    :eventual-successes (make-list 500 :initial-element -1000.0)
    :eventual-failures 0
    :eventual-efforts 25.0))

(p PECK-LEFT
  =goal>
   isa goal
   to  get-food
   just hungry
   food no
   my-loc left
==>
  =goal>
    just pecking
    switch nil
 !output! ("Pecking Left")
 !eval! (update-schedule-peck 'left 'peck))

(p PECK-RIGHT
  =goal>
   isa goal
   to  get-food
   just hungry
   food no
   my-loc right
==>
  =goal>
    just pecking
    switch nil
 !output! ("Pecking Right")
 !eval! (update-schedule-peck 'right 'peck))

(p PECKING
  =goal>
   isa goal
   just pecking
==>
  =goal>
   just pecked)

(spp-fct (list 'PECKING
    :creation-time -100.0
    :successes (make-list 125 :initial-element -100.0)
    :failures 0
    :efforts 100.0
    :effort 0.8
    :eventual-successes (make-list 25 :initial-element -100.0)
    :eventual-failures (make-list 100 :initial-element -100.0)
    :eventual-efforts 2.5))

(p GIVEUP-LEFT
  =goal>
   isa goal
   to  get-food
   just hungry
   food no
   switch nil
   my-loc left
==>
  =goal>
   switch yes
;  just switched
   my-loc right
 !output! ("Switching to Right")
 !eval! (update-schedule-peck 'right 'switch2))

(p GIVEUP-RIGHT
  =goal>
   isa goal
   to  get-food
   just hungry
   food no
   switch nil
   my-loc right
==>
  =goal>
   switch yes
;  just switched
   my-loc left
 !output! ("Switching to Left")
 !eval! (update-schedule-peck 'left 'switch2))

(spp-fct (list '(peck-left peck-right)
    :creation-time -100.0
    :successes (make-list 250 :initial-element -100.0)
    :failures 0
    :efforts 12.5
    :effort 0.05
    :eventual-successes (make-list 50 :initial-element -100.0)
    :eventual-failures (make-list 200 :initial-element -100.0)
    :eventual-efforts 45.0))

(spp-fct (list '(giveup-left giveup-right)
    :creation-time -100.0
    :successes (make-list 250 :initial-element -100.0)
    :failures 0
    :efforts 87.5
    :effort 0.35
    :eventual-successes (make-list 50 :initial-element -100.0)
    :eventual-failures (make-list 200 :initial-element -100.0)
    :eventual-efforts 45.0))

(p EAT-FOOD
  =goal>
   isa goal
   to get-food
   just pecked
   food yes
   my-loc =side
==>
 =goal>
   new-loc =side
  !output! ("Eating food")
  !eval! (eat-food-peck =side)
  !pop!)

(spp EAT-FOOD
:creation-time -1000
:successes (-1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000)
:failures 0
:efforts 1.0
:eventual-successes (-1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000 -1000)
:eventual-failures 0
:eventual-efforts 1.0
:success T)

(p EAT-NO-FOOD
  =goal>
   isa goal
   to get-food
   just pecked
 - food yes
   my-loc =side
==>
  =goal>
   new-loc =side
   !output! ("No food")
   !pop!)

(spp-fct (list 'EAT-NO-FOOD
    :creation-time -1000.0
    :successes (make-list 1000 :initial-element -1000.0)
    :failures 0
    :efforts 50.0
    :effort 0.05
    :eventual-successes (make-list 1000 :initial-element -1000.0)
    :eventual-failures 0
    :eventual-efforts 50.0
    :failure T))