;;; Past tense learning in ACT-R
;;; Niels Taatgen and John Anderson
;;; 20/4/2000
;;; Before loading this model, load "proceduralization.lisp"
;;; Works with ACT-R 4.0.2
;;; 
;;; Using the model:
;;; the function "do-it" runs the model
;;; the function "report-all" generates the reports
;;; To run the no-feedback model enter:
;;; (do-it 120000 :generate t)
;;; To run the indirect-feedback model enter:
;;; (do-it 60000 :init-words 2000)
;;; Warning: the model is really slow: takes about 8 hours on a 300Mhz G3
;;; (report-all) or (report-all :generate t) will generate a report of the results. 
;;; You can also use this function after interrupting the model, e.g. after 
;;; running it for only 10000 words. 
;;; See the comments with the do-it function for more options
;;;

(clearall)

(sgp
:V t
:CT T
:ERA T
:ER T
:crt t
:PL t    ; parameters learning
:OL t    ; optimized learning
:BLL 0.4  ; base-level learning ; was 0.3
:sl nil  ; strength learning
:AL nil ; associative learning was 0.1
:ANs 1.6   ; activation noise was 2.0
:pas nil  ; permanent activation noise
:EGs 0.085   ; expected gain noise ; was 0.5 ; lower because of decay
:DAT 0.05 ; default action time
:GA 0.5  ; goal activation ; lower because IAs get uncredibly high in this model
:ut -100.0 ; utility threshold: no escape from this experiment!
:G 5
:LF 0.5 ; latency factor was 1
:LE 0.25
:BLC 0
:MP 1.5
:RT 0.3  ; retrieval threshold was -0.2
)

(setf 
 *proc-odds* 100
 *proc-threshold* -10.0
 *initial-experience* 150  ; was 200
 *cost-penalty* 1.0
 *experience-threshold* 125
 *noise-factor* 0.4
 *specialize* 'restricted
 *initial-decay-noise* nil
 )

(defvar **record**)
(setf **record** nil)

(defvar *trial*)

(chunk-type word type of stem suffix retrieve)
(chunk-type word-frag of)

(add-dm
 (ed isa chunk)
 (blank isa chunk)
)

(set-all-base-levels 10000 -10000)

(defvar *word-list*)
(setf *word-list* nil)
(defvar *answer-list*)
(defvar *answer*)
(defvar *report*)
(defvar *voc-size*)
(defvar *number*)
(defvar *word*)
(defvar *decay-rate*)
(setf *decay-rate* 0.4) ; decay rate for noise reduction was 0.5
(defvar repcount)
(defvar *act-threshold*)
(setf *act-threshold* -3.5) ; was -3.0

; sum is 115544

;;; decreasing noise for base-level activation
;;;

(defun act-noise (n wme)
  (noise
   (if
     *base-level-learning*
     (* n (expt (+ 1 
                (car (wme-references wme)))
                (- *decay-rate*)))
     n)))

(defun activation (wme)
  "Returns the activation of wme.  May involve recomputing the spreading activation,
   the base level and adding some noise."
  (declare (inline compute-spreading-activation compute-base-level-activation noise))
  (when (and *enable-rational-analysis*
             (< (wme-spread-stamp wme) *spread-stamp*))
    (compute-spreading-activation wme))
  (when (and (or *base-level-learning* *activation-noise*)
             (< (wme-time-stamp wme) *time*))
    (when *base-level-learning*
      (compute-base-level-activation wme))
    (setf (wme-activation wme) (+ (wme-permanent-noise wme)
                                  (wme-base-level wme)
                                  (wme-source-spread wme)))
    (when *activation-noise*
      (let ((noise (act-noise *activation-noise* wme)))
        (signal-output *activation-trace* "   Adding noise ~6,3F" noise)
        (incf (wme-activation wme) noise)))
    (setf (wme-time-stamp wme) *time*))
  (wme-activation wme))

;;; The vocabulary

