;;; ------------------------------------------------------------------------
;;
;; Lisp functions used for running the balance scale model
;;
;; Hedderik van Rijn, 020117
;;
;;; ------------------------------------------------------------------------

(defvar **stimulus-chunks**)

(setf **stimulus-chunks** nil)

(defvar **balance-goal**)

(setf **balance-goal** nil)

(defvar **cd**)
(defvar **cd-percent**)

(setq **cd-percent** 0)

(defvar **w1**)
(defvar **w2**)
(defvar **d1**)
(defvar **d2**)
(defvar **a1**)
(defvar **a2**)
(defvar **f1**)
(defvar **f2**)

(defvar **weight-values**)
(defvar **distance-values**)
(defvar **addition-values**)
(defvar **guess-values**)
(defvar **force-values**)

(defvar **answer**)
(defvar **answer-d**)
(defvar **answer-w**)

(defvar **given-answer**)

(defvar **success**)
(setf **weight-values** nil)
(setf **distance-values** nil)
(setf **addition-values** nil)
(setf **guess-values** nil)
(setf **force-values** nil)

(defvar **procp** nil)

(defun set-proc-settings (&optional (procp **procp**))
  (format t "~%Proceduralization is o~a~%" (if procp "n" "ff"))
  (eval `(sgp :epl ,procp)))

(defun set-base-levels-of (list-of-chunks num time)
  (dolist (curchunk list-of-chunks t)
    (eval `(set-base-levels ,(list curchunk num time)))))

(defun present-random-stimulus ()
  (add-stimulus-to-model (random 5) (random 5) (random 5) (random 5)))

(defun present-cd-stimulus ()
  (let* ((cd-items '((2 0 1 1)
 		     (1 3 2 0)
 		     (2 1 1 4)
 		     (1 4 2 1)
 		     (3 4 4 2)
		     (4 2 3 4)))
	 (stim (nth (random (length cd-items)) cd-items)))
    (princ stim)
    (add-stimulus-to-model (nth 0 stim)
			   (nth 1 stim)
			   (nth 2 stim)
			   (nth 3 stim))))


(defun present-cw-stimulus ()
  (let* ((cw-items '((0 2 3 1)
		     (3 1 0 2)
		     (1 2 4 1)
		     (4 1 1 2)
		     (4 3 2 4)
		     (2 4 4 3)))
	 (stim (nth (random (length cw-items)) cw-items)))
    (princ stim)
    (add-stimulus-to-model (nth 0 stim)
			   (nth 1 stim)
			   (nth 2 stim)
			   (nth 3 stim))))


(defun present-wd-stimulus ()
  (let ((w1 (random 5))
	(w2 (random 5))
	(d1 (random 5))
	(d2 (random 5)))
    (if (or (and (> w1 w2)
		 (> d1 d2))
	    (and (< w1 w2)
		 (< d1 d2)))
	(present-wd-stimulus)
      (add-stimulus-to-model w1 d1 w2 d2))))
	

(defun present-w-stimulus ()
  (let* ((cd-items '((2 0 1 0)
		     (1 0 2 0)
		     (4 1 3 1)
		     (3 1 4 1)
		     (3 4 4 4)
		     (4 4 3 4)))
	 (stim (nth (random (length cd-items)) cd-items)))
    (princ stim)
    (add-stimulus-to-model (nth 0 stim)
			   (nth 1 stim)
			   (nth 2 stim)
			   (nth 3 stim))))

(defun present-d-stimulus ()
  (let* ((cd-items '((0 2 0 1)
		     (0 1 0 2)
		     (1 4 1 3)
		     (1 3 1 4)
		     (4 3 4 4)
		     (4 4 4 3)))
	 (stim (nth (random (length cd-items)) cd-items)))
    (princ stim)
    (add-stimulus-to-model (nth 0 stim)
			   (nth 1 stim)
			   (nth 2 stim)
			   (nth 3 stim))))

(defun present-b-stimulus ()
  (let* ((cd-items '((0 2 0 2)
		     (0 1 0 1)
		     (1 4 1 4)
		     (2 4 2 4)
		     (4 3 4 3)
		     (4 3 4 3)))
	 (stim (nth (random (length cd-items)) cd-items)))
    (princ stim)
    (add-stimulus-to-model (nth 0 stim)
			   (nth 1 stim)
			   (nth 2 stim)
			   (nth 3 stim))))

