;Call (do-n n) where n is the number of replications of the experiment (defun initialize () (defparameter a2 nil) (defparameter a1 nil) (defparameter e2 nil) (defparameter e1 nil) (defparameter *t* 1) (defparameter *fail* 0) (defparameter *success* 2.0) (defparameter *alpha* .2) (defparameter *a-val* 0) (defparameter *b-val* 0)) (initialize) (defparameter runs nil) (defparameter 6flag nil) (defparameter cont nil) (defparameter *sequences1* '( ((B A B B B B B B B B B B) (A B B B B B B B B B B B) (B B B B B B A B B B B B) (B B B B B B B B B B B B)) ((B B B B B B B B A B B B) (B B B B B B B B B B B B) (B B A B B B B A A B A A) (B B B B A B B B B A B A)) ((B A B B A A B B A B B B) (B A B B B A B A B B B B) (B B A B A A A A A B B A) (B B B B A B B A B A B A)) ((A B A A A B A B B B B B) (B A A B A B A B B B B B) (B B B B B B B B A A B B) (B B B B A B B B A B B B)) ((A A A A A B A B A B A B) (A B B A B A A B A B A A) (B A A B A B A B A B A A) (A A B B B A A A A A A A)) ((A A B A A A B A A A A B) (B B A A A A A B A A A B) (A A B A A A B B A A A A) (A A B A A A A A A A B A)) ((B B A B A B B A B A A A) (A A A A A A A A A A A B) (A B B B A A A A B A A B) (A A A A A A A A B A B A)) ((A A B A A A A A A A A A) (A A A A A A A A A A A A) (A A A A A A A A B A A A) (A A A B A A A A A A A A)))) (defparameter *sequences2* '( ((B B B B B B A B B B B B) (B B B B B B B B B A B B) (B B B B B B A B B B B B) (B B B B B A B B B A B B)) ((A B B B B A B B B A B B) (B B B A B B B B B B B B) (B A B B A B B B B B B B) (B B B A B A A B B B B B)) ((B A B A A B A A B B B A) (A B B B B A B B B B B A) (A B B B B B B B A B B B) (B B B A B B B A B B A B)) ((B A B B A A A A A B B A) (B B A A B A A A B B B A) (A A A B A A B B A B B B) (A B A B A B A B A B B A)) ((A A A B B A A A A B B A) (A A B A B A B A B A A A) (B B A A B A B A B A B A) (A B A A B B B B A B B A)) ((A B A A B B A A B A B A) (A B A A A A B A A B A A) (A A A A A B A B A A B A) (A A B A A B A A A A B A)) ((B A A A A A B A A A A A) (A A A A A A A A A A A A) (A A A A A A A A A A A A) (A A A A A B A A B A A B)) ((A A A A A A A A A A A A) (A A A A A A A A B A B A) (A A A A A A A A A B A A) (B A A A A A A B B A A B)))) (defparameter *means* '( 5.39 5.90 5.82 5.87 4.02 2.72 2.11 1.79 5.55 5.94 5.80 5.76 4.40 3.14 3.49 3.75 5.02 5.79 5.51 5.42 5.82 4.90 5.22 4.14 5.05 5.36 5.79 5.46 5.50 5.30 4.61 4.61 4.81 5.65 5.52 5.11 6.66 6.17 6.19 6.20 5.99 5.77 5.81 5.72 6.02 6.36 7.01 7.45 6.19 5.91 5.80 6.17 6.04 9.09 8.84 8.72 6.74 6.69 6.10 5.49 7.95 9.38 9.41 9.42 6.64 6.05 5.84 5.68)) (defparameter *orders* '((3 4 1 0 5 7 2 6) (4 1 3 0 5 7 6 2) (7 6 1 3 2 4 5 0) (2 6 3 7 4 5 0 1) (7 4 2 5 1 3 6 0) (6 1 7 2 0 4 5 3) (7 2 3 6 1 0 4 5) (3 7 6 5 0 4 2 1) (1 3 6 5 2 0 4 7) (5 1 7 2 6 4 3 0))) (defun gen-48 (p) (do ((i 0 (1+ i)) (result nil (cons (gen-12 p) result))) ((= i 4) result))) (defun gen-12 (p) (do ((i 0 (1+ i)) (result nil (cons (if (< (random 1.0) p) 'a 'b) result))) ((= i 12) result))) (defun do-n (n) (setf runs (make-array '(25 2) :initial-element 0)) (setf cont (make-array '(2 2 2 2 2) :initial-element 0)) (do ((i 1 (1+ i)) (result (80-subjs) (mapcar 'append (80-subjs) result))) ((= i n) (statistics result)))) (defun stats (lis) (do ((temp lis (cdr temp)) (sum 0 (+ sum (car temp))) (ssq 0 (+ ssq (* (car temp) (car temp))))) ((null temp) (list (/ sum (length lis)) (/ (- ssq (/ (* sum sum) (length lis))) (1- (length lis))))))) (defun statistics (result) (princ "The means for the 68 blocks: ") (do ((temp (mapcar 'stats result) (cdr temp))) ((null temp) nil) (print (caar temp))) (terpri) (princ "Run information:") (terpri) (do ((i 1 (1+ i))) ((= i 25) nil) (princ (format nil "Length = ~A, N = ~A, P = ~4,2F" (if (< i 5) (- i 5) (- i 4)) (+ (aref runs i 0)(aref runs i 1)) (If (zerop (+ (aref runs i 0)(aref runs i 1))) 0 (/ (aref runs i 1) (+ (aref runs i 0)(aref runs i 1)))))) (terpri)) (do ((i 0 (1+ i))) ((= i 2) nil) (do ((j 0 (1+ j))) ((= j 2) nil) (do ((k 0 (1+ k))) ((= k 2) nil) (do ((l 0 (1+ l))) ((= l 2) nil) (do ((m 0 (1+ m))) ((= m 2) nil) (terpri) (princ (format nil "C-2 = ~A, F-2 = ~A, C-1 = ~A, F-1 = ~A, C0 = ~A, N = ~A" (if (= i 0) "R" "L") (if (= j 0) "R" "L") (if (= k 0) "R" "L") (if (= l 0) "R" "L") (if (= m 0) "R" "L") (aref cont i j k l m))))))))) (defun gen-seq (lis) (let (result temp (count 0)) (loop (cond ((= count 12) (setf result (cons (reverse temp) result)) (setf temp nil) (if (null lis) (return (reverse result)) (setf count 0)))) (setf temp (cons (car lis) temp)) (incf count) (setf lis (cdr lis))))) (defun 80-subjs () (mapcar 'append (full-design) (full-design) (full-design) (full-design))) (defun full-design () (mapcar 'append (half-design *sequences1*) (half-design *sequences2*))) (defun half-design (seq) (do ((temp (cdr *orders*) (cdr temp)) (result (mapcar 'list (do-experiment (car *orders*) seq)) (mapcar 'cons (do-experiment (car temp) seq) result))) ((null temp) result))) (defun do-experiment (cond lis) (initialize) (setf 6flag nil) (do ((temp cond (cdr temp)) (result (list (do-sequence (gen-48 .5))) (append result (list (list (car temp) (append (do-sequence (nth (car temp) lis)) (do-sequence (gen-48 .5)))))))) ((null temp) (run-6) (apply 'append (cons (car result) (mapcar 'cadr (sort (cdr result) '< :key 'car))))))) (defun do-sequence (seq) (mapcar 'do-block seq)) (defun run-6 () (setf 6flag 0) (do ((i 0 (1+ i))) ((= i 6) nil) (do-sequence (gen-48 .8)))) (defun do-block (lis) (do ((temp lis (cdr temp)) (count 0 (+ count (do-trial (car temp))))) ((null temp) (/ count 1.0)))) (defun do-trial (item) (let ((result (if (> (prob (- *a-val* *b-val*)) (random 1.0)) 1 0))) (setf *b-val* (if (equal item 'b) (increase *b-val*) (decrease *b-val*))) (setf *a-val* (if (equal item 'a) (increase *a-val*) (decrease *a-val*))) (cond (6flag (if (and a2 a1) (incf (aref cont a2 e2 a1 e1 (- 1 result)))) (setf a2 a1) (setf e2 e1) (setf a1 (- 1 result)) (setf e1 (if (eq item 'a) 0 1)) (cond ((eq item 'a) (if (and (< 6flag 25) (> 6flag 0)) (incf (aref runs 6flag result))) (if (> 6flag 4)(incf 6flag) (setf 6flag 5))) (t (if (and (< 6flag 25) (> 6flag 0)) (incf (aref runs 6flag result))) (if (< 6flag 5) (decf 6flag) (setf 6flag 4)))))) result)) (defun prob (dif) (/ 1 (+ 1 (exp (/ (- dif) *t*))))) (defun decrease (val) (+ (* (- 1 *ALPHA*) VAL) (* *alpha* *fail*))) (defun increase (val) (+ (* (- 1 *ALPHA*) VAL) (* *alpha* *success*)))