(defun make-triples (l)
  (when l
  (cons (list (first l)(second l)(third l)
              (if (eq (second l) 'I) (gentemp (symbol-name (first l))) (first l))
              (if (eq (second l) 'I) 'blank 'ed)) 
        (make-triples (nthcdr 3 l)))))

(setf *word-list* (make-triples '(
be        I              39175
have      I              12458
do        I               4367
say       I               2765
make      I               2312
go        I               1844
take      I               1575
come      I               1561
see       I               1513
get       I               1486
know      I               1473
give      I               1264
find      I               1033
use       R               1016
think     I                982
look      R                910
seem      R                831
tell      I                759
leave     I                650
feel      I                643
show      R                640
want      R                631
call      R                627
ask       R                612
turn      R                566
write     I                561
follow    R                540
keep      I                523
put       I                513
hold      I                509
work      R                496
bring     I                488
let       I                482
live      R                472
try       R                472
stand     I                468
move      R                447
hear      I                433
run       I                431
need      R                413
start     R                386
mean      I                376
help      R                352
believe   R                336
play      R                333
pay       R                325
reach     R                324
sit       I                314
carry     R                304
grow      I                300
serve     R                300
pass      R                298
like      R                294
add       R                291
walk      R                287
happen    R                278
talk      R                275
lose      I                274
read      I                274
wait      R                263
open      R                259
learn     R                254
send      I                253
remember  R                250
build     I                249
cut       I                245
stop      R                240
fall      I                239
place     R                233
break     I                228
change    R                225
lie       I                224
draw      I                222
allow     R                209
watch     R                209
cover     R                202
rise      I                199
stay      R                195
spend     I                194
raise     R                188
fill      R                184
die       R                183
choose    I                177
close     R                174
wear      I                174
hope      R                164
prepare   R                163
recognize R                163
study     R                163
buy       I                162
wish      R                161
act       R                159
drop      R                159
win       I                159
fight     I                155
kill      R                153
teach     I                153
throw     I                150
catch     I                146
love      R                145
pull      R                145
pick      R                143
point     R                143
end       R                140
answer    R                133
feed      I                132
hang      I                131
marry     R                130
visit     R                129
measure   R                128
hit       I                126
ride      I                126
listen    R                123
eat       I                122
smile     R                122
save      R                121
finish    R                120
sing      I                120
forget    I                119
wonder    R                119
shoot     I                117
fix       R                109
name      R                109
care      R                108
strike    I                108
shake     I                107
share     R                105
burn      R                103
push      R                102
sleep     I                 97
miss      R                 95
paint     R                 95
stare     R                 95
drink     I                 93
fly       I                 92
touch     R                 91
laugh     R                 89
worry     R                 89
belong    R                 88
check     R                 88
roll      R                 88
file      R                 87
cross     R                 84
wash      R                 83
press     R                 82
sound     R                 82
handle    R                 81
organize  R                 80
guess     R                 77
match     R                 77
rest      R                 77
shout     R                 77
swing     I                 77
surprise  R                 76
dry       R                 72
light     I                 72
step      R                 71
own       R                 70
lift      R                 69
manage    R                 68
promise   R                 68
dress     R                 67
beat      I                 66
hate      R                 66
climb     R                 65
count     R                 65
cry       R                 64
lock      R                 63
hide      I                 61
lean      R                 61
park      R                 61
stretch   R                 61
cool      R                 59
dance     R                 59
clean     R                 58
jump      R                 58
tear      I                 58
back      R                 57
meet      I                 57
remind    R                 57
mix       R                 56
swim      I                 55
disappear R                 54
sweep     I                 54
freeze    I                 53
print     R                 53
blow      I                 52
hand      R                 52
frighten  R                 51
guide     R                 51
bend      I                 50
cook      R                 50
exercise  R                 50
shut      I                 50
stick     I                 50
tie       R                 50
invite    R                 49
last      R                 48
pour      R                 48
knock     R                 47
slip      R                 47
bother    R                 45
dare      R                 45
hurry     R                 45
thank     R                 45
wake      I                 45
attach    R                 44
color     R                 44
hunt      R                 44
pack      R                 44
slide     I                 43
smell     R                 43
aim       R                 42
trust     R                 42
crack     R                 41
mind      R                 41
drag      R                 40
practice  R                 40
scream    R                 40
ring      I                 39
steal     I                 39
stir      R                 39
brush     R                 38
disturb   R                 38
heat      R                 38
land      R                 38
snap      R                 38
crawl     R                 37
grab      R                 37
march     R                 37
matter    R                 35
score     R                 35
wipe      R                 35
kick      R                 34
rub       R                 34
twist     R                 34
sail      R                 33
straighten R                 33
weigh     R                 33
balance   R                 32
dig       I                 32
melt      R                 32
borrow    R                 31
breathe   R                 31
hurt      I                 31
kiss      R                 31
spin      I                 31
whisper   R                 31
yell      R                 31
drill     R                 30
fish      R                 30
load      R                 30
pray      R                 30
race      R                 30
squeeze   R                 30
wave      R                 30
lend      I                 29
wind      I                 29
bounce    R                 28
flash     R                 28
sigh      R                 28
switch    R                 28
boil      R                 27
pretend   R                 27
bite      I                 26
bless     R                 26
grind     I                 26
scare     R                 26
shop      R                 26
smoke     R                 26
mail      R                 25
bury      R                 24
carve     R                 23
crash     R                 23
float     R                 23
shave     R                 23
wrap      R                 23
choke     R                 22
ruin      R                 22
scratch   R                 22
taste     R                 22
spit      I                 21
camp      R                 20
fold      R                 20
glue      R                 20
polish    R                 20
rock      R                 20
swallow   R                 20
fasten    R                 19
obey      R                 19
bleed     I                 18
plant     R                 18
sew       R                 18
shrug     R                 18
smash     R                 18
soak      R                 18
suck      R                 18
wink      R                 18
crush     R                 17
curl      R                 17
pop       R                 17
repair    R                 17
skip      R                 17
slap      R                 17
whirl     R                 17
chew      R                 16
murder    R                 16
shove     R                 16
stamp     R                 16
steer     R                 16
trim      R                 16
bake      R                 15
screw     R                 15
smooth    R                 15
dash      R                 14
drip      R                 14
drown     R                 14
dump      R                 14
lick      R                 14
peel      R                 14
punish    R                 14
rain      R                 14
rip       R                 14
spell     R                 14
spray     R                 14
blink     R                 13
bow       R                 13
fan       R                 13
poke      R                 13
rustle    R                 13
sway      R                 13
wreck     R                 13
decorate  R                 12
empty     R                 12
pat       R                 12
pump      R                 12
shrink    I                 12
snow      R                 12
tighten   R                 12
type      R                 12
whistle   R                 12
ache      R                 11
excuse    R                 11
hug       R                 11
mock      R                 11
pinch     R                 11
steam     R                 11
bang      R                 10
fool      R                 10
hop       R                 10
joke      R                 10
sip       R                 10
sniff     R                 10
spoil     R                 10
starve    R                 10
trap      R                 10
blast     R                  9
bump      R                  9
chop      R                  9
clap      R                  9
dust      R                  9
hook      R                  9
spill     R                  9
thread    R                  9
tuck      R                  9
wet       R                  9
cough     R                  8
dodge     R                  8
flip      R                  8
fry       R                  8
iron      R                  8
itch      R                  8
kid       R                  8
paste     R                  8
tease     R                  8
blind     R                  7
bomb      R                  7
chase     R                  7
cheat     R                  7
fetch     R                  7
hatch     R                  7
pin       R                  7
sharpen   R                  7
smack     R                  7
splash    R                  7
string    I                  7
tip       R                  7
bubble    R                  6
copy      R                  6
dip       R                  6
holler    R                  6
pardon    R                  6
plug      R                  6
rake      R                  6
rinse     R                  6
tangle    R                  6
trip      R                  6
wobble    R                  6
bob       R                  5
bust      R                  5
comb      R                  5
erase     R                  5
growl     R                  5
howl      R                  5
leak      R                  5
mess      R                  5
perch     R                  5
row       R                  5
scoop     R                  5
scoot     R                  5
ski       R                  5
tick      R                  5
wiggle    R                  5
box       R                  4
dial      R                  4
hammer    R                  4
mash      R                  4
salute    R                  4
snuggle   R                  4
wag       R                  4
claw      R                  3
clip      R                  3
peek      R                  3
punch     R                  3
skate     R                  3
sneeze    R                  3
squeal    R                  3
unscrew   R                  3
untie     R                  3
yawn      R                  3
zoom      R                  3
criss-cross R                  2
hush      R                  2
juggle    R                  2
nap       R                  2
peep      R                  2
shovel    R                  2
squash    R                  2
squeak    R                  2
squirt    R                  2
stab      R                  2
tickle    R                  2
trick     R                  2
zip       R                  2
bark      R                  1
chirp     R                  1
dribble   R                  1
faint     R                  1
pee       R                  1
pout      R                  1
rope      R                  1
scribble  R                  1
smart     R                  1
tape      R                  1
bash      R                1
bop       R                1
bowl      R                1
burp      R                1
chain     R                1
dirty     R                1
drool     R                1
fizz      R                1
jabber    R                1
meow      R                1
pee-pee   R                1
reattach  R                1
sharp     R                1
spank     R                1
squoosh   R                1
staple    R                1
swish     R                1
unbuckle  R                1
unbutton  R                1
unchain   R                1
unplug    R                1
untangle  R                1
urinate   R                1
wee-wee   R                1
)))

;;; This function tries to give new productions a proper name
;;; Ties in with production rule learning

(setf *production-name-scheme*
      #'(lambda (p1 p2 inst)
          (cond 
           ((eq p1 'find-past-retrieve)
            "Retrieve-irreg")
           ((and (eq p1 'analogy-fill-slot)
                 (not (eq (wme-name (get-slot-value (get-wme inst) 'suffix)) 'blank)))
            "Regular-rule")
           ((and (eq p1 'analogy-fill-slot)
                 (eq (wme-name (get-slot-value (get-wme inst) 'suffix)) 'blank))
            "Blank-rule")
           (t "PRODUCTION"))))

;;; The following function keeps track of the PG-C's during the experiment

(defun add-record (t1)
  "Adds current PG-C's to **record** and update vocabulary-size"
  (let ((tot-reg 0)(tot-irreg 0))
    (dolist (word-rec *word-list*)
      (let* 
        ((word (first word-rec))
         (reg (second word-rec))
         (highest-activation
          (let ((result -100))
            (dolist (wme (no-output (eval `(sdm of ,word))) result)
              (let ((activation (caar (no-output (eval `(sdp ,wme :base-level))))))
                (when (> activation result) (setf result activation)))))))
        (when (> highest-activation *act-threshold*)
          (if (eq reg 'I) (incf tot-irreg)(incf tot-reg)))))
    (push (list tot-irreg tot-reg) *voc-size*))
  (dolist (r *procedural-memory*)
    (let*
      ((rule (rest r))
       (rule-name (first r))
       (evaluation (production-pg-c rule))
       (record (assoc rule-name **record**)))
      (if
      record
      (setf **record** 
            (replace-list (append record (list (list t1 evaluation))) **record**))
      (push (list rule-name (list t1 evaluation)) **record**)))))
       
(defun replace-list (item l)
  (cond
   ((null l) 'error)
   ((eq (car item)(caar l)) (cons item (rest l)))
   (t (cons (first l) (replace-list item (rest l))))))

;;; Select a random word from the vocabulary

(defun random-word ()
 (let
   ((num (random 115544)))
   (dolist (i *word-list*)
     (if (< num (third i))
       (return i)
       (setf num (- num (third i)))))))

;;; Set the goal to do one past tense

(defun make-one-goal ()
  (let*
    ((wordpair (random-word))
     (word (first wordpair))
     (word-no (second wordpair))
     (goal (gentemp "GOAL")))
    (setf *number* word-no *word* word)
    (eval `(add-dm (,goal isa word of ,word)))
    (eval `(goal-focus ,goal))
    ))

;;; This function simulates "hearing" a past tense

(defun add-past-tense-to-memory ()
  (let*
    ((wordpair (random-word))
     (word (first wordpair))
     (stem (fourth wordpair))
     (suffix (fifth wordpair))
     (word-chunk (gentemp "W")))
    (eval `(add-dm (,word-chunk isa word of ,word stem ,stem suffix ,suffix)))
    (eval `(goal-focus ,word-chunk))
    (pop-goal)))

;;; Report functions

;;; This function shows proportion of irregular, regular and no suffix results for individual words

(defun report (&key (n nil) (last nil))
  (format t "~%Word       Type      Irreg    Reg   None~%")
  (dolist (i (if n (subseq *word-list* 0 n) *word-list*))
    (let ((irreg 0)
          (reg 0)
          (none 0))
      (dolist (x (if last (subseq *report* 0 last) *report*))
        (when (eq (third x) (first i))
          (cond ((eq (second x) 'reg)
                 (setf reg (1+ reg)))
                ((eq (second x) 'irreg)
                 (setf irreg (1+ irreg)))
                (t (setf none (1+ none))))))
      (format t "~11S ~6S ~6D ~6D ~6D~%" (first i) (second i)irreg reg none))))

;;; the following function reports how often an irregular word gets a irregular (correct), regular past tense
;;; or just the stem as past tense (None). It shows how this developes in time.
  
(defun report-irreg (&optional (n 500))
  (format t "~% Irreg    Reg   None   Overreg~%")
  (rep-f-i (reverse *report*) n))


(defun rep-f-i (l n)
  (when l
    (let ((x (if (> (length l) n) (subseq l 0 (1- n)) l))
          (y (if (> (length l) n) (subseq l n) nil))
          (irreg 0)
          (reg 0)
          (none 0))
      (dolist (i x)
        (cond ((eq (first i) 'R) nil)
              ((eq (second i) 'reg) (setf reg (1+ reg)))
              ((eq (second i) 'irreg) (setf irreg (1+ irreg)))
              (t (setf none (1+ none)))))
      (if (> (+ irreg reg none) 0)
        (format t "~6,3F ~6,3F ~6,3F ~6,3F~%" (/ irreg (+ irreg reg none))
                (/ reg (+ irreg reg none))(/ none (+ irreg reg none))
                (if (> (+ irreg reg) 0) (/ irreg (+ irreg reg)) 0))
        (format t "~6,3F ~6,3F ~6,3F ~6,3F~%" 0 0 0 0)
        )
    (rep-f-i y n))))

;;; Same function for regular past tenses

(defun report-reg (&optional (n 500))
  (format t "~% Irreg    Reg   None~%")
  (rep-f-r (reverse *report*) n))


(defun rep-f-r (l n)
  (when l
    (let ((x (if (> (length l) n) (subseq l 0 (1- n)) l))
          (y (if (> (length l) n) (subseq l n) nil))
          (irreg 0)
          (reg 0)
          (none 0))
      (dolist (i x)
        (cond ((eq (first i) 'I) nil)
              ((eq (second i) 'reg) (setf reg (1+ reg)))
              ((eq (second i) 'irreg) (setf irreg (1+ irreg)))
              (t (setf none (1+ none)))))
      (if (> (+ irreg reg none) 0)
        (format t "~6,3F ~6,3F ~6,3F~%" (/ irreg (+ irreg reg none))(/ reg (+ irreg reg none))(/ none (+ irreg reg none)))
        (format t "~6,3F ~6,3F ~6,3F~%" 0 0 0)
        )
    (rep-f-r y n))))

;;; This function produces a report on a single verb

(defun report-verb (verb &optional (n 10000))
  (format t "~%Report for ~S~%~% Irreg    Reg   None~%" verb)
  (rep-f-v verb (reverse *report*) n))


(defun rep-f-v (verb l n)
  (when l
    (let ((x (if (> (length l) n) (subseq l 0 (1- n)) l))
          (y (if (> (length l) n) (subseq l n) nil))
          (irreg 0)
          (reg 0)
          (none 0))
      (dolist (i x)
        (cond ((not (eq (third i) verb)) nil)
              ((eq (second i) 'reg) (setf reg (1+ reg)))
              ((eq (second i) 'irreg) (setf irreg (1+ irreg)))
              (t (setf none (1+ none)))))
      (if (> (+ irreg reg none) 0)
        (format t "~6,3F ~6,3F ~6,3F~%" (/ irreg (+ irreg reg none))(/ reg (+ irreg reg none))(/ none (+ irreg reg none)))
        (format t "~6,3F ~6,3F ~6,3F~%" 0 0 0)
        )
    (rep-f-v verb y n))))

;;; This function report the PG-C's of the different production rules over time

(defun report-evals ()
  (let ((record (reverse **record**)))
    (format t "~% ")
    (dolist (item record)
      (format t "~S " (first item)))
    (format t "~%")
    (dolist (item (rest (first record)))
      (dolist (i2 record)
        (let ((x (assoc (first item) (rest i2))))
          (when x (format t "~6,3F " (second x)))))
      (format t "~%"))))

;;; This function reports on the size of the vocabulary

(defun report-voc ()
  (let ((record (reverse *voc-size*)))
    (format t "~% irreg      reg ~%")
    (dolist (item record)
      (format t " ~6,1F  ~6,1F~%" (first item)(second item)))))

;;; This function runs all report functions

(defun report-all (&key (generate nil))
  (format t "~%~%Irregular verbs~%")
  (format t "~%Each line represents 500 trials,  which is ~4,2F months.~%" (if generate 0.19 0.39))
  (report-irreg)
  (when (null generate)
    (format t "~%~%Regular verbs~%")
    (format t "~%Each line represents 500 trials, which is ~4,2F months.~%" (if generate 0.19 0.39))
    (report-reg))
  (format t "~%~%Evalutions of production rules~%")
  (format t "~%Each line represents 500 trials, which is ~4,2F months.~%" (if generate 0.19 0.39))
  (report-evals)
  (when (null generate)
    (format t "~%~%Vocabulary size~%")
    (report-voc))
  (format t "~%~%Frequencies for some individual words~%")
  (report)
  (when (null generate)
    (format t "~%~%Overregularization for individual verbs~%")
      (format t "~%Each line represents 10000 trials, which is 7.7 months.~%")
    (report-verb 'be)
    (report-verb 'say)
    (report-verb 'go)
    (report-verb 'feel)
    (report-verb 'run)
    (report-verb 'read)
    (report-verb 'draw)
    (report-verb 'eat)
    (report-verb 'spend)
    (report-verb 'dig)
    (report-verb 'spin)
    (report-verb 'bite)
    (report-verb 'shrink)))
  


;;; This function will run the experiment for n trials
;;; Optional parameters are:
;;; generate - if set to t, run the generate version of the model
;;; cont - continue, when set to true the experiment continues instead of starting anew.
;;;                  Allows you to interrupt the model and continue later on
;;; repfreq - determines how often PG-C's and vocabulary sizes are recorded
;;; init-words - number of words that will be presented to the model prior to the 1st trial
;;; less-feedback - may equal half, one, one-and-a-half or nil (meaning: two)

(defun do-it (n &key (generate nil)(cont nil)(repfreq 500)(init-words 0)(less-feedback nil))
  (when (null cont)
    (reset)
    (when (and generate (null cont))
      (add-generate-prods)
      ;; part of the penalty is shifted toward pronounciation
      (spp analogy-copy-a-slot :eventual-successes 100 :eventual-efforts 50 :effort 0.2)
      (spp find-past-tense-regular :effort 0.8)
      )
    (setf *report* nil)
    (setf **record** nil)
    (setf *voc-size* nil)
    (setf *trial* 0 repcount 0)
    (sgp :v nil)
    (dotimes (i init-words)
      (add-past-tense-to-memory)
      (setf *time* (+ *time* 500))
    ))
  (dotimes (i n)
    (when (null generate)
      (when (not (eq less-feedback 'half)) (add-past-tense-to-memory))
      (when (or (null less-feedback) 
                (and (= (mod i 2) 0)
                     (member less-feedback '(one-and-a-half half))))
        (add-past-tense-to-memory))
      )
    (make-one-goal)
    (run)
    (setf repcount (1+ repcount))
      (when (>= repcount repfreq) 
        (add-record *trial*)
        (format t "~D~%" *trial*)
        (setf repcount 0))
      (setf *time* (+ *time* 
                      (if generate 1000 2000))) 
      (incf *trial*)
      ))

;;; Production rules of the model


;;; Use the stem as past tense

(p past-is-present
   =goal>
     isa word
     of =stem
     suffix nil
     stem nil
     retrieve nil
==>
   =goal>
     stem =stem
     suffix blank)

(spp past-is-present :effort 0.5)

;;; Retrieve a past tense from memory

(p find-past-retrieve
   =goal>
     isa word
     of =stem
     stem nil
     suffix nil
     retrieve nil
   =retrieved>
     isa word
     of =stem
     stem =stem2
     suffix =suffix
     retrieve nil
==>
   =goal>
     stem =stem2
     suffix =suffix)

(spp find-past-retrieve :eventual-successes 10 :eventual-efforts 1)

;;; Implement an analogy strategy

(p analogy-fill-slot
   =goal>
     isa word
     suffix nil
     retrieve nil
   =retrieved>
     isa word
     suffix =suffix
     retrieve nil
==>
   =goal>
     suffix =suffix)

;(spp analogy-fill-slot :eventual-successes 100 :eventual-efforts 150) ; was 200/200

(p analogy-copy-a-slot
   =goal>
     isa word
     of =stem
     stem nil
     suffix =suffix
     retrieve nil
   =dummy>
     isa chunk
==>
   =goal>
     stem =stem)

;;; the costs of this rule reflect the additional costs of using the regualr rule: 600 ms

(spp analogy-copy-a-slot :eventual-successes 100 :eventual-efforts 50 :effort 0.6)


;;; Three rules finalize the process by pronouncing the word
;;; 

(p find-past-tense-no-suffix
   =goal>
     isa word
     stem =stem
     suffix blank
     - of =stem
==>
   =goal>
     retrieve nil
   =goal>
     retrieve nil   ; will kill off proceduralization 
   !eval! (push (list *number* 'irreg *word*) *report*)
   !pop!)

;;; If there is a suffix, it is slightly slower

(p find-past-tense-regular
   =goal>
     isa word
     stem =stem
     - suffix nil
     - suffix blank
==>
   =goal>
     retrieve nil
   =goal>
     retrieve nil   ; will kill off proceduralization 
   !eval! (push (list *number* 'reg *word*) *report*)
   !pop!)

;;; If the past tense is equal to the stem, we include a penalty for the possibility of
;;; miscommunication

(p find-past-tense-equal
   =goal>
     isa word
     stem =stem
     suffix blank
     of =stem
==>
   =goal>
     retrieve nil
   =goal>
     retrieve nil   ; will kill off proceduralization 
   !eval! (push (list *number* 'none *word*) *report*)
   !pop!)

(spp find-past-tense-equal :effort 0.9) 





;;; !!!!!!! These rules are only part of the generate model !!!!!!

(defun add-generate-prods ()

;;; First the generate rules

(p generate-new-irregular
   =goal>
     isa word
     of =stem
     suffix nil
     stem nil
     retrieve nil
==>
   =subgoal>
     isa word-frag
     of =goal
   =goal>
     stem =subgoal
     suffix blank
   !push! =subgoal)

(spp generate-new-irregular :effort 1.4)

(p generate-new-regular
   =goal>
     isa word
     of =stem
     suffix nil
     stem nil
     retrieve nil
==>
   =subgoal>
     isa word-frag
     of =goal
   =goal>
     stem =stem
     suffix =subgoal
   !push! =subgoal)

(spp generate-new-regular :effort 1.3)

(p pop-word-frag
   =goal>
     isa word-frag
==>
   !pop!)

(p find-past-tense-equal
   =goal>
     isa word
     stem =stem
     suffix blank
     of =stem
==>
   =goal>
     retrieve t
   =goal>
     retrieve t   ; will kill off proceduralization 
   !eval! (push (list *number* 'none *word*) *report*)
   !pop!)

(spp find-past-tense-equal :effort 0.9) 

(p find-past-tense-no-suffix
   =goal>
     isa word
     stem =stem
     suffix blank
     - of =stem
==>
   =goal>
     retrieve nil
   !eval! (push (list *number* 'irreg *word*) *report*)
   !pop!)
)

;;; End of the rules that are only part of the generate model