;;; ------------------------------------------------------------------------
;;
;; -*- actr -*-
;;
;; ACT-R Model for balance scale learning
;;
;; Hedderik van Rijn, 020117
;;
;; Uses the production rule learning mechanisms as present in ACT-R 5.0.
;; However, these mechanisms are buggy (or, better, not doing what I
;; expected). If two production rules are composed, explicit tests on the
;; equalness of two slots are not compiled into the new rules. A hack
;; specific for this model is present in the file pc.lisp. This code
;; explicitly tests for equality or inequality tests in the slot1, slot2,
;; slot3 and slot4 slots. 
;;
;;; ------------------------------------------------------------------------

;; ACT-R 5.0
(load "actr")
;; Hack to solve problems with production compilation
(load "pc")
;; Code to write expected gain (parameters) to file
(load "wpp")

;;; ------------------------------------------------------------------------

(defun select-random (src) (nth (random (length src)) src))

;; Lisp code to (among other functionality) present problems to the model.
(load "lisp.lisp")

;;; ------------------------------------------------------------------------

(clear-all)

(sgp 
     :esc t
     :cp 0				     ; (*)
     :egs 0.2
     :pl t
     :epl t
)

;; *) According to the manual/tutorials, the Cost Penalty is used to make
;; sure that the new rule is not directly used. Only because of the noise in
;; the system, the new rule will be used and because it might be better, it
;; will replace the old rules. Although I can imagine that a new rule might
;; not directly be used, I do not understand completely why this should be
;; accounted for in the effect with the cost penalty, and not, for example,
;; by making the compilations stochastic. However, for the current model,
;; because we want to demonstrate that this mechanism works, it is
;; sufficient to show that the new rules can take over, no matter what the
;; mechanism is. Therefore, we've made the new rules equally good, by
;; setting the penalty to 0.
;;

(chunk-type gen-goal type slot1 slot2 slot3 slot4 active-dim answer action operand prev-step retrieve)
(chunk-type dec-step goal prev action operand constraint step)
(chunk-type equalness value1 value2 answer)

(add-dm

 (balance-goal ISA chunk)
 (feature ISA chunk)
 (combination-of-features ISA chunk)
 (feature-value ISA chunk)

 ; Actions to apply to incoming information
 (comparison ISA chunk)
 ; Answers to actions 
 (equal ISA gen-goal type equal)
 (unequal ISA gen-goal type unequal)
 
 ; Number of pegs/distance
 (one ISA chunk)
 (two ISA chunk)
 (three ISA chunk)
 (four ISA chunk)
 (five ISA chunk)

 ; Answer representations
 (left ISA chunk)
 (right ISA chunk)
 (none ISA chunk)
)

; Declarative representations used to learn Rule 1 and 2
(add-dm

 (init 
  isa dec-step)

 (retrieve-feature
  isa dec-step
  goal balance-goal
  action retrieve
  operand feature
  prev init)

 (perceive-values
  isa dec-step
  goal balance-goal
  action perceive
  operand feature-value
  prev retrieve-feature)

 (are-the-values-equal
  isa dec-step
  goal balance-goal
  action test
  operand equal
  prev perceive-values)

 (constraint-on-equalness
  isa dec-step
  goal balance-goal
  constraint t
  prev are-the-values-equal)

 (search-for-different-feature
  isa dec-step
  goal balance-goal
  action retrieve
  operand feature
  constraint equal
  step retrieve-feature
  prev constraint-on-equalness)

 (found-unequal-values-so-answer
  isa dec-step
  goal balance-goal
  action answer
  operand t
  constraint unequal
  prev constraint-on-equalness)

 (answer-balance
  isa dec-step
  goal balance-goal
  action answer
  operand t ; has to be non-nil
  prev nil)

)

;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;; 
;; Generic PRules, interpreting declarative actions
;;
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------


(p State-Initiate-Retrieval
  =goal>	
    isa           gen-goal
    type          =goal-type
    action        nil
    operand       nil
    prev-step     =prev-step
  - retrieve      failure
 ==>
  =goal>
    prev-step     nil
  +retrieval>
    isa           dec-step
    goal          =goal-type
    prev          =prev-step)

(p State-Change-Goal
  =goal>
    isa           gen-goal
    type          =goal-type
    action        nil
    operand       nil
    prev-step     nil
  =retrieval>
    isa           dec-step
    goal          =goal-type
    action        =action
    operand       =operand
    constraint    nil
 ==>
  =goal>
    action        =action
    operand       =operand
    prev-step     =retrieval)

