;; ------------------------------------------------------------------------- ;; ;; Additions/modification by Hedderik marked with "hvr". ;; ;; HvR, 011122 ;; ;; Modified to reflect (in)equality tests in compiled rules for the balance ;; scale model. ;; ;; NOTE: Code does ONLY work for new models (> Model3) of the balance scale ;; model, as it only checks for equality in slot1 vs slot2. ;; ;; ------------------------------------------------------------------------- (format t "HvR pc.lisp version") ;; Given two production rules: (1) initiating a retrieval and (2) ;; registering a failure, I want to be able to remove the retrieval by ;; compilation. That is, if you're trying to retrieve something, but cannot ;; retrieve the requested chunk, the current version of the composition ;; mechanism would not allow to proceduralize these steps. Again, a bit of a ;; hack. :-) (defun composable (first-actions second-tests) "Determines whether the productions first and second can be composed. That means: No action (+ or -) on a buffer in first that is tested (=) in second. No retrieval request in first if second tests against an error." ;; (let ((pm-actions '(+visual-location> +visual> +aural> +aural-location> +manual> +vocal> ;; -visual-location> -visual> -aural> -aural-location> -manual> -vocal>)) ;; (pm-tests '(=visual-location> =visual> =aural> =aural-location> =manual> =vocal>))) ;; (and (null (intersection (filter-buffers first-actions pm-actions) ;; pm actions in 1st ;; (filter-buffers second-tests pm-tests))) ;; pm test in 2nd ;; (or (not (assoc '+retrieval> first-actions)) ;; no retrieval request or ;; (not (eq (second (second (assoc '=retrieval> second-tests))) ;; (get-type 'error))) ;; no error test ;; )))) (declare (ignore first-actions second-tests)) t) ;;; ------------------------------------------------------------------------ (defun return-slot-with-negation (name gc) (assoc '- (mapcar (lambda (x) (if (= 2 (length (intersection (list '- name) x))) x nil)) gc))) (defun compose-production (x y) ;The legal pair test has been asserted simply to abort any attempt to compose productions that have things in them other ;that what is considered kosher. ; (format t "~%1: ~S~%2: ~S~%Legal: ~S~%" x y (legal-pair x y)) (if (legal-pair x y) ;X IS THE FIRST PRODUCTION AND Y THE SECOND ;WE IDENTIFY THE PATTERNS AND INSTANTIONS OF THESE TWO PRODUCTIONS IN THE NEXT 8 ASSIGNMENTS (let* ((renamings (renamings (car x) (car y))) ;renamings has been introduced to avoid any accidental use of the same variable across productions -- this is a poor version of achieving ;a thorough unification (cond-pat1 (get-condition x)) ;pattern in condition of first production (cond-pat2 (substitute-vars (get-condition y) renamings)) ;pattern in condition of second production (act-pat1 (get-action x)) ;pattern in action of first production (act-pat2 (substitute-vars (get-action y) renamings)) ;pattern in action of second production (cond-ins1 (third x)) ;instantiation of condition of first production (cond-ins2 (third y)) ;instantiation of condition of second production (act-ins1 (fourth x)) ;instantiation of action of first production (act-ins2 (fourth y)) ;instantiation of action of second production ;EXTRACTION OF BUFFERS -- THIS IS REPRESENTED AS A PAIRING OF THE PATTERN AND INSTANTIAION (gc1 (get-terms cond-pat1 cond-ins1 '=goal>)) ; goal buffer in the condition of first production (gc2 (get-terms cond-pat2 cond-ins2 '=goal>)) ; goal buffer in the condition of second production (ga1 (get-terms act-pat1 act-ins1 '=goal>)) ; goal buffer in the action of first production (ga2 (get-terms act-pat2 act-ins2 '=goal>)) ; goal buffer in the action of second production (rc1 (get-terms cond-pat1 cond-ins1 '=retrieval>)) ; retrieval buffer in the condition of first production (rc2 (get-terms cond-pat2 cond-ins2 '=retrieval>)) ; retrieval buffer in the condition of second production (ra1 (or (get-terms act-pat1 act-ins1 '+retrieval>)(get-terms act-pat1 act-ins1 '-retrieval>))) ; retrieval buffer in the action of first production (ra2 (or (get-terms act-pat2 act-ins2 '+retrieval>)(get-terms act-pat2 act-ins2 '-retrieval>))) ; retrieval buffer in the action of second production (ras1 (get-terms act-pat1 act-ins1 '=retrieval>)) (ras2 (get-terms act-pat2 act-ins2 '=retrieval>)) ;deals with cases where we are resetting the the contents of a chunk (vc1 (get-terms cond-pat1 cond-ins1 '=visual>)) ; visual-object buffer in the condition of first production (vl1 (get-terms cond-pat1 cond-ins1 '=visual-location>)) ; visual-location buffer in the condition of first production (vs1 (get-terms cond-pat1 cond-ins1 '=visual-state>)) ; visual-state buffer in the condition of first production (vc2 (get-terms cond-pat2 cond-ins2 '=visual>)) ; visual-object buffer in the condition of second production (vl2 (get-terms cond-pat2 cond-ins2 '=visual-location>)) ; visual-location buffer in the condition of second production (vs2 (get-terms cond-pat2 cond-ins2 '=visual-state>)) ; visual-state buffer in the condition of second production (va1 (or (get-terms act-pat1 act-ins1 '+visual>)(get-terms act-pat1 act-ins1 '-visual>))) ; visual-object buffer in the action of first production (va2 (or (get-terms act-pat2 act-ins2 '+visual>)(get-terms act-pat2 act-ins2 '-visual>))) ; visual-object buffer in the action of second production (vla1 (or (get-terms act-pat1 act-ins1 '+visual-location>)(get-terms act-pat1 act-ins1 '-visual-location>))) (vla2 (or (get-terms act-pat2 act-ins2 '+visual-location>)(get-terms act-pat2 act-ins2 '-visual-location>))) (eval1 (car (get-terms cond-pat1 cond-ins1 '!eval!))) (eval2 (car (get-terms cond-pat2 cond-ins2 '!eval!))) (mc1 (get-terms cond-pat1 cond-ins1 '=manual>)) (mc2 (get-terms cond-pat2 cond-ins2 '=manual>)) (ms1 (get-terms cond-pat1 cond-ins1 '=manual-state>)) (ms2 (get-terms cond-pat2 cond-ins2 '=manual-state>)) ; manual buffer in the condition of second production ;more complete treatment of buffers (ma1 (or (get-terms act-pat1 act-ins1 '+manual>) (get-terms act-pat1 act-ins1 '-manual>))) ; manual buffer in the action of first production (ma2 (or (get-terms act-pat2 act-ins2 '+manual>)(get-terms act-pat2 act-ins2 '-manual>))) ; manual buffer in the action of second production (n1 (or (get-terms act-pat1 act-ins1 '+goal>) (get-terms act-pat1 act-ins1 '=newgoal>)) ) ; newgoal buffer in the action of first production (n2 (or (get-terms act-pat2 act-ins2 '+goal>) (get-terms act-pat2 act-ins2 '=newgoal>)))) ; newgoal buffer in the action of second production (declare (ignore mc1 mc2)) ; THIS DEALS WITH THE CASE IN WHICH WE CAN SIMPLY COMPOSE THE TWO CONDITIONS BUT FIRST WE TEST FOR ALL THE CASES WHERE THIS IS FORBIDDEN (cond ((and (not n1) ;one does not want to simply compose over a switch in the goal but see below (same-goal-test (car (second gc1)) (car (second gc2))) ;then they should be the same goal ;the line above is the generalized same goal test and the line below avoids the situation of direction retrieval of the goal (not (equal (first (second (first ra1))) '=goal)) (not (and va1 vc2)) (not (and Va1 va2)) (not (or ras1 ras2)) (not (and vla1 vl2)) (not (and vla1 vla2)) ;one does not want to compose when there is a contingency between the visual processing (not (and ma1 ma2)) ;one does not want to have jamming actions ; HvR: (not (and rc2 (equal (wme-type-name (second (second (car rc2)))) 'error))) ) ;one also does not want to compose over a retrieval failure ; IF WE ARE GOING TO COMPOSE THE PRODUCTIONS WE NEED TO GO ABOUT CALCULATING ; WHAT THE BUFFER SPECIFICATIONS WILL BE IN THE COMPOSED PRODUCTION ; IF THERE IS A RETRIEVAL REQUEST IS THE FIRST AND A TEST WE WILL DELETE THESE ; BEYOND THIS WE MUST MAKE SURE THAT THE VARIABLES ARE CONSTRAINED TO BE WHAT ; THEY WOULD HAVE BEEN IN THIS RETRIEVAL REQUEST MORE GENERALLY WE NEED TO ; CALCULATE A CONSISTENT SET OF VARIABLE NAMES BETWEEN THE TWO PRODUCTIONS (let* ((mapping1 (append (extract-map (first ra1) (second ra1)) ;any variables in the first's retrieval request must be replaced by constants (extract-constant-map (first ga1) (first gc2)) ;deal with case were second condition constrains variable in first action (modify1 (first ra1) (second ra1)) ;Deals with the mapping produced required when there is direct assignment to a retrieval request. For ;reasons that are unclear to me any more I re-ordered the retrieval and goal mappings (hack (first ga1) (first gc2) (first rc2) (second rc2)))) (hvr_gc2 (first gc2)) ;; If the variable that is bound to slot1 (vs1) is a constraint ;; for slot2 (vs2), set hvr_equal to t (hvr_equal_12 (let ((vs1 (second (assoc 'slot1 (cdr hvr_gc2)))) (vs2 (second (assoc 'slot2 (cdr hvr_gc2))))) ;; (format t "Equal: vs1: ~S~%vs2: ~S~%" vs1 vs2) (and vs1 vs2 (equal vs1 vs2)))) (hvr_unequal_12 ;; If the variable that is bound in slot1 (vs1) also occurs in ;; a slot (in casu, always slot2) with a negation, set hvr_unqual to t (let ((vs1 (second (assoc 'slot1 (cdr hvr_gc2)))) (vs2 (third (return-slot-with-negation 'slot2 (cdr hvr_gc2))))) ;; (format t "Unequal: vs1: ~S~%vs2: ~S~%" vs1 vs2) (and vs1 vs2 (equal vs1 vs2)))) ;; If the variable that is bound to slot1 (vs1) is a constraint ;; for slot2 (vs2), set hvr_equal to t (hvr_equal_34 (let ((vs1 (second (assoc 'slot3 (cdr hvr_gc2)))) (vs2 (second (assoc 'slot4 (cdr hvr_gc2))))) ;; (format t "Equal: vs1: ~S~%vs2: ~S~%" vs1 vs2) (and vs1 vs2 (equal vs1 vs2)))) (hvr_unequal_34 ;; If the variable that is bound in slot1 (vs1) also occurs in ;; a slot (in casu, always slot2) with a negation, set hvr_unqual to t (let ((vs1 (second (assoc 'slot3 (cdr hvr_gc2)))) (vs2 (third (return-slot-with-negation 'slot4 (cdr hvr_gc2))))) ;; (format t "Unequal: vs1: ~S~%vs2: ~S~%" vs1 vs2) (and vs1 vs2 (equal vs1 vs2)))) (rt (progn (retrieval-test mapping1 ))) (mapping2 (extend-map (append (modify (first ra1) (second ra1)) ;=retrieval in second production replaced with direct assignment (extract-map (first rc2) (second rc2)) ;any variables in the seconds retrieval test but be replaced by constants (extract-map (first gc2) (first ga1)) ;any variables in the second's goal test must be replace by ;extending the mapping to include terms in the retrieval buffer (extract-map (first vc2) (first vc1)) (extract-map (first gc2) (first gc1))) ;corresponding terms from the first action or condition mapping1));these substitutions for the second production must be made consistent with the substitution for the first (gc (chunk-merge-condition (substitute-vars (car gc1) mapping1) ;the goal buffer must be specific to the retrieval (chunk-dif (substitute-vars (car gc2) mapping2) ;and include any additional tests from the second production (substitute-vars (car ga1) mapping1)))) ;that were not created in the first's action (ga (chunk-merge-action (substitute-vars (car ga2) mapping2) ;the goal action must combine the action of the second and the action of (substitute-vars (car ga1) mapping1))) ;the first giving preference to the second (ma (or (substitute-vars (car ma1) mapping1) (substitute-vars (car ma2) mapping2))) ;whichever has a manual condition (rc (let ((hvr_rc (substitute-vars (car rc1) mapping1))) ;maintain the instantiated retrieval request from the second (cond ((position '(SLOT2 =SLOT2) hvr_rc :test 'equal) ;; If we've noticed that the original prule had a ;; "variable constraint" (what is the official ;; term?), introduce it again in the newly compiled ;; prule. (cond (hvr_equal_12 (setf (nth (position '(SLOT2 =SLOT2) hvr_rc :test 'equal) hvr_rc) '(slot2 =slot1))) (hvr_unequal_12 (setf (nth (position '(SLOT2 =SLOT2) hvr_rc :test 'equal) hvr_rc) '(- slot2 =slot1)))) (if (or hvr_equal_12 hvr_unequal_12) (setq hvr_rc (append hvr_rc '((slot2 =slot2)))))) ((position '(SLOT4 =SLOT4) hvr_rc :test 'equal) ;; If we've noticed that the original prule had a ;; "variable constraint" (what is the official ;; term?), introduce it again in the newly compiled ;; prule. (cond (hvr_equal_34 (setf (nth (position '(SLOT4 =SLOT4) hvr_rc :test 'equal) hvr_rc) '(slot4 =slot3))) (hvr_unequal_34 (setf (nth (position '(SLOT4 =SLOT4) hvr_rc :test 'equal) hvr_rc) '(- slot4 =slot3)))) (if (or hvr_equal_34 hvr_unequal_34) (setq hvr_rc (append hvr_rc '((slot4 =slot4))))))) hvr_rc)) (ra (substitute-vars (car ra2) mapping2)) (vl (or (substitute-vars (car vl1) mapping1) (substitute-vars(car vl2) mapping2))) ; one of the tests of visual location (vs (or (substitute-vars (car vs1) mapping1) (substitute-vars (car vs2) mapping2))) ;one of the visual states -- my colon is a hack trying to deal with :visual ;Substitution is required in these cases as well (ms (or (substitute-vars (car ms1) mapping1) (substitute-vars (car ms2) mapping2))) ;more complete treatment of buffers (vc (or (substitute-vars (car vc1) mapping1) (substitute-vars (car vc2) mapping2))) ;one of the visual object tests (va (or (substitute-vars (car va1) mapping1) (substitute-vars (car va2) mapping2))) ;one of the visual object requests ;Substitution is required in these cases as well (vla (location-filter (or(substitute-vars (car vla1)mapping1) (substitute-vars (car vla2)mapping2)))) ;The location filter is just a hack to deal with troubles I have had with wmes versus symbols (eval (eval-merge rt (substitute-vars eval1 mapping1) (substitute-vars eval2 mapping2))) ;reatment of evals (na (substitute-vars (car n2) mapping2)) ;the goal switch made consistent ;NOW THE ACTUAL CALCULATION OF THE NEW PRODUCTION CAN BEGIN (new-condition (remove-nils(list gc rc vl vs vc ms eval)) ) ;the new condition with all buffers specified ;ms and eval have been added. The eval computation and the old rt have been absorbed by val (new-action (remove-nils (list vla va ga ra ma na) )) ;the new action with all buffers specified (production-name (new-name-fct "PRODUCTION-2-")) ;create a new name for the production (production (compile-or-select-production production-name (second (second (first cond-pat1))) new-condition new-action nil nil))) ;call code to create production (when production (finish-up production (car x) (car y))))) ;when a production was created set its parameters etc ;THE CODE BELOW DEALS WITH A CASE IN WHICH ONE CAN COMPOSE TWO PRODUCTIONS EVEN IF THEY BOTH INVOLVE NEWGOALS. THIS IS WHEN THE SECOND NEWGOAL IS ;RETURNING TO THE GOAL OF THE FIRST PRODUCTION. THUS THE FIRST PRODUCTION PUSHES AND THE SECOND POPS ((and n1 n2 (equal (headere (car (second gc1))) (car (second (second n2)))) ;test for this condition (not (equal (first (second (first ra1))) '=goal)) ;the line above is the generalized same goal test (not (and va1 vc2)) (not (and Va1 va2)) (not (or ras1 ras2)) (not (and vla1 vl2)) (not (and vla1 vla2)) ;one does not want to compose when there is a contingency between the visual processing (not (and ma1 ma2)) ;one does not want to have jamming actions (not (and rc2 (equal (wme-type-name (second (second (car rc2)))) 'error)))) ;one also does not want to compose over a retrieval failure ;Copying of the same tests used for the case above (let* ((mapping1 (append (extract-map (first ra1) (second ra1)) ;any variables in the first's retrieval request must be replaced by constants (modify1 (first ra1) (second ra1)) ;Deals with the mapping produced required when there is direct assignment to a retrieval request (extract-map (first n1) (first gc2)))) ;terms in the first production must be specific to how the goal was tested ;For reasons that are unclear to me any more I re-ordered the retrieval and goal mappings (rt (retrieval-test mapping1 )) (mapping2 (extend-map (append (modify (first ra1) (second ra1)) ;Correction of a mistake in place of (extract-map (first gc2) (first ga1) ;=retrieval in second production replaced with direct assignment (extract-map (first rc2) (second rc2));any variables in the seconds retrieval test but be replaced by constants (extract-map (first vc2) (first vc1)) ;extending the mapping to include terms in the retrieval buffer (extract-map (first gc2) (first n1))) ;corresponding terms from the first action or condition ;Correction of a mistake mapping1)) ;these substitutions for the second production must be made consistent with the substitution for the first (gc (substitute-vars (car gc1) mapping1)) ;rename terms in first goal test (ga (substitute-vars (car ga1) mapping1)) ;rename terms in first goal change (ma (or (substitute-vars (car ma1) mapping1) (substitute-vars (car ma2) mapping2))) ;whichever has a manual condition (rc (substitute-vars (car rc1) mapping1)) ;maintain the instantiated retrieval test from the first (ra (substitute-vars (car ra2) mapping2)) ;maintain the instantiated retrieval request from the second (vl (or (substitute-vars (car vl1) mapping1)(substitute-vars (car vl2) mapping2))) ; one of the tests of visual location (vs (or (substitute-vars (car vs1) mapping1) (substitute-vars (car vs2) mapping2))) ;Substitution is required in these cases as well ; (vla (or(substitute-vars (car vla1)mapping1)(substitute-vars (car vla2)mapping2))) (vla (location-filter (or(substitute-vars (car vla1)mapping1) (substitute-vars (car vla2)mapping2)))) ;Visual locations appearing in the action -- the first setting is dead code ;The location filter is just a hack to deal with troubles I have had with wmes versus symbols (ms (or (substitute-vars (car ms1) mapping1) (substitute-vars (car ms2) mapping2))) ;more complete treatment of buffers (eval (eval-merge rt (substitute-vars eval1 mapping1) (substitute-vars eval2 mapping2))) ;treatment of evals (vc (or (substitute-vars (car vc1) mapping1) (substitute-vars (car vc2) mapping2))) ;one of the visual object tests (va (or (substitute-vars (car va1) mapping1) (substitute-vars (car va2) mapping2))) ;one of the visual object requests ;NOW THE ACTUAL CALCULATION OF THE NEW PRODUCTION CAN BEGIN (new-condition (remove-nils (list gc rc vl vs vc ms eval) )) ;the new condition with all buffers specified ;ms and eval have been added. The eval computation and the old rt have been absorbed by val (new-action (remove-nils (list vla va ga ra ma) )) ;the new action with all buffers specified (production-name (new-name-fct "PRODUCTION-3-")) ;create a new name for the production (production (compile-or-select-production production-name (second (second (first cond-pat1))) ;call code to create production new-condition new-action nil nil))) ;call code to create production (when production (finish-up production (car x) (car y))))) ;when a production was created set its parameters etc ((and n1 (not n2) (equal (car (second (car n1))) 'isa) (not (and va1 vc2)) (not (and Va1 va2)) (not (or ras1 ras2)) ;the line below avoids the situation of direction retrieval of the goal (not (equal (first (second (first ra1))) '=goal)) (not (and vla1 vl2)) (not (and vla1 vla2)) ;one does not want to compose when there is a contingency between the visual processing (not (and ma1 ma2)) ;one does not want to have jamming actions (not (and rc2 (equal (wme-type-name (second (second (car rc2)))) 'error)))) ;one also does not want to compose over a retrieval failure (let* ((mapping1 (append (extract-map (first ra1) (second ra1)) ;any variables in the first's retrieval request must be replaced by constants (extract-constant-map (first n1) (first gc2)) ;deal with case were second condition constrains variable in first action (modify1 (first ra1) (second ra1)) (hack (first ga1) (first gc2) (first rc2) (second rc2)))) (rt (retrieval-test mapping1 )) (mapping2 (extend-map (append (modify (first ra1) (second ra1)) (extract-map (first rc2) (second rc2)) ;any variables in the seconds retrieval test but be replaced by constants (extract-map (first gc2) (first n1)) ;any variables in the second's goal test must be replace by ;extending the mapping to include terms in the retrieval buffer (extract-map (first vc2) (first vc1)) (extract-map (first gc2) (first gc1))) ;corresponding terms from the first action or condition mapping1)) ;these substitutions for the second production must be made consistent with the substitution for the first (gc (substitute-vars (car gc1) mapping1)) ;rename terms in first goal test (ga (substitute-vars (car ga1) mapping1)) ;rename terms in first goal change (ma (or (substitute-vars (car ma1) mapping1) (substitute-vars (car ma2) mapping2))) ;whichever has a manual condition (rc (substitute-vars (car rc1) mapping1)) ;maintain the instantiated retrieval test from the first (ra (substitute-vars (car ra2) mapping2)) ;maintain the instantiated retrieval request from the second (vl (or (substitute-vars (car vl1) mapping1)(substitute-vars (car vl2) mapping2))) ; one of the tests of visual location (vla (location-filter (or(substitute-vars (car vla1)mapping1) (substitute-vars (car vla2)mapping2)))) (vs (or (substitute-vars (car vs1) mapping1)(substitute-vars (car vs2) mapping2))) ;one of the visual states (ms (or (substitute-vars (car ms1) mapping1) (substitute-vars (car ms2) mapping2))) (eval (eval-merge rt (substitute-vars eval1 mapping1) (substitute-vars eval2 mapping2))) (vc (or (substitute-vars (car vc1) mapping1) (substitute-vars (car vc2) mapping2))) ;one of the visual object tests (va (or (substitute-vars (car va1) mapping1) (substitute-vars (car va2) mapping2))) ;one of the visual object requests (na (append (list '+goal> (second (car n1))) (cdr (chunk-merge-action (substitute-vars (car ga2) mapping2) ;the goal action must combine the action of the second and the action of (substitute-vars (cons (first (car n1)) (cddr (car n1))) mapping1))))) ;the first giving preference to the second ;NOW THE ACTUAL CALCULATION OF THE NEW PRODUCTION CAN BEGIN (new-condition (remove-nils (list gc rc vl vs vc ms eval) )) ;the new condition with all buffers specified (new-action (remove-nils (list vla va ga ra ma na) )) ;the new action with all buffers specified (production-name (new-name-fct "PRODUCTION-4-")) ;create a new name for the production (production (compile-or-select-production production-name (second (second (first cond-pat1))) ;call code to create production new-condition new-action nil nil))) ;call code to create production (when production (finish-up production (car x) (car y))))) ;when a production was created set its parameters etc ))) ) ;largely from Niel -- different definition of new b -- from Niels Thursday (defun finish-up (production old1 old2) ;; this code allows us to recognize when we have recreated a production ;; and have yet to try it. In this case it seems wise to reset its ;; parameters according to the current parameters of the productions from ;; which it originated. There is a more general version of this idea that ;; I did not implement because it is not sorted in the production ;; structure. this is that the initialization of the parameters of a ;; production should change whenever the originating productions change ;; but the production-specific experience should be allowed to accumulate. ;; Echter, in de huidige opzet kan een nieuw aangemaakte regel wegzakken. ;; Hierdoor komen de oude regels weer bovendrijven, waardoor de ;; oorspronkelijk aangemaakte regel weer opnieuw aangemaakt kan worden. ;; Als dit gebeurd, blijft deze echter gewoon de oude parameter settings ;; houden. Dit betekent dat als een nieuw prule per toeval "in den ;; beginne" een aantal keer leidde tot een fout antwoord, deze zonder ;; echte noise nooit meer boven threshold uit zal komen. Omdat ik geen ;; noise wil gebruiken, kies ik ervoor om het aantal successes na ;; heraanmaken van een prule te verhogen, in eerste instantie met slechts ;; 1. Dat is gegeven een *initial-experience* van 10 nog altijd een ;; invloed van zo'n 10 procent. (let ((number (no-output (+ (caaar (eval `(spp ,production :successes))) (caaar (eval `(spp ,production :failures))))))) (cond ((<= number *initial-experience*) (cond ((and (equal number 1.0) *production-compilation-trace* *verbose*) (eval `(pp ,production)))) (no-output (let* ((initial-experience *initial-experience*) (effort1 (caar (eval `(spp ,old1 :effort)))) (effort2 (caar (eval `(spp ,old2 :effort)))) (effort (+ effort1 effort2 (- *default-action-time*))) ;we save the 50 ms by having one fewer productions (c2 (caar (eval `(spp ,old2 :c)))) (p2 (caar (eval `(spp ,old2 :p)))) (c1 (caar (eval `(spp ,old1 :c)))) (p1 (caar (eval `(spp ,old1 :p)))) (s1 (caar (eval `(spp ,old1 :success)))) (s2 (caar (eval `(spp ,old2 :success)))) (c (max 0 (+ c1 *cost-penalty*))) ;this is the pessimism built into the productions ;;avoid negative costs (p p1) ;since this new production must compete with the first it makes sense to base its parameters on the first. (successes (* p initial-experience)) (failures (- initial-experience successes)) (efforts (* c initial-experience)) (s (or s1 s2)) (pl (first (no-output (sgp :pl))))) (declare (ignore p2 c2)) (cond ((eq pl t) (no-output (eval `(spp ,production :effort ,effort :efforts ,efforts :success ,s :successes ,successes :failures ,failures)))) ((null pl) (no-output (eval `(spp ,production :effort ,effort :c ,c :p ,p)))) (t (no-output (eval `(spp ,production :effort ,effort :efforts ,efforts :success ,s :successes ,successes :failures ,failures))))))) (when (and *production-compilation-trace* *verbose*) (eval `(spp ,production)))) ;; HvR re-composed rules again are given an extra boost ((> number *initial-experience*) (no-output (let ((successes (1+ (1+ (caaar (eval `(spp ,production :successes))))))) (eval `(spp ,production :successes ,successes))))) )))