; TI PC-Scheme compatability for Ibuki Common LISP
;    
;    Bruce MacLennan
;    Department of Computer Science
;    107 Ayres Hall
;    The University of Tennessee
;    Knoxville, TN 37996-1301
;    
;    (423)974-0994/5067
;    maclennan@cs.utk.edu

(defmacro define (ndum iens &rest rem)
  (if (atom ndum) `(defvar ,ndum ,iens)
                  (append `(defun ,(car ndum) ,(cdr ndum) ,iens) rem)))
(define implementation "Ibuki on Sun")
(define false nil)
(define else t)
(define pcs-debug-mode '())
(define saved-state '())

(define (-1+ x) (1- x))
(define (modulo m n) (mod m n))
(defmacro make-vector (n &optional x) `(make-array ,n :initial-element ,x))
(define (vector-ref v k) (aref v k))
(define (vector-set! v k x) (setf (aref v k) x))
(define (null? x) (null x))
(define (equal? x y) (equal x y))

(defmacro set! (x y) `(setq ,x ,y))

; Minimal Standard Random Number Generator
; Park & Miller, CACM 31, 10.
;(define ranf-seed 1) ; value must be in [1..ranf-m]
;(define ranf-m 2147483647)
;(define ranf-a 16807)
;(define (ranf)
;  (set! ranf-seed (modulo (* ranf-seed ranf-a) ranf-m))
;  (/ ranf-seed ranf-m)) 
;(define (random n) (floor (* (ranf) n)))

(define (set-video-mode! x) 'ignored)
(define (set-pen-color! x) (print (list 'pen 'color x)))
(define (position-pen x y) (print (list 'pen 'at x y)))
(define (draw-line-to x y) (print (list 'line 'to x y)))
(define (draw-point x y) (print (list 'point 'at x y)))
(define (clear-graphics) 'ignored)
(define (exit) (bye))

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

; exp1*.s - Experiment 1
;
;    Bruce MacLennan
;    Department of Computer Science
;    107 Ayres Hall
;    The University of Tennessee
;    Knoxville, TN 37996-1301
;    
;    (423)974-0994/5067
;    maclennan@cs.utk.edu
;
; 90/02/19; revised 90/05/16

(define prog-name "exp1bi.l")
(define mu 0.01)
(define max-gens 10000)
(define env-cycles 5)
(define env-delay 10)
(define state-size 0)
(define no-states (expt 2 state-size))
(define glo-state-size 3)
(define no-glo-states (expt 2 glo-state-size))
(define loc-state-size 3)
(define no-loc-states (expt 2 loc-state-size))
(define action-size 3)
(define no-actions (expt 2 action-size))
(define population 100)
(define emission-reward 1)
(define reception-reward 1)
(define max-comms (* env-cycles env-delay population))
(define window-size 50)
(define plot-interval 20)
(define emiss-corr 0)
(define generation 0)
(define global-env '())
(define genomes '())
(define bodies '())
(define state '())
(define local-envs '())
(define fitness '())
(define action '())
(define last-emittor 0)
(define emissions false)
(define comm-counted false)
(define no-emissions 0)
(define no-receptions 0)
(define no-comms 0)
(define org-cause '())
(define correl '())
(define correl-cycle 0)
(define af-window '())
(define bf-window '())
(define fitness-window '())
(define mean-fit '())
(define log-file-name "results.log")
(define log-file '())
(define dump-file-name "bodies.dmp")
(define dump-file '())
(define plot-file-name "fitness.plt")
(define plot-file '())
(define dict-file-name "dictionaries")
(define dict-file '())
(define response-size (max action-size glo-state-size))
(define no-responses (max no-actions no-glo-states))
(define no-chromos (* no-states no-glo-states no-loc-states))
(define chromo-size (+ state-size 1 response-size))
(define genome-size 3)
(define seed 0)

(define left-x -160)
(define upper-y 100)
(define x-size 320)
(define y-size 200)
(define g-orig (+ left-x 10))
(define l-orig (+ g-orig glo-state-size 10))
(define l-width (1+ loc-state-size))
(define a-orig (+ l-orig (* population l-width) 9))
(define a-width (+ 2 action-size))
(define s-orig (+ a-orig (* population a-width) 9))
(define s-width (1+ state-size))
(define f-orig (+ s-orig (* population s-width) 9))
(define f-width 20)

(define disconnect false)
(define suppress false)
(define learning false)
(define print-global-env false)
(define print-local-envs false)
(define print-sound false)
(define print-org-fitness false)
(define print-summary-fitness false)
(define print-avg-fitness false)
(define print-fitness-means false)
(define print-actions false)
(define print-xitions false)
(define print-signaler false)
(define print-comms false)
(define print-correl false)
(define print-comm-ratio false)
(define print-variation false)
(define print-fitness-window false)
(define print-breeders false)
(define plot-af false)
(define plot-bf false)
(define plot-maf false)
(define plot-mbf false)
(define write-plot false)
(define graphics-1 false)
(define fsearch-monitor false)
(define write-log t)
(define dump-bodies false)
(define write-dict false)

(define af 0)
(define bf 0)
(define bo 0)
(define sbf 0)
(define sbo 0)
(define tf 0)
(define wf 1)
(define wo 0)
(define so 0)
(define sf 0)
(define env-ctr 0)

(define (initialize)
  (do ((k 0 (1+ k))) ((>= k seed))  (ran))
  (set! write-plot (or plot-af plot-bf plot-maf plot-mbf))
  (set! global-env (random no-glo-states))
  (set! genomes (make-vector population))
  (set! bodies (make-vector population))
  (set! state (make-vector population))
  (set! action (make-vector population))
  (set! local-envs (make-vector population))
  (next-env)
  (do ((org 0 (1+ org))) ((>= org population))
      (vector-set! state org (random no-states))
      (let ((G (random-genome)))
        (vector-set! genomes org G)
        (vector-set! bodies org (phenotype G))))
  (set! no-emissions 0)
  (set! no-receptions 0)
  (set! no-comms 0)
  (set! af-window (make-vector window-size))
  (set! bf-window (make-vector window-size))
  (set! fitness-window (make-vector window-size))
  (set! correl (make-vector window-size))
  'done)

(define (random-genome)
  (let ((G (make-vector no-chromos)))
    (do ((k 0 (1+ k))) ((>= k no-chromos) G)
	(let* ((s (random no-states))
	       (f (random 2))
	       (a (if (and (= 1 f) (<= (ran) emiss-corr)) s 
		      (random no-responses))))
	      (vector-set! G k (list s f a))))))

(define (run)
  (if write-plot (set! plot-file (open plot-file-name :direction :output)))
  (cond (graphics-1 (set-video-mode! 4) (clear-graphics)))
  (do ((gener 0 (1+ gener))) ((>= gener max-gens))
      (set! generation (1+ generation))
      (set! correl-cycle (modulo (1+ correl-cycle) window-size))
      (let ((corrc (make-vector no-glo-states)))
        (vector-set! correl correl-cycle corrc)
        (do ((s 0 (1+ s))) ((>= s no-glo-states))
            (vector-set! corrc s (make-vector no-loc-states 0))))
      (vector-set! fitness-window correl-cycle 
		   (make-vector population 0))
      (evaluate-fitness gener)
      (if print-summary-fitness
          (print (list generation 'best bo (list bf)
            '2nd 'best sbo (list sbf) 'worst wo (list wf))))
      (if print-comm-ratio
          (print (list generation 'comm '= no-comms 'emiss '= no-emissions
		       'comm/emiss '= (float (/ no-comms no-emissions))
                       'recep '= no-receptions)))
      (if (and print-variation (>= generation window-size))
	  (let ((sv (variation))) 
	       (print (list generation 'sigma '= (car sv) 
			    'V '= (cadr sv)))))
      (if (and write-plot (= 0 (mod generation plot-interval)))
	  (write-plot-fitness))
      (set! global-env 0)
      (set! emissions false)
      (breed))
  (if write-plot (close plot-file))
  (if write-log (generate-log-file log-file-name))
  (cond (dump-bodies 
        (set! dump-file (open dump-file-name :direction :output))
	(print (list 'set! 'bo bo) dump-file)
	(print (list 'set! 'sbo sbo) dump-file)
        (print (list 'set! 'bodies bodies) dump-file)
        (close dump-file)))
  (if write-dict (generate-dict-file))
  (list max-gens 'generations 'completed))

(define (evaluate-fitness gener)
  (set! fitness (make-vector population 0))
  (do ((env-no 0 (1+ env-no))) ((>= env-no env-cycles))
      (next-env)
      (do ((time 0 (1+ time))) ((>= time env-delay))
          (if print-sound
              (print (list generation env-no time env-ctr
                           (vector-ref local-envs env-ctr))))
          (all-behave env-no time)
          (if graphics-1 (plot-state (+ (* gener env-cycles) env-no) time))))
  (update-eval (* (1+ gener) env-cycles env-delay)))

(define (next-env)
  (do ((org 0 (1+ org))) ((>= org population))
      (vector-set! local-envs org (random no-loc-states)))
  (if print-local-envs (print local-envs)))

(define (all-behave env-no time)
  (do ((org 0 (1+ org))) ((>= org population))
      (eval-act org (act-of org))
      (if print-org-fitness
          (print (list (list generation env-no time)
                       org 'fitness '= (vector-ref fitness org))))
      (if print-sound (princ global-env))
      (if print-global-env
          (print (list (list generation env-no time)
                       org 'global-env '= global-env)))))


(define (update-eval time)
    (set! tf 0)
    (set! bf -1) (set! sbf -1) (set! wf 2) ; "infinite" values
    (do ((o 0 (1+ o))) ((>= o population))
        (let ((f (vector-ref fitness o)))
          (set! tf (+ tf f))
	  (vector-set! (vector-ref fitness-window correl-cycle) o f)
          (cond ((>= f bf)
                 (set! so bo) (set! sf bf) (set! bo o) (set! bf f)
                 (cond ((>= sf sbf) (set! sbo so) (set! sbf sf))))
                ((>= f sbf) (set! sbo o) (set! sbf f)))
          (cond ((<= f wf) (set! wo o) (set! wf f)))))
    (set! af (float (/ tf population)))
    (vector-set! af-window correl-cycle af)
    (vector-set! bf-window correl-cycle bf)
    (if print-avg-fitness (print (list generation 'avg-fitness '= af)))
    (if (and print-fitness-window (>= generation window-size))
	(print (list generation 'fitness 'window (ev-fitness-window))))
    (if (and print-fitness-means (>= generation window-size))
      (let ((v (fitness-means))) 
           (print (list generation 'maf '= (car v) 'mbf '= (cadr v)))))
    (if graphics-1 (plot-fitness time)))

(define (eval-act org phi-alpha)
  (let ((phi (car phi-alpha)) (alpha (cadr phi-alpha)))
    (if print-actions (print (list org 'does phi alpha)))
    (if (and (= 0 phi) emissions)
        (let ((lele (vector-ref local-envs last-emittor)))
          (cond ((equal? (mod alpha no-actions) lele)
                 (incr-fitness last-emittor emission-reward) 
		 (incr-fitness org reception-reward)
                 (let* ((pair (list global-env lele))
                        (row (vector-ref (vector-ref correl correl-cycle)
                                         global-env))
                        (c lele))
                   (cond ((not comm-counted)
                          (set! no-comms (1+ no-comms))
                          (set! comm-counted t)))
                   (set! no-receptions (1+ no-receptions))
                   (vector-set! row c (1+ (vector-ref row c)))
                   (if print-correl (print correl))
                   (if print-comms
                       (print (list 'com last-emittor '-> org pair
                                    (float (/ no-comms no-emissions)))))
                   ))
		(learning (teach org lele)))))))

(define (incr-fitness org reward)
  (vector-set! fitness org (+ (vector-ref fitness org) reward)))

(define (teach org action)
  (let* ((body (vector-ref bodies org))
	 (rule (vector-ref body org-cause))) 
	(vector-set! body org-cause 
		     (list (car rule) 0 action))))

(define (breed)
  (let* ((orgs (find-parents))
         (G (possible-mutation
              (crossover (vector-ref genomes (car orgs))
                         (vector-ref genomes (cadr orgs)))))
         (wo (caddr orgs)))
    (vector-set! genomes wo G)
    (vector-set! bodies wo (phenotype G))))

(define (find-parents)
  (let* ((father (fsearch t (random population)))
         (mother (fsearch t father))
         (deceased (fsearch false mother)))
    (if print-breeders
      (print (list 'father father 'mother mother 'deceased deceased)))
    (list father mother deceased)))

(define (fsearch criterion start)
  (do* ((o (mod (1+ start) population) (mod (1+ o) population))
        (sp 0 (+ sp p))
        (p (fitness-prob criterion (vector-ref fitness o))
           (fitness-prob criterion (vector-ref fitness o))))
       ((< (ran) (/ p (- 1 sp))) o)
     (if fsearch-monitor
       (print (list 'fsearch criterion start o p sp)))))

(define (fitness-prob criterion fk)
  (if criterion 
      (if (= 0 tf) (float (/ 1 population)) (float (/ fk tf)))
      (let ((pbf (* population bf)))
	   (if (= tf pbf) 
	       (float (/ 1 population)) 
	       (float (/ (- bf fk) (- pbf tf)))))))

(define (phenotype G) G)

(define (act-of org)
  (let* ((le (vector-ref local-envs org))
         (st (vector-ref state org))
         (k (+ st (* no-states (+ le (* global-env no-loc-states)))))
         (r (vector-ref (vector-ref bodies org) k))
	 (f (phi-part r))
         (a (alpha-part r)))
    (vector-set! action org a)
    (vector-set! state org (nu-part r))
    (set! org-cause k)
    (cond ((= 1 f)
	   (set! global-env 
		 (if disconnect (random no-glo-states) 
		     (mod a no-glo-states)))
           (set! last-emittor org)
           (set! comm-counted false)
           (set! no-emissions (1+ no-emissions))
	   (set! emissions t)
           (if print-signaler (print (list org 'emits global-env)))))
    (if suppress (set! global-env (random no-glo-states)))
    (if print-xitions 
        (print (list org 'xition (list global-env le st)
		     '=> (nu-part r) f a)))
    (list f a)))

(define (nu-part r) (car r))

(define (phi-part r) (cadr r))

(define (alpha-part r) (caddr r))

(define (crossover F H)
  (let* ((G (make-vector no-chromos))
         (r1 (random no-chromos))
         (r2 (random no-chromos))
         (rmin (min r1 r2))
         (rmax (max r1 r2)))
    (do ((c 0 (1+ c))) ((>= c no-chromos) G)
        (cond ((< c rmin)
               (vector-set! G c (vector-ref F c)))
              ((< c rmax)
               (vector-set! G c (vector-ref H c)))
              (else
                (vector-set! G c (vector-ref F c)))))))

(define (possible-mutation G)
  (cond ((> (ran) mu) G)
        (else (let ((x (random no-chromos)))
                (vector-set! G x 
			     (list (random no-states)
				   (random 2)
				   (random no-responses)))
                G))))

(define (ran) (float (/ (random 100000) 100000)))

(define (save-state)
  (set! saved-state (make-vector 6))
  (vector-set! saved-state 0 local-envs)
  (vector-set! saved-state 1 genomes)
  (vector-set! saved-state 2 bodies)
  (vector-set! saved-state 3 state)
  (vector-set! saved-state 4 global-env)
  (vector-set! saved-state 5 env-ctr)
  t)

(define (restore-state)
  (set! local-envs (vector-ref saved-state 0))
  (set! genomes (vector-ref saved-state 1))
  (set! bodies (vector-ref saved-state 2))
  (set! state (vector-ref saved-state 3))
  (set! global-env (vector-ref saved-state 4))
  (set! env-ctr (vector-ref saved-state 5))
  t)

(define (plot-state env-no time)
  (let ((y (- upper-y (modulo (+ (* env-no env-delay) time) y-size))))
    (set-pen-color! 0)
    (position-pen left-x y) (draw-line-to (+ left-x x-size) y)
    (cond ((> y (- upper-y y-size -1))
           (set-pen-color! 2)
           (position-pen left-x (-1+ y))
           (draw-line-to (+ left-x x-size) (-1+ y))))
    (set-pen-color! 1)
    (plot-bits global-env glo-state-size g-orig y)
    (do ((p 0 (1+ p))) ((>= p population))
        (plot-bits (vector-ref local-envs p) loc-state-size
                   (+ l-orig (* p l-width)) y)
        (plot-bits (vector-ref action p) action-size
                   (+ a-orig (* p a-width)) y)
        (plot-bits (vector-ref state p) state-size
                   (+ s-orig (* p s-width)) y))
    (set-pen-color! 2)
    (draw-point (-1+ g-orig) y)
    (draw-point (-1+ l-orig) y)
    (draw-point (-1+ a-orig) y)
    (draw-point (-1+ s-orig) y)
    (draw-point (-1+ f-orig) y)
    (draw-point (+ f-orig f-width 1) y)))

(define (plot-fitness time)
  (define y (- upper-y (modulo (- time 1) y-size)))
  (set-pen-color! 2)
  (draw-point (+ f-orig (round (/ f-width 2))) y)
  (set-pen-color! 1)
  (draw-point (+ f-orig (round (* af f-width))) y)
  (draw-point (+ f-orig (round (* bf f-width))) y))

(define (plot-bits s len x y)
  (cond ((not (null? s))
         (if (= 1 (car s)) (draw-point x y))
         (plot-bits (cdr s) (-1+ len) (1+ x) y))
        (else (set-pen-color! 2) (draw-point x y) (set-pen-color! 1))))

(define (vidrst) (set-video-mode! 2))

(define (correl-window)
  (let((cw (make-vector no-glo-states)))
    (do ((g 0 (1+ g))) ((>= g no-glo-states) cw)
        (let ((r (make-vector no-loc-states 0)))
          (do ((k 0 (1+ k))) ((>= k no-loc-states))
              (do ((c 0 (1+ c))) ((>= c window-size))
                  (vector-set! r k (+ (vector-ref r k)
                     (vector-ref (vector-ref (vector-ref correl c) g) k)))))
          (vector-set! cw g r)))))

(define (variation)
  (let ((tc 0) (N (* no-glo-states no-loc-states)) (ts 0)
	(sigma 0) (V 0) (i 0) (j 0)
	(cw (correl-window)) (mean 0))
       (do ((i 0 (1+ i))) ((>= i no-glo-states))
	   (let ((cr (vector-ref cw i)))
		(do ((j 0 (1+ j))) ((>= j no-loc-states))
		    (set! tc (+ tc (vector-ref cr j))))))
       (set! mean (float (/ tc N)))
       (do ((i 0 (1+ i))) ((>= i no-glo-states))
	   (let ((cr (vector-ref cw i)))
		(do ((j 0 (1+ j))) ((>= j no-loc-states)) 
		    (set! ts (+ ts (expt (- (vector-ref cr j) mean) 
					 2))))))
       (set! sigma (sqrt (/ (float ts) N)))
       (list sigma 
	     (if (= 0 mean) 'infinity (/ sigma mean)))))

(define (fitness-means)
  (if (< generation window-size) '(0 0) 
      (let ((taf 0) (tbf 0) (i 0)) 
	   (do ((i 0 (1+ i))) ((>= i window-size) 
			       (list (float (/ taf window-size))
				     (float (/ tbf window-size))))
	       (set! taf (+ taf (vector-ref af-window i))) 
	       (set! tbf (+ tbf (vector-ref bf-window i)))))))

(define (ev-fitness-window) 
  (set! mean-fit (efw 0)))

(define (efw org)
  (if (>= org population) nil
      (cons 
       (let ((total 0)) 
	    (do ((k 0 (1+ k))) 
		((>= k window-size) (float (/ total population)))
		(set! total (+ total 
			       (vector-ref (vector-ref fitness-window k) 
					   org)))))
       (efw (1+ org)))))

(define (write-plot-fitness)
  (print generation plot-file)
  (prinf plot-af af) 
  (prinf plot-bf bf) 
  (prinf plot-maf (car (fitness-means))) 
  (prinf plot-mbf (cadr (fitness-means))))

(define (prinf flg f)
  (cond (flg (princ "	" plot-file) (princ f plot-file))))

(define (generate-log-file log-file-name)
  (set! log-file (open log-file-name :direction :output))
  (print (list 'experiment '= log-file-name) log-file)
  (print (list 'program '= prog-name 'on implementation) log-file)
  (print (list 'population '= population) log-file)
  (print (list 'gens '= generation) log-file)
  (print (list 'window-size '= window-size) log-file)
  (print (list 'seed '= seed) log-file)
  (print (list 'communication 
	       (if suppress 'suppressed 'permitted) 'and
	       (if disconnect 'disconnected 'connected)) log-file)
  (print (list 'learning (if learning 'enabled 'disabled)) log-file)
  (print (list 'last 'avg 'fitness '= af) log-file)
  (print (list 'last 'best 'fitness '= bf) log-file)
  (let ((fms (fitness-means)))
       (print (list 'mean 'avg 'fitness '= (car fms)) log-file)
       (print (list 'mean 'best 'fitness '= (cadr fms)) log-file))
  (print (list 'comm '= no-comms) log-file)
  (print (list 'emiss '= no-emissions) log-file)
  (print (list 'c/e '= (float (/ no-comms no-emissions))) log-file)
  (let ((sv (variation)))
       (print (list 'sigma '= (car sv)) log-file)
       (print (list 'coef-var '= (cadr sv)) log-file))
  (print 'fitness-window log-file)
  (write (ev-fitness-window) :stream log-file :pretty t)
  (print 'cw log-file)
  (let ((cw (correl-window))) 
       (do ((k 0 (1+ k))) ((>= k no-glo-states))
	   (print (list k '-> (vector-ref cw k)) log-file)) 
       (let* ((H (entropy2 cw)) 
	      (eta (-1+ (/ H loc-state-size)))) 
	     (print (list 'H '= H
		    'H-max '= (+ glo-state-size loc-state-size)
		    'eta '= eta) 
		    log-file)
	     )
       )
  (close log-file))

(define (generate-dict-file)
  (set! dict-file (open dict-file-name :direction :output))
  (do ((org 0 (1+ org))) ((>= org population)) 
      (let ((b (vector-ref bodies org))) 
	   (print (list 'org org 'fitness (vector-ref fitness org)
			'mean 'fitness (elt mean-fit org)) 
		  dict-file)
	   (print (list 'reception 'dictionary) dict-file) 
	   (do ((g 0 (1+ g))) ((>= g no-glo-states))
	       (print '> dict-file)
	       (do ((l 0 (1+ l))) ((>= l no-loc-states))
		   (do ((s 0 (1+ s))) ((>= s no-states))
		       (princ (get-act b g l s) dict-file)
		       )
		   )
	       )
	   (print (list 'emission 'dictionary) dict-file)
	   (do ((l 0 (1+ l))) ((>= l no-loc-states))
	       (print '> dict-file)
	       (do ((g 0 (1+ g))) ((>= g no-glo-states))
		   (do ((s 0 (1+ s))) ((>= s no-states))
		       (princ (get-act b g l s) dict-file)
		       )
		   )
	       )
	   )
      )
  (close dict-file))

(define (entropy2 M)
  (let ((C 0) (sm 0)) 
       (do ((g 0 (1+ g))) 
	   ((>= g no-glo-states) 
	    (- (log C 2) (/ sm C))) 
	   (let ((row (vector-ref M g))) 
		(do ((l 0 (1+ l))) ((>= l no-loc-states))
		    (let ((n (vector-ref row l)))
			 (set! C (+ C n))
			 (if (plusp n) (set! sm (+ sm (* n (log n 2)))))
			 ))))))

(define (get-act b g l s)
  (vector-ref b (+ s (* no-states (+ l (* g no-loc-states))))))

(define (batchrun lf df)
  (set! log-file-name lf)
  (set! suppress df)
  (initialize)
  (run)
  (exit))

(define (plotrun lf pf df)
  (set! plot-file-name pf)
  (set! plot-maf t)
  (set! plot-mbf t)
  (batchrun lf df))