(p State-Change-Initiate-Retrieval-For-Constraint
  =goal>
    isa           gen-goal
    type          =goal-type
    retrieve      =constraint
    prev-step     nil
  - retrieve     failure
  =retrieval>
    isa           dec-step
    goal          =goal-type
;    action        =action
;    operand       =operand
    constraint    t
 ==>
  +retrieval>
    isa           dec-step
    goal          =goal-type
    constraint    =constraint
    prev          =retrieval)

(p State-Change-Constraint-Goal
  =goal>
    isa           gen-goal
    type          =goal-type
    retrieve      =constraint
    action        nil
    operand       nil
    prev-step     nil
  =retrieval>
    isa           dec-step
    goal          =goal-type
    action        =action
    operand       =operand
    constraint    =constraint
    step          nil			     ; Without "Looping back"
 ==>
  =goal>
    action        =action
    operand       =operand
    prev-step     =prev-step)

(p State-Change-Constraint-Goal-Loop
  =goal>
    isa           gen-goal
    type          =goal-type
    action        nil
    operand       nil
    retrieve      =constraint
    prev-step     nil
  =retrieval>
    isa           dec-step
    goal          =goal-type
    action        =action
    operand       =operand
    constraint    =constraint
    step          =prev-step		     ; "Looping back"
 ==>
  =goal>
    action        =action
    operand       =operand
    prev-step     =prev-step)

;; NOTE: if no dec-step with prev nil is available, the model will dead-lock.

;; Failure to retrieve a declarative representation

(p State-Initiate-Retrieval-After-Failure-1
  =goal>
    isa           gen-goal
    type          =goal-type
    prev-step     nil
  =retrieval>
    isa           error
 ==>
  +retrieval>
    isa           dec-step
    goal          =goal-type
    prev          nil)
    
;; Failure to retrieve something else, hack: task-specific coded, can and
;; should be incorportated in declarative representations. However, not
;; essential to the model and a lot of work... :-)

(p State-Initiate-Retrieval-After-Failure-2
  =goal>
    isa           gen-goal
    type          =goal-type
    retrieve      failure
 ==>
  =goal>
    action        Answer
    retrieve      nil)

;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------
;;
;; General purpose rules
;;
;;; ------------------------------------------------------------------------
;;; ------------------------------------------------------------------------

;;; -[Retrieve]-------------------------------------------------------------

(p Action-Retrieval-Intiate-1
  =goal>
    isa           gen-goal
    type          =goal-type
    action        Retrieve
    operand       =operand
    active-dim    nil
 ==>
  +retrieval>
    isa           gen-goal
    type          =operand
    prev-step     nil
  =goal>
    operand       nil)

(p Action-Retrieval-Intiate-2
  =goal>
    isa           gen-goal
    type          =goal-type
    action        Retrieve
    operand       =operand
    active-dim    =dim
 ==>
  +retrieval>
    isa           gen-goal
    type          =operand
    prev-step     =dim
  =goal>
    operand       nil)

(p Action-Retrieval-Succeeded-1
  =goal>
    isa           gen-goal
    type          =goal-type
    action        Retrieve
    operand       nil
    slot1         nil
    slot2         nil
  =retrieval>
    isa           gen-goal
 ==>
  =goal>
    action        nil
    retrieve      =retrieval
    active-dim    =retrieval)

(p Action-Retrieval-Succeeded-2
  =goal>
    isa           gen-goal
    type          =goal-type
    action        Retrieve
    operand       nil
    slot1         =slot1
    slot2         =slot2
  =retrieval>
    isa           gen-goal
 ==>
  =goal>
    action        nil
    slot1         nil
    slot2         nil
    slot3         =slot1
    slot4         =slot2
    retrieve      =retrieval
    active-dim    =retrieval)

(p Action-Retrieval-Failed
  =goal>
    isa           gen-goal
    type          =goal-type
    action        Retrieve
    operand       nil
  =retrieval>
    isa           error
 ==>
  =goal>
    action        nil
    retrieve      failure)

;;; -[Perceive]-------------------------------------------------------------

(defun do-perception-action () t)

(p Action-Perceive-Initiate
  =goal>
    ISA           gen-goal
    type          =goal-type
    action        Perceive
    operand       =class
    retrieve      =subclass
;    slot1         nil
;    slot2         nil
 ==>
  +retrieval>
    isa           gen-goal
    type          =class
    operand       =subclass
  !eval!          (do-perception-action)     ; Prevent compilation. (*)
  =goal>
;    slot3         =class
    active-dim         =subclass
    operand       nil
    retrieve      nil)

(p Action-Perceive-Retrieval
  =goal>
    ISA           gen-goal
    type          =goal-type
    action        Perceive
    operand       nil
    retrieve      nil
  =retrieval>
    isa           gen-goal
    slot1         =slot1
    slot2         =slot2
 ==>
  =goal>
    slot1         =slot1
    slot2         =slot2
    action        nil)