(defun pr (w1 d1 w2 d2)
  (add-stimulus-to-model (1- w1) (1- d1) (1- w2) (1- d2)))

(defun reset-pp (plist)
  (dolist (prule plist)
    (spp-fct (list prule :successes 10 :failures 5 :efforts 0.075))))

(defvar reset1)
(defvar reset2)
(defvar reset3)

(defun add-stimulus-to-model (w1 d1 w2 d2)
  
  ;; We assume that all general production rules are also extensively used
  ;; within other contexts. Therefore, the expected gains of these rules are
  ;; not supposed to be influenced too much by the balance scale task. In other
  ;; words, reset the expected gains for these production rules. 
  
  (reset-pp reset1)
  (reset-pp reset2)

  ;; Because of the removal of the goal-stack, it is necessary to explicitly
  ;; flag which rules represent failures. However, this causes the flagged
  ;; rule's expected gain to decrease as each firing is a failure. This
  ;; strikes me as odd, as it can be a rational function to "signal a
  ;; failure". Another approach would be to account the failure to all
  ;; previous production rules, and not to the one that signals the failure.
  ;;
  ;; To make sure that the production rule can keep firing, reset its
  ;; expected gain.
  
  (reset-pp reset3)
  
  (incf w1)
  (incf w2)
  (incf d1)
  (incf d2)
  (let* ((balance (- (* w1 d1) (* w2 d2)))
	 (**a1** (+ w1 d1))
	 (**a2** (+ w2 d2))
	 (**f1** (* w1 d1))
	 (**f2** (* w2 d2)))
    
    (setf **w1** w1)
    (setf **w2** w2)
    (setf **d1** d1)
    (setf **d2** d2)
    
    (setf **answer** (cond ((> balance 0) 'left)
			   ((< balance 0) 'right)
			   (t 'none)))
    (setf **answer-w** (cond ((> w1 w2) 'left)
			     ((< w1 w2) 'right)
			     (t 'none)))
    (setf **answer-d** (cond ((> d1 d2) 'left)
			     ((< d1 d2) 'right)
			     (t 'none)))
    ;; Modify (after first presentation) or add the goal...
    ;; 
    (if **balance-goal**
	(eval `(mod-chunk ,**balance-goal** type balance-goal
			  slot1 nil slot2 nil slot3 nil slot4 nil
			  answer nil action nil operand nil retrieve nil
			  prev-step init active-dim nil))
      (progn
	(setf **balance-goal** 'balance-problem)
	(eval `(add-dm (,**balance-goal** isa gen-goal type balance-goal
					  prev-step init)))))

    (if **weight-values**
	(eval `(mod-chunk ,**weight-values** type feature-value
			  slot1 ,**w1** slot2 ,**w2** slot3 nil slot4 nil
			  answer nil action nil operand weight retrieve nil
			  prev-step nil))
      (progn
	(setf **weight-values** 'weight-values)
	(eval `(add-dm (,**weight-values** 
			isa gen-goal type feature-value
			slot1 ,**w1** slot2 ,**w2** slot3 nil slot4 nil
			answer nil action nil operand weight retrieve nil
			prev-step nil)))))
      

    (if **distance-values**
	(eval `(mod-chunk ,**distance-values** type feature-value
			  slot1 ,**d1** slot2 ,**d2** slot3 nil slot4 nil
			  answer nil action nil operand distance retrieve nil
			  prev-step nil))
      (progn
	(setf **distance-values** 'distance-values)
	(eval `(add-dm (,**distance-values** 
			isa gen-goal type feature-value
			slot1 ,**d1** slot2 ,**d2** slot3 nil slot4 nil
			answer nil action nil operand distance retrieve nil
			prev-step nil)))))

    (if **addition-values**
	(eval `(mod-chunk ,**addition-values** type feature-value
			  slot1 ,**a1** slot2 ,**a2** slot3 nil slot4 nil
			  answer nil action nil operand addition retrieve nil
			  prev-step nil))
      (progn
	(setf **addition-values** 'addition-values)
	(eval `(add-dm (,**addition-values** 
			isa gen-goal type feature-value
			slot1 ,**a1** slot2 ,**a2** slot3 nil slot4 nil
			answer nil action nil operand addition retrieve nil
			prev-step nil)))))
      
    (if **force-values**
	(eval `(mod-chunk ,**force-values** type feature-value
			  slot1 ,**f1** slot2 ,**f2** slot3 nil slot4 nil
			  answer nil action nil operand multiplication retrieve nil
			  prev-step nil))
      (progn
	(setf **force-values** 'multiplication-values)
	(eval `(add-dm (,**force-values** 
			isa gen-goal type feature-value
			slot1 ,**f1** slot2 ,**f2** slot3 nil slot4 nil
			answer nil action nil operand multiplication retrieve nil
			prev-step nil)))))
      
    

    
    (set-base-levels-of (list **balance-goal** **distance-values** **weight-values** **addition-values** **force-values**) 25 -100)

    (eval `(goal-focus ,**balance-goal**))
    (format t "~% left: w(~S),d(~S) right: w(~S),d(~S) = ? (~S, w[~S], d[~S])" 
	    **w1** **d1** **w2** **d2** 
	    **answer** **answer-w** **answer-d**)
    (setf **success** nil)))
  

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

(defvar **present-func**)

(defun present-type (type)
  (setf **present-func**
   (cond ((eq type 'cd) 'present-cd-stimulus)
	 ((eq type 'w) 'present-w-stimulus)
	 ((eq type 'd) 'present-d-stimulus)
	 ((eq type 'wd) 'present-wd-stimulus)
	 (t  'present-random-stimulus))))

(present-type 'random)

(defun do-it (&optional (n 'help) (procp nil) (log nil) (flag nil))
  (if (eq n 'help) 
      (format t "(do-it arg1 arg2 arg3 arg4)~% arg1: number of runs~% arg2: proceduralization?~% arg3: log? 'delete: delete log file~% arg4: t: verbose, pstep: pstep")
    (let ((cycles nil)
	  (productions nil)
	  (init-prods (length *procedural-memory*))
	  (**pstep** (eq flag 'pstep))
	  (numrun (cond ((numberp flag) flag)))
	  (vflag (not (eq flag nil))))
	  
      (if (and (eq log 'delete)
	       (probe-file "prule-par1.dat"))
	  (delete-file "prule-par1.dat"))
      (if log 
	  (start-write-prule-parameters "prule-par1" "PRODUCTION" '(:PG-C :C) 200))

      (set-proc-settings procp)

	(dotimes (i n)
	  (progn
	    (funcall **present-func**)
	    (eval `(sgp :v ,vflag))
	    (setf **given-answer** nil)
	    (if **pstep** (pstep)
	      (let* ((cc (multiple-value-list (run-fct (or numrun 50))))
		     (cyc (second cc))
		     (tm (first cc)))
		(if flag
		    (format t "~% left: w(~S),d(~S) right: w(~S),d(~S) = ? " **w1** **d1** **w2** **d2**))
		(format t "~%Problem ~3D  Cycles ~2D Time ~6,2F Productions ~3D Success ~S (~S,~S)" (1+ i) cyc tm 
			(- (length *procedural-memory*) init-prods)
			(if **success** 'Yes 'No)
			**answer** **given-answer**)
		(push cc cycles)
		(push (- (length *procedural-memory*) init-prods) productions)))
	    (if (write-prule-parameters-p)
		(do-write-prule-parameters))))
  (if log
      (stop-write-prule-parameters)))))

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

(defun do-it-stop (&optional (n 'help) (procp nil) (log nil) (flag nil))
  (if (eq n 'help) 
      (format t "(do-it arg1 arg2 arg3 arg4)~% arg1: number of runs~% arg2: proceduralization?~% arg3: log? 'delete: delete log file~% arg4: t: verbose, pstep: pstep")
    (let ((cycles nil)
	  (productions nil)
	  (init-prods (length *procedural-memory*))
	  (**pstep** (eq flag 'pstep))
	  (numrun (cond ((numberp flag) flag)))
	  (vflag (not (eq flag nil))))
	  
      (if (and (eq log 'delete)
	       (probe-file "prule-par1.dat"))
	  (delete-file "prule-par1.dat"))
      (if log 
	  (start-write-prule-parameters "prule-par1" "PRODUCTION" '(:PG-C :C) 200))

      (set-proc-settings procp)

      (let ((stop nil))
	(dotimes (i n)
	  (cond ((not stop)
		 (funcall **present-func**)
		 (eval `(sgp :v ,vflag))
		 (setf **given-answer** nil)
		 (if **pstep** (pstep)
		   (let* ((cc (multiple-value-list (run-fct (or numrun 50))))
			  (cyc (second cc))
			  (tm (first cc)))
		     (if flag
			 (format t "~% left: w(~S),d(~S) right: w(~S),d(~S) = ? " **w1** **d1** **w2** **d2**))
		     (format t "~%Problem ~3D  Cycles ~2D Time ~6,2F Productions ~3D Success ~S (~S,~S)" (1+ i) cyc tm 
			     (- (length *procedural-memory*) init-prods)
			     (if **success** 'Yes 'No)
			     **answer** **given-answer**)
		     (if (> (length *procedural-memory*) init-prods)
			 (setf stop t))
		     (push cc cycles)
		     (push (- (length *procedural-memory*) init-prods) productions)))
		 (if (write-prule-parameters-p)
		     (do-write-prule-parameters))))))
      (if log
	  (stop-write-prule-parameters)))))

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

(defun 1-wd ()
  (let ((**present-func** 'present-w-stimulus))
    (do-it 1 nil nil t))
  (let ((**present-func** 'present-d-stimulus))
    (do-it 1 nil nil t)))

(defun 1-w ()
  (let ((**present-func** 'present-w-stimulus))
    (do-it 1 nil nil t)))

(defun 1-d ()
  (let ((**present-func** 'present-d-stimulus))
    (do-it 1 nil nil t)))

(defun 1-b ()
  (let ((**present-func** 'present-b-stimulus))
    (do-it 1 nil nil t)))

(defun 1-cd ()
  (let ((**present-func** 'present-cd-stimulus))
    (do-it 1 nil nil t)))

(defun 1-wdb ()
  (sgp :pl nil)
  (1-w)
  (1-d)
  (1-b)
  (sgp :pl t))
  
;;; ------------------------------------------------------------------------

(defun do1 (type proc)
  (let (**present-func**)
    (present-type type)
    (do-it 1 proc t)))

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

(defun wpp1 ()
  (sgp :pl t)
  (start-write-prule-parameters "prule-par1" "PRODUCTION" '(:P :C) 200))

(defun wpp0 ()
  (stop-write-prule-parameters))

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

(defun disall ()
  (pdisable-fct (return-matching-prules '("PRODUCTION-2-"))))

(defun enall ()
  (dolist (p (mapcar 'car *failed-productions*)) (penable-fct (list p))))

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

(defun show-last-pp ()
  (pp-fct (last (no-output (pp)))))

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

(defun do1 (num)
  (reload)
  (add-stimulus-to-model 1 1 1 1)
  (run-fct (list num)))

(defun do2 (num)
  (reload)
  (add-stimulus-to-model 2 2 1 1)
  (run-fct (list num)))

(defun do-wdb ()
  (sgp :epl nil :pl nil :egs nil)

  (format t "~%~%Weight item~%~%")
  (sgp :pt nil)
  (1-w)
  (sgp :pt t)
  (1-w)

  (format t "~%~%Distance item~%~%")
  (sgp :pt nil)
  (1-d)
  (sgp :pt t)
  (1-d)

  (format t "~%~%Balance item~%~%")
  (sgp :pt nil)
  (1-b)
  (sgp :pt t)
  (1-b)

  (format t "~%~%Conflict distance item~%~%")
  (sgp :pt nil)
  (1-cd)
  (sgp :pt t)
  (1-cd)


  (sgp :epl t :pl t :egs 0.25)
)

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

(defun cd-t (n)
  (let ((**present-func** 'present-cd-stimulus))
    (do-it n t nil nil)))

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