(p Action-Perceive-Failure
  =goal>
    ISA           gen-goal
    type          =goal-type
    action        Perceive
    operand       nil
    retrieve      nil
  =retrieval>
    isa           error
 ==>
  =goal>
    slot1         nil
    slot2         nil
    action        nil)


;; (*) In a fullblown version of this model, the expected gain of the new
;; rule in which this "perception" is removed because of specialization will
;; decrease sharply. However, this requires an even larger number of trials,
;; or more explict task-external reasoning. Because of the relative
;; fine-grainedness of this model, we've included an !eval! which boils down
;; to the same thing: This rule won't be specialized.

;;; -[Equality Tests]---------------------------------------------------

;; With these production rules, I assume that there are different "equality
;; test" production rules for different properties. For example, for easily
;; quantifiable entries like weights the test can be on exact numbers, but
;; for "levels of shading" as used in Brenda's experiment this might be a
;; different procedure.

(p Action-Test-Equal-for-Weights
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1
    slot2         =slot1
    slot3         nil
    slot4         nil
    active-dim    weight
    retrieve      nil
 ==>
  =goal>
    action        nil
    operand       nil
    retrieve      equal)

(p Action-Test-Unequal-for-Weights
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1
  - slot2         =slot1
    slot2         =slot2
    slot3         nil
    slot4         nil
    active-dim    weight
    retrieve      nil
 ==>
  =goal>
    action        nil
    operand       nil
    retrieve      unequal)

(p Action-Test-Equal-for-Distances-given-Equal-Weight
    "If both weights and distances are equal, simply answer balance"
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1
    slot2         =slot1
    slot3         =slot3
    slot4         =slot3
    active-dim    distance
    retrieve      nil
 ==>
  =goal>
    slot3         nil
    slot4         nil
    action        nil
    operand       nil
    retrieve      equal
)

(p Action-Test-Equal-for-Distances-given-Unequal-Weight
    "When distances are equal, but the weights aren't, base answer on the unequal weights"
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1
    slot2         =slot1
    slot3         =slot3
  - slot4         =slot3
    slot4         =slot4
    active-dim    distance
    retrieve      nil
 ==>
  =goal>
    action        nil
    operand       nil
    slot1         =slot3
    slot2         =slot4
    slot3         nil
    slot4         nil
    retrieve      unequal
)

(p Action-Test-Unequal-for-Distances-given-Equal-Weights
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1
  - slot2         =slot1
    slot3         =slot3
    slot4         =slot3
    active-dim    distance
    retrieve      nil
 ==>
  =goal>
    action        nil
    operand       nil
    slot3         nil
    slot4         nil
    retrieve      unequal)

(p Action-Test-Unequal-for-Distances-given-Unequal-Weights
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1
  - slot2         =slot1
    slot3         =slot3
  - slot4         =slot3
    active-dim    distance
    retrieve      nil
 ==>
  =goal>
    action        nil
    operand       nil
    slot1         nil
    slot2         nil
    slot3         nil
    slot4         nil
    retrieve      complex) ; <---
 

(p Action-Test-Equality-for-Addition-Unequal
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1		     ; Addition
  - slot2         =slot1
    active-dim    addition
    retrieve      nil
 ==>
  =goal>
    action        nil
    operand       nil
    slot3         nil
    slot4         nil
    retrieve      unequal
)

(p Action-Test-Equality-for-Addition-Equal
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1		     ; Addition
    slot2         =slot1
    active-dim    addition
    retrieve      nil
 ==>
  =goal>
    slot3         nil
    slot4         nil
    action        nil
    operand       nil
    retrieve      equal
)

(p Action-Test-Equality-for-Multiplication-Unequal
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1		     
  - slot2         =slot1
    active-dim    multiplication
    retrieve      nil
 ==>
  =goal>
    slot3         nil
    slot4         nil
    action        nil
    operand       nil
    retrieve      unequal
)

(p Action-Test-Equality-for-Multiplication-Equal
  =goal>
    isa           gen-goal
    action        Test
    operand       Equal
    slot1         =slot1		     
    slot2         =slot1
    active-dim    multiplication
    retrieve      nil
 ==>
  =goal>
    slot3         nil
    slot4         nil
    action        nil
    operand       nil
    retrieve      equal
)

;;; ------------------------------------------------------------------------

(p Action-Answer-Balance-Say-Balance
  =goal>
    isa           gen-goal
    action        Answer
    answer        nil
    slot1         =slot1
    slot2         =slot1
    slot3         nil
    slot4         nil
 ==>
  !output!        ("Retrieved values are equal, so I'll say: balance")
  =goal>
    answer        none)


(p Action-Answer-Balance-Say-Left
  =goal>
    isa           gen-goal
    action        Answer
    answer        nil
    slot1         =slot1
  < slot2         =slot1
    slot3         nil
    slot4         nil
 ==>
  !output!        ("Left larger than right, so I'll say: left")
  =goal>
    answer        left)

(p Action-Answer-Balance-Say-Right
  =goal>
    isa           gen-goal
    action        Answer
    answer        nil
    slot1         =slot1
  > slot2         =slot1
    slot3         nil
    slot4         nil
 ==>
  !output!        ("Right larger than left, so I'll say: right")
  =goal>
    answer        right)

(p Action-Answer-Guess
  =goal>
    isa           gen-goal
    action        Answer
    answer        nil
    slot1         nil
    slot2         nil
 ==>
  !output!        ("No values to compare, so I'll guess")
  =goal>
    answer        (!eval! (select-random '(left right none)))
)

(spp Action-Answer-Guess :effort 0.25)

;; -------------------------------------------------------------------------

(p Successful
  =goal>
    isa           gen-goal
    Action        Answer
    answer        =answer
  !eval!          (eq =answer **answer**)
 ==>
  !output!        ("Answer ~S is correct!" =answer)
;  +goal>
;    isa           error
  !eval!          (setf **success** t)
  !stop!
)

(spp Successful :success t)

(p Failure
  =goal>
    isa           gen-goal
    Action        Answer
    answer        =answer
  !eval!          (not (eq =answer **answer**))
 ==>
  !output!        ("Answer ~S is INcorrect!" =answer)
  !stop!
)

(spp Failure :failure t)
    
;;; ------------------------------------------------------------------------

(setq reset1 (return-matching-prules '("STATE-")))
(setq reset2 (return-matching-prules '("ACTION-RETRIEVAL-")))
(setq reset3 '(Failure))

;;; ------------------------------------------------------------------------

;; Note, it probably won't work if a later phase is activated when not all
;; the previous states are activated too.
(setf dophase0 t)
(setf dophase1 t)
(setf dophase2 t)
(setf dophase3 nil)
(setf dophase4 nil)

; --------------------------------------------------------------------------

(present-type 'wd)

(cond (dophase0
       (format t "~%~%Phase 0~%~%")
       (sgp :epl t :pl t :egs 0.25)
       (do-it 250 t 'delete)
       (do-wdb)))

; --------------------------------------------------------------------------

(cond (dophase1
       (format t "~%~%Phase 1~%~%")
       (add-dm 
	(weight ISA gen-goal type feature operand weight prev-step nil))
       (sgp :epl t :pl t :egs 0.25)
       (do-it 500 t t)
       (do-wdb)))
       
; --------------------------------------------------------------------------

(cond (dophase2
       (format t "~%~%Phase 2~%~%")
       (add-dm (distance ISA gen-goal type feature operand distance prev-step weight))
       (sgp :epl t :pl t :egs 0.25)
       (do-it 500 t t)
       (do-wdb)))

; --------------------------------------------------------------------------

(defun phase3 ()
  (add-dm 
   ;; New knowledge for Phase 3 & 4 
   (found-unequal-values-nevertheless-search-for-new-feature
    isa dec-step
    goal balance-goal
    action retrieve
    operand feature
    constraint unequal
    step retrieve-feature
    prev constraint-on-equalness)

   (found-unequal-for-both-so-combine
    isa dec-step
    goal balance-goal
    action retrieve
    operand combination-of-features
    constraint complex
    step retrieve-feature
    prev constraint-on-equalness))

  (delete-chunk found-unequal-values-so-answer))

(cond (dophase3
       (format t "~%~%Phase 3~%~%")
       (Phase3)
       (sgp :epl t :pl t :egs 0.25)
       (do-it 125 t t)
       (do-wdb)

       (format t "**~%~
** Probably, the model won't use the \"guess\" rule as the expected gain~%~
** of the rule that switches attention to the distance cue if the weights are~%~
** unequal is not really high. However, the model has constructed the ~%~
** necessary rules. See discussion in paper.~%~
**~%~
** To see the guess rule in action, run:~%~
** (let ((**present-func** 'present-cd-stimulus))~%~
**   (do-it 1 t nil t))~%~
** until the expected gain tries the guess-rule.~%~
**~%")))

; (let ((**present-func** 'present-cd-stimulus))
;    (do-it 10 t nil t))
; (do-wdb)


; --------------------------------------------------------------------------

(defun phase4 ()
  (add-dm 
   (multiplication ISA gen-goal 
		   type combination-of-features 
		   operand multiplication 
		   prev-step distance)))

(cond
 (dophase4
  (format t "~%~%Phase 4~%~%")
  (phase4)
  (sgp :epl t :pl t :egs 0.25)
  (do-it 1000 t t)
  (do-wdb)))

; --------------------------------------------------------------------------