A Genetic-Algorithm systerm for evolving emergent behaviors in Turing machines.

A Foxes & Rabbits Simulation

by

Matthew Scott

 

      This Scheme based program can be used to discover the dynamics of colonies of autonomous robots (Turing Machines) in

a closed but complex environment. The machines start out with a random behaviour and quickly evolve (via cross-over genetic reproduction) to optimize their energy function (fitness) on the environment.

 

     This implementation also demonstrates a Lotka-Voltera ‘predator-prey’ dynamic in populations.  (From Wikipedia)

 

\frac{dx}{dt} = x(\alpha - \beta y)

\frac{dy}{dt} = - y(\gamma - \delta  x)

 

where

;====================================================================================

 

  

     Initial random placement of machines, plants, food.                     Half an hour later. The colonies are all migrating in groups.

 

ga.s

;====================================================================================

;Author: Matthew Scott

;Life, Turing machines, Genetic Algorithms and the modeling of eco-systems.

;This code is configured for MIT Scheme 7.4 running under X Windows.

 

;To invoke just load it.

;search forward to $$$ for the beginning of documentation

;====================================================================================

;(trace-output-port)

 

(define set-trace

  (lambda ()

    (set! trace-set #t)))

 

(define env-width 240)    ; Width of env array

(define env-height 128)    ; Height of array

;(define env-width 120)    ; Width of env array

;(define env-height 64)    ; Height of array

(define senile-age 500.0)   ; Death age

(define cell-size 10.0)   ; Tm box size

(define cell-mid (/ cell-size 2))   ; Tm box size

(define plant-size 5.0)   ; Tm box size

(define food-factor 1)

(define replicate-point 200.0) ;Min replication age

(define maturity-age 20.0)  ; Min reproductive age

(define mate-factor .3)   ; See equation

(define mate-cost 15.0)     ; Energy to mate

(define baby-str 30.0)      ; Initial energy level

(define menopause 400.0)    ; Max reproductive age

(define plant-value 10.0)   ; Gain from eating plant

(define bit-value 1.2)      ; Gain from taking a bit

(define bit-cost 2.0)       ; Cost of writing a bit (fertilizing)

(define max-pop 60.0)

(define min-pop 10.0)

(define sav-elite 5.0)

(define starvation 0.0)     ; die if this weak

(define kill-bonus 3.0)

(define mutate-rate 5)     ; 5/100

 

 

(define on  0)            ;draw mode code

(define off 15)            ;draw mode code

 

 

;(if (null? (graphics-type-available? 'win32))

;((begin

(define x-geom (x-geometry-string (* env-width cell-size) (* env-height cell-size) #f #f))

   (define grid (make-graphics-device 'x  "it:0.0" x-geom))

;)))

 

;;(if (null? (graphics-type-available? 'x))

   ;;(define grid (make-graphics-device 'win32))

;;)

 

   (graphics-set-coordinate-limits grid 0.0 (* env-height cell-size)

                               (* env-width cell-size) 0.0)

   (graphics-operation grid 'set-foreground-color "white")

   (graphics-operation grid 'set-background-color "black")

 

   (graphics-clear grid)

 

 

;$$$

;In this program I am attempting to develop a means of using genetic

;algorithms to develop 'highly-fit' turing machines in a stable eco-system.

;By stable I mean that energy is conserved and the inhabitants stay within

; the bounds of extinction and over-population.

;The inhabitants are Pac (from the book by (A Clarke?)) and plants, both of which are

;described as turing machines.

;The turing machines will be described as a binary number.

;Consider the following Tm,

 

; q0 1 -> q0 1 R

; q0 0 -> q1 1 R

; q1 1 -> q0 1 L

; q1 0 -> q0 1 R

 

;Since the language has only two symbols, we know each state has only two

;options. Thus, we can delete the state ID symbols giving us,

 

; 1 0 1 Up

; 0 1 1 Down      Oh, by the way, the 'tape' is a 2 dimensional grid

; 1 0 1 Left      for the eco-system.

; 0 0 1 Right

 

;Of course, if we want our Tm to be described in binary then the 'next-state

;bits should all be the same length. That is, if the machine has eight states,

;then each machine should have each state look like,

 

; I XXX O DD

;'I' is a bit specifying input

;XXX is 000 -> 111 specifying the next-state

;'O' is a bit specifying the output

; and DD is the direction to move.

 

;We want DD to be binary, so lets say

;(L)eft=00, (R)ight=01, (U)p=10, and (D)own=11.

;Now the Tm above can be described as:

 

;  (0 0 1 1 0     1 1 1 1 1     0 0 1 0 0     1 0 0 1 1)

;   I X O D D     I X O D D     I X O D D     I X O D D

;q0,0->q0,1,U  q0,1->q1,1,D  q1,0->q0,1,L  q1,1->q0,0,D

 

;Oops, one more thing to get rid of. Since a state's defining characteristics

;are found by off-setting from the front of the list by (state# * N * 2) where

; 'N' is the number of bits required to define a state, then we would not have

;an effective procedure if the input bits got mutated or crossed. Obviously we

;should remove them since they are implicit in position too. So we have again:

 

;  (    0 1 1 0         1 1 1 1         0 1 0 0         0 1 1 1)

;       X O D D         X O D D         X O D D         X O D D

;q0,0->q0,1,U    q0,1->q1,1,D    q1,0->q0,1,L    q1,1->q0,0,D

 

;I will use gentemp to assign each new turing machine a name.

;The current state will be held in a record 'state# and

;The Tm's age will be held in record 'age

;and its strength value in 'str (strength ect described below)

(define num-states 8)

(define num-state-bits 8)

(define make-n-states

  (lambda (n)

    (if (zero? n) '()

            (cons (make-state)(make-n-states (- n 1))))))

(define make-state

  (lambda ()

    (list->vector (v1-list num-state-bits)))) ;six => XXXODD

(define Tm-list '());holds the names of the currently living Tm's

(define make-tm

  (lambda ()

    (let* ((Tm (list->vector (make-n-states (* 2 num-states))))

                  (Tm-name (Tm-make 0 baby-str mouse-posit Tm 0 0))

                  (x (* cell-size (car mouse-posit)))

                  (y (* cell-size (cadr mouse-posit))))

      (set! Tm-list (cons Tm-name Tm-list))

       (update-env mouse-posit (cons 'tm (cons tm-name '())) )

        (draw-tm Tm-name on)

      )))

;trace make-tm)

 

(define pl-list '())

 

;(L)eft=00, (R)ight=01, (U)p=10, and (D)own=11.

                                      ;next-state, output, direction

;if we do not make the state0 direction random then all the plants will tend

;to move in one direction

 

(define plant-def

  (let*(

         (rnd (if (even? (random 10)) 1 0))

         (v1 (cons 0 (cons 0 (cons 0 ( cons 0 (cons 0 (cons rnd '())))))))

       )

  (list->vector

    (cons (list->vector '(0 0 1  0   1 0))  ;0

    (cons (list->vector '(0 0 0  0   1 0))

 

    (cons (list->vector '(0 1 0  0   0 0))  ;1

    (cons (list->vector '(0 0 1  0   0 0))

 

    (cons (list->vector '(0 1 1  0   1 1))  ;2

    (cons (list->vector '(0 1 0  0   1 1))

 

    (cons (list->vector '(1 0 0  0   1 1))  ;3

    (cons (list->vector '(0 1 1  0   1 1))

 

    (cons (list->vector '(1 0 1  0   0 1))  ;4

    (cons (list->vector '(1 0 0  0   0 1))

 

    (cons (list->vector '(1 1 0  0   0 1))  ;5

    (cons (list->vector '(1 0 1  0   0 1))

 

    (cons (list->vector '(1 1 1  0   0 1))  ;6

    (cons (list->vector '(1 1 0  0   0 1))

 

    (cons (list->vector '(0 0 0  0   1 0))  ;7

    (cons (list->vector '(1 1 1  0   1 0))

 

              '())))))))))))))))))))

 

 

(define make-plant

  (lambda (posit)

    (let* (

      (plant-name (Tm-make 0 0 posit plant-def 0 0))

              (x (* cell-size (car posit)))

              (y (* cell-size (cadr posit))))

      (set! pl-list (cons plant-name pl-list))

      (update-env posit (cons 'pl (cons plant-name '())) )

      (draw-plant plant-name on)

      ;(draw-word 'y x y 6)

      )))

 

;trace make-plant)

 

 

;Using the GA tactic requires that the matings cause a gradient descent toward

;the optima (possibly a local minima/optima).

;For a turing machine, the optima desired can be described in terms of the

;output or may be based on intrisic properties of the Tm. I had at first

;endeavored to use the GA technique to evolve Tm's that would fit certain

;logical operations. As with the finite automata where I showed the manner

;in which one could describe any logical operation on two bits with a two

;state automata, one can do the same with a two state Tm. But, on further

;consideration, it became apparent to me that changing any bit in a Tm will

;drastically alter its behaviour. On a topological map describing the

;possible ways in which our two state Tm can solve the desired logical

;operation (the map is a surface that resides in the phase space of the Tm,

;its valleys are 'efficient Tm's, its hills are inefficient Tm's), each

;generation will NOT follow a semi-continuous gradient descent into a local

;optima=minima. Actually, I am fairly sure it will jump around randomly, most

;of the time not even on the map.

;Therefore, I must abstract the gradient descent out of the definition of the

;Tm and put it into the 'performance' of the tm in a certain environment.

;This gives every possible Tm a scaled value of performance, wherein the

;performance of a Tm expected to compute a logical function is zero for almost

;all of the possible permutations of its description.

 

 

;So, heres the plan.

;A) Make a pool of randomly (but correctly) defined turing machines.

;   Make it so the user can specify the number of Tm's in the start pool and

;   the number of states.

;   For an initial test I will have the number of states constant.

;   Later I will let the number of states vary, if this

;   seems interesting.

;B) Make an environment in which the Tm's live, forage, spawn, and die.

;   This environment will just be a 32x64 matrix containing zeros and ones.

;   I am keeping it small to increase the speed and reduce the number of

;   squares that must be checked each cycle.

;   Let no more than one Tm occupy a square at a time (for visibility).

;C) Make the eco-system user definable. Parameters are:

;   1) Number of cycles a Tm must be alive before it is mature.

 

;   2) The factors determining mating of two Tms:

;      a) They meet topologically (adjacent to each other).

;      b) Each has a strength greather than mating-strength.

;         I will make it such that a single Tm may replicate itself (with minor

;         mutations) if it has reached a replicating-strength. This may

;         help prevent extinction...since extinction is considered boring.

;      c) They have a degree of similarity >= sim-factor.

 

 

;   3) The factors determining death:

;      a) A Tm does not reproduce every 'x' cycles. This takes care of

;         age and strength simulaneously, but we would still like to have

;         mortal Tm's as this will increase the evolutionary rate (that is,

;         decrease the chance of stagnation), thus we will incorporate a

;         mortality-constant.

;      b) Two Tm's with similarity less than sim-factor meet. The Tm with

;         the greatest strength has a higher probability of winning.

 

;   4) The factors determining strength:

;      a) The number of plants a Tm has eaten.

;      b) The number of cycles a Tm has been alive.

;      ....These two variables will be combined in a function that describes

;          a curve like:         (food=> # of plants eaten)

;   10   |

;        |

;        |                             .

;        |                         . food=10.

;   ^    |replicating-strength--.---------------.----------

;   |    |                  .                      .

;strength|               .                            .

;        |            .              .  .  .             .

;   ^    |         .            . '  food=0  '  .           .

;   |    |-------.------.-------<-mating-strength->-----.------.---------

;        |     .   . '                                    '  .   .

;        |   . .                                                 . .

;        | .                                                         .

;   0    |_________________________________________________________________

;        age=0                                                age=mortality

;  increasing age --->

 

 

; You are probably wondering what a plant is. It is a Turing maching. But

; unlike our Pac Tm's, it does not mate. It is created, or should I say,

; 'sprouts from the ground' wherever there are three or more 1's surrounding

; a square. It's internal state machine directs it to run around eating ones,

; and leaving zeros behind it. When it cant find anymore ones it stops moving.

; You may have noticed a similarity to Conrad's 'Life'. But note that since the

; plant effectively digs its own grave, we do not need to have a death clause

; like 'a plant dies if it is surrounded by ....'.

; I guess I could have it die, but I think this would violate conservation of

; energy in the system.

; A smart plant-eating turing machine will learn to fertilize the ground a

; lot (ones = fertilizer), as this will increase the number of plants around

; it, thus increasing it's chance of reproducing. If it gets to be REALLY

; smart, I would think it would learn how to fertilize seperate patches of

; land such that a plant would only eat the 1's that caused it to sprout. This

; of course will increase the yeild of plants that a Tm can harvest.

; Naturally, by genetic diversity, the Tm's will form species. Hopefully these

; species will learn to kill each other (Yes, a little sadistic, but really its

; just capatalism). If I had time I would make it such that the Tm's could

; sense each other (scan the squares around them) and have this data go into

; the Tm's input bits on a few pre-determined states. Thus if a Tm gets into

; one of these states it will be looking around, not at the ground.

 

;to see a trace of the program enter (set-trace)

;type (cycle number dna fx3)

(define trace-set #t)

 

 

;The following procedures are used to build vector spaces

;Reference a square in the environment by (env-ref column# row#)

(define column (make-vector env-height 0))

(define env (make-vector env-width column))

(set! column 'junk) ; just in case

 

; the columns seem to point to the same object...

; so I have to reset them individually...and verify uniqueness.

(define init-env

   (lambda (env-width)

     (let (

            (column (make-vector env-height 0))

            (flip (random env-height))

          )

     (cond

      ((zero? env-width) '())

      (else

        (vector-set! column flip 1) ;spray env with 1's

        (vector-set! env (- env-width 1) column)

        (init-env (- env-width 1)))))))

 

(init-env env-width)

 

(define env-ref

  (lambda (posit); a list '(col row) = (x y)

    (let ((x (car posit))

              (y (cadr posit)))

      (if (< x 0) (set! x 0)

              (if (>= x env-width)(set! x (- env-width 1))))

      (if (< y 0) (set! y 0)

              (if (>= y env-height)(set! y (- env-height 1))))

    (vector-ref (vector-ref env x) y))))

 

(define env-ref-up

  (lambda (posit)

  (env-ref (env-up posit))))

(define env-up

  (lambda (posit);  31

    (if (<= (cadr posit) 0)

            (cons (car posit)(cons ( - env-height 1) '()))

            (cons (car posit)(cons (- (cadr posit) 1) '() )))))

(define env-ref-down

  (lambda (posit)

  (env-ref (env-down posit))))

(define env-down

  (lambda (posit)

    (if (>= (cadr posit) (- env-height 1))

            (cons (car posit)(cons 0 '()))

            (cons (car posit)(cons (+ 1 (cadr posit)) '())))))

(define env-ref-left

  (lambda (posit)

  (env-ref (env-left posit))))

(define env-left

  (lambda (posit)

    (if (<= (car posit) 0)

            (cons ( - env-width 1) (cdr posit))

            (cons (- (car posit) 1)(cdr posit)))))

(define env-ref-right

  (lambda (posit)

  (env-ref (env-right posit))))

(define env-right

  (lambda (posit)

    (if (>= (car posit) (- env-width 1))

            (cons 0 (cdr posit))

            (cons (+ 1 (car posit)) (cdr posit)))))

(define env-ref-up-left

  (lambda (posit)

  (env-ref (env-up-left posit))))

(define env-up-left

  (lambda (posit)

    (env-up (env-left posit))))

(define env-ref-up-right

  (lambda (posit)

  (env-ref (env-up-right posit))))

(define env-up-right

  (lambda (posit)

    (env-up (env-right posit))))

(define env-ref-down-left

  (lambda (posit)

  (env-ref (env-down-left posit))))

(define env-down-left

  (lambda (posit)

    (env-down (env-left posit))))

(define env-ref-down-right

  (lambda (posit)

  (env-ref (env-down-right posit))))

(define env-down-right

  (lambda (posit)

    (env-down (env-right posit))))

 

(define mouse-posit '(0 0))

(define set-mouse-posit

  (let ((x (random env-width))

          (y (random env-height)))

       (set! mouse-posit (cons x (cons y '())))

  ))

 

 

     

(define run!

  (lambda ()

    (if pcs

            (begin

              (plot-old-tms tm-list color)))

    (letrec ((loop (lambda ()

;                (flush-input)

                             (display 'enter-command-or-arrows-or-?> )

                             (set! trap (read-char))

                             (cond

                               ((or (equal? trap '#\K )

                                        (equal? trap '#\H )

                                        (equal? trap '#\P )

                                        (equal? trap '#\M ))

                                          (begin

                                                (loop)))

                               ((equal? trap '#\? )(menu-poppup ))

                               ((equal? trap '#\q ) 'done-enter-reset!-to-continue )

                               ((equal? trap '#\t ) (make-tm) )

                               ((equal? trap '#\r ) (make-random-tms 5) )

                               ((equal? trap '#\s )(cycle-env -1));single-step

                               ((equal? trap '#\g )(cycle-env 10));let-her-rip

                               (else            ;note interupt must be (char-ready)

                                     (begin

                                     (display-stat 'invalid-command trap)

                                     (menu-poppup)

                                     (loop))))

                             (if (not (equal? trap '#\q))

                                     (loop)

                                     #t ))))

      (loop))))

 

(define make-random-tms

  (lambda (n)

    (cond

      ((zero? n) '())

      (else

            (let ((x (random env-width))

                  (y (random env-height)))

              (set! mouse-posit (cons x (cons y '())))

              (make-tm)

              (make-random-tms (- n 1)))))))

 

(define make-random-plants

  (lambda (n)

    (cond

      ((zero? n) '())

      (else

            (let ((x (random env-width))

                  (y (random env-height)))

              (set! mouse-posit (cons x (cons y '())))

              (make-plant mouse-posit)

              (make-random-plants (- n 1)))))))

 

 

 

(define menu-poppup

  (lambda ()

    (display 'not-implemented-yet )))

 

 

(define cycles 0)

     

 

(define cycle-env

  (lambda (n)

    (cond

      ((= n 0) #t)

;     ((char-ready?)(set! trap (read-char)))

      ((= n -1)(begin (cycle-environment)(cycle-env -1)))

      (else

            (begin

              (cycle-environment)

              (cycle-env (- n 1)))))))

;trace cycle-env)

 

 

(define cycle-environment

  (lambda ()

    (let ((tm-len (length tm-list)))

    (set! cycles (+ cycles 1))

    (if (> tm-len max-pop)(slew-weakest ( + 20 (- tm-len max-pop))) #f)

    (if (< tm-len min-pop)(make-random-tms 10) #f)

    (cycle-plants pl-list)

    (cycle-tms tm-list)

    )))

 

;trace cycle-environment)

 

 

(define cycle-plants

  (lambda (lst)

    (cond

      ((null? lst) '())

      (else

      (run-tm (car lst) 'pl)

      (cycle-plants (cdr lst))))))

;trace cycle-plants)

 

 

(define cycle-tms

  (lambda (lst)

    (cond

      ((null? lst) 'done)

      (else

            (begin

              (cycle-tm (car lst))

              (cycle-tms (cdr lst)))))))

;trace cycle-tms)

 

 

(define cycle-tm

  (lambda (tm)

    (run-tm tm 'tm)

    (Tm-age! tm (+ 1 (Tm-age? tm )))))

;trace cycle-tm)

 

(define run-tm

  (lambda (tm type)

    (let* ((posit (Tm-posit? tm ))

              (x (* cell-size (car posit)))

              (y (* cell-size (cadr posit)))

              (age (Tm-age?  tm ))

              (strength (Tm-str?  tm ))

              (tm-def (Tm-def?  tm )); a vector of vectors

              (tm-state (Tm-curr-state? tm ))

              ;(input-data (env-ref posit))

              (input-data (Tm-in? tm))

              (state (vector-ref tm-def

                                         (if (equal? input-data 0)

                                                 (* 2 tm-state)

                                                 (+ 1 (* 2 tm-state)))))

               (s0 (vector-ref state 0));x

               (s1 (vector-ref state 1));x

               (s2 (vector-ref state 2));x

               (out (vector-ref state 3));output 0/1

               (s4 (vector-ref state 4));d

               (s5 (vector-ref state 5));d

               (next-state (bin->dec

                                     (list->vector (cons s0 (cons s1 (cons s2 '()))))))

               )

      (cond

      ((eq? type 'tm)

       (begin

         (draw-tm tm on)     

         (if (replicant-str age strength)

             (replicate tm posit)

                     #f)

         (if (> age senile-age)

                  (begin (kill-tm tm posit) )

                  (begin

              (Tm-curr-state! tm next-state)

              (Tm-str! tm (- (Tm-str? tm) (* out bit-cost))) ; out = 0/1

              (move-tm out s4 s5 posit tm);also determines mating,fighting,foraging

            )

         )

         (if (and (< (Tm-str? tm) starvation) (> sav-elite (length tm-list)))

                (begin (kill-tm tm posit) ) #f)

       ))

      ((eq? type 'pl)

       (begin

         ;(Tm-str! tm (+ (Tm-str? tm) bit-cost))

         (move-pl tm);also determines mating,fighting,foraging

       ))

      ) ;cond

)))

;trace run-tm)

 

(define update-env

  (lambda (posit data)

    (let* ((x (car posit))  ;X

                   (y (cadr posit))  ;Y ??? x/col

           (x-vec (vector-ref env x))

         )

     (vector-set! x-vec y data)

     (vector-set! env x x-vec)

;    (vector-set! env x (vector-set! (vector-ref env x) y data))

     (cond

               ((equal? data 0)

                 (draw-cell posit off))

               ((equal? data 1)

                 (draw-cell posit on))

             (else

              'tm-name )))))

;trace update-env)

 

(define move-tm ;returns #t or #f

  (lambda (out b1 b2 posit tm-name)

    (let ((new-posit 'fooey )

         )

      (cond

            ((and (= b1 0)(= b2 0))(set! new-posit (env-left posit)))

            ((and (= b1 0)(= b2 1))(set! new-posit (env-right posit)))  

            ((and (= b1 1)(= b2 0))(set! new-posit (env-up posit)))  

            ((and (= b1 1)(= b2 1))(set! new-posit (env-down posit)))

            (else 'error-in-directions ))

      (let ((npc (env-ref new-posit));new posit's contents

                (draw #f))

            (Tm-in! tm-name npc)

            (cond

              ((equal? npc 0)(begin

           (set! draw #t)  ))

      ((and (number? npc)(> npc 0))(begin

           (Tm-str! tm-name (+ (Tm-str? tm-name) (* npc bit-value)))

           (set! draw #t)  ))

 

 

              ((equal? (car npc) 'tm)

               (set! draw (fight-mate tm-name posit

                                                                 (cadr npc) new-posit)))

              ((equal? (car npc) 'pl)

               (begin

               (eat-plant tm-name new-posit (cadr npc))

               (set! draw #t)))

              (else 'undefined-env-tm ))

            (if draw ;if location OK to occupy

                (begin

                  (update-env posit out);also plots digit

;Assume Tm has jumped to a square on cycle-0. On cycle-1 it will read

;that square, write to it, and then jump to a new square.

          (draw-tm tm-name off) ;zzz

                  (Tm-posit! tm-name new-posit)

          (draw-tm tm-name on) ;zzz

                  (update-env new-posit (cons 'tm (cons tm-name '())))

                        ))

            ))))

 

(define move-pl ;returns #t or #f

  (lambda (tm-name)

    (let* ((new-posit 'fooey )

           (posit (Tm-posit? tm-name ))

           (tm-def (Tm-def?  tm-name ))

           (tm-state (Tm-curr-state? tm-name ))

           ;(input-data (env-ref posit))

           (input-data (Tm-in? tm-name))

           (state (vector-ref tm-def

                  (if (equal? input-data 0)

                  (* 2 tm-state)

                  (+ 1 (* 2 tm-state))

            )))

 

           (s0 (vector-ref state 0));x

           (s1 (vector-ref state 1));x

           (s2 (vector-ref state 2));x

           (out (vector-ref state 3));output 0/1

           (b1 (vector-ref state 4));d

           (b2 (vector-ref state 5));d

           (next-state (bin->dec

              (list->vector (cons s0 (cons s1 (cons s2 '()))))))

          )

    (cond

    ((and (= b1 0)(= b2 0))(set! new-posit (env-left posit)))

    ((and (= b1 0)(= b2 1))(set! new-posit (env-right posit)))

    ((and (= b1 1)(= b2 0))(set! new-posit (env-up posit)))

    ((and (= b1 1)(= b2 1))(set! new-posit (env-down posit)))

    (else 'error-in-directions ))

      (let ((npc (env-ref new-posit));new posit's contents

            (draw #f)

            (go #f))

    (Tm-in! tm-name npc)

    (cond

      ((equal? npc 0)(begin

           (set! draw #t)  ))

      ((and (number? npc)(> npc 0))(begin

           (Tm-str! tm-name (+ (Tm-str? tm-name) (* npc bit-value)))

           (set! draw #t)(set! go #t)  ))

 

      ((equal? (car npc) 'tm) ;plant gets eaten

       (set! draw #f)

       (eat-plant (cadr npc) new-posit tm-name)

      )

      ((equal? (car npc) 'pl)

       (begin

       (set! draw #f)))

      (else 'undefined-env-tm )) ;cond

 

    (if draw ;if location OK to occupy

        (begin

          (Tm-curr-state! tm-name next-state)

          (update-env posit out);also plots digit

          (draw-plant tm-name off) ;zzz

          (Tm-posit! tm-name new-posit)

          (draw-plant tm-name on) ;zzz

          (update-env new-posit (cons 'pl (cons tm-name '())))

        ))

     (if go (move-pl tm-name) #f)

    ))))

 

 

(define eat-plant

  (lambda (tm-name posit plant)

     (Tm-str!  tm-name (+ (Tm-str? tm-name) plant-value))

     (kill-pl plant posit)))

 

;this factor will cause the number of fights to increase as the population of

;Tm's in the environment increases

(define sim-factor ;similarity factor

  (lambda ()

    (let ((l (vector-length (list->vector tm-list))))

      (* .8 (* 2 (+ 1 num-states))))))

;      (+ 5 (* (* 2 (+ 1 num-states)) (/ (- 100 l) 100))))))

;trace sim-factor)

 

;this will allow a tm and its spawn to seperate a little to allow mixing

 

(define maturity

  (lambda (age1 str1 age2 str2)

    (let ((mat (/ (+ age1 age2 str1 str2) 100)))

    (if (and

      (> age1 maturity-age)

      (> age2 maturity-age)

      (> mat mate-factor)

      (< age1 menopause)

      (< age2 menopause)) #t #f))))

;trace maturity)

 

(define replicant-str

  (lambda (age str)

    (if (or (and

              (< (length tm-list) max-pop)

              (> (+ age (* food-factor str)) replicate-point))

            (< (length tm-list) min-pop)) #t #f)))

;trace replicant-str)

 

;tm1 wants to move to p2

(define fight-mate ;needs to return #t if tm1 can move to p2

  (lambda (tm1 p1 tm2 p2)

    (let ((age1 (Tm-age?  tm1 ))

              (str1 (Tm-str?  tm1 ))

              (x (* cell-size (car p1)))

              (y (* cell-size (cadr p1)))

              (age2 (Tm-age?  tm2 ))

              (str2 (Tm-str?  tm2 ))

              (sim (calc-simularity (Tm-def?  tm1 )

                                                (Tm-def?  tm2 )(* 2(- num-states 1))))

              )

      (cond

                ((<= sim (sim-factor))

            (fight tm1 p1 age1 str1 tm2 p2 age2 str2))

; sim now > sim-factor

                ((replicant-str age1 str1)

             (begin (replicate tm1 p1)

                            (draw-tm tm1 on)

                                                             #f))

                ((maturity age1 str1 age2 str2)

             (begin

                            (mate tm1 p1 tm2 p2)

                            (draw-tm tm1 on)

                            #f )) ;if tm1 mates it should not also move

                (else

                   #f )))));the only way it can move to p2 is by killing tm2

;trace fight-mate)

 

(define calc-simularity

  (lambda (tm1-def tm2-def n)

    (let ((sim (if (equal? (vector-ref tm1-def n)(vector-ref tm2-def n)) 1 0)))

      (cond

            ((zero? n) sim)

            (else

              (+ sim (calc-simularity tm1-def tm2-def (- n 1))))))))

;trace calc-simularity)

 

;This says that foraging food performance is 3 times more important than age

(define calc-power

  (lambda (age str)

    (/ (+ age (* str food-factor)) 100)))

;trace calc-power)

 

 

(define fight

  (lambda (tm1 p1 age1 str1 tm2 p2 age2 str2)

    (let ((pow1 (calc-power age1 str1))

              (pow2 (calc-power age2 str2)))

      (if (> pow1 pow2)

              (begin

                (kill-tm tm2 p2)

                (Tm-str! tm1 (+ kill-bonus (Tm-str?  tm1 )))

                #t)

              (begin

                (kill-tm tm1 p1) #f )))))

;trace fight)

 

(define kill-tm

  (lambda (tm p)

      (let ((x (* cell-size (car p)))

                (y (* cell-size (cadr p))))   

            (set! tm-list (remove tm tm-list))

            (update-env p 0)

            (draw-tm tm off)

            )))

 

(define kill-all-tm

   (lambda ()

    (slew-weakest (length tm-list))))

 

(define kill-pl

  (lambda (tm p)

      (let ((x (* cell-size (car p)))

        (y (* cell-size (cadr p))))

    (set! pl-list (remove tm pl-list))

    (update-env p 0)

    (draw-plant tm off)

    )))

 

(define kill-all-pl

   (lambda (lst)

     (cond

       ((null? lst) #t)

     (else

       (begin

          (kill-pl (car lst) (Tm-posit? (car lst)) )

          (kill-all-pl (cdr lst)))))))

 

(define slew-weakest

   (lambda (n)

    (cond

    ((zero? n) '())

    ((null? tm-list) '())

    (else

       (let ((weakest (find-weakest-tm (car tm-list)(cdr tm-list)

                                       (Tm-str? (car tm-list)))))

          (kill-tm weakest (Tm-posit? weakest))

          (slew-weakest (- n 1)))))))

 

(define find-weakest-tm

   (lambda (worst rest val)

     (cond

        ((null? rest) worst)

     (else

     (if (< (Tm-str? (car rest)) val)

         (find-weakest-tm (car rest) (cdr rest) (Tm-str? (car rest)))

         (find-weakest-tm worst (cdr rest) val))

 

))))

 

(define remove

  (lambda (obj lst)

    (cond

      ((null? lst) '())

      ((equal? obj (car lst)) (cdr lst))

      (else

            (cons (car lst)(remove obj (cdr lst)))))))

;trace remove)

 

(define replicate

  (lambda (tm1 p1)

    ;(pp 'replicate!)

      (mate tm1 p1 tm1 p1)))

;trace replicate)

 

 

(define find-open-square

  (lambda (posit)

    (cond

      ((number? (env-ref-up posit))(env-up posit))

      ((number? (env-ref-down posit))(env-down posit))

      ((number? (env-ref-left posit))(env-left posit))

      ((number? (env-ref-right posit))(env-right posit))

      ((number? (env-ref-up-left posit))(env-up-left posit))

      ((number? (env-ref-up-right posit))(env-up-right posit))

      ((number? (env-ref-down-left posit))(env-down-left posit))

      ((number? (env-ref-down-right posit))(env-down-right posit))

      (else

    #f ))))

;trace find-open-square)

 

(define find-open-square-r

  (lambda (posit start tries)

    (cond

      ((and ((= start 0)(number? (env-ref-up posit))))(env-up posit))

      ((and ((= start 1)(number? (env-ref-down posit))))(env-down posit))

      ((and ((= start 2)(number? (env-ref-left posit))))(env-left posit))

      ((and ((= start 3)(number? (env-ref-right posit))))(env-right posit))

      ((and ((= start 4)(number? (env-ref-up-left posit))))(env-up-left posit))

      ((and ((= start 5)(number? (env-ref-up-right posit))))(env-up-right posit))

      ((and ((= start 6)(number? (env-ref-down-left posit))))(env-down-left posit))

      ((and ((= start 7)(number? (env-ref-down-right posit))))(env-down-right posit))

      (else

        (if (= 0 tries) #f (find-open-square posit (random 8) (- tries 1)))))))           

;trace find-open-square)

 

(define mate

  (lambda (tm1 p1 tm2 p2)

    (let* ((p3 (find-open-square p1));   (random 8) 12))

                   (Tm (list->vector (make-n-states (* 2 num-states))))

                   (Tm-name (Tm-make 0 baby-str p3 Tm 0 0))

          )

      (if p3

        (begin

           ;pp 'mate!)

                   (set! Tm-list (cons Tm-name Tm-list))

                   (set! Tm (list->vector

                             (cross-tms

                                  (Tm-def?  tm1 )(Tm-def?  tm2 )

                                  (random (* 2 num-states)) ; choose

                   0)))                       ; start point for crossing

           ;(if (mutate-state)

               ;(vector-set! Tm (random num-state-bits)

                    ;(if (even? (random 10)) 1 0)))

                   (Tm-def! Tm-name Tm)

                   (Tm-age!  Tm-name  0)

                   (Tm-str!  Tm-name  baby-str)

                   (Tm-posit! Tm-name p3)

                  ;(Tm-def! Tm-name Tm)

                   (Tm-curr-state!  Tm-name 0)

                   (Tm-in!  Tm-name 0)

                   (update-env p3 (cons 'tm (cons tm-name '())) )

                   (draw-tm Tm-name on)

           (Tm-str!  Tm1  (- (Tm-str? Tm1) mate-cost))

           (Tm-str!  Tm2  (- (Tm-str? Tm2) mate-cost))

)))))

 

; n is cross point, x is counter

 

(define cross-tms

 

  (lambda (tm1-def tm2-def n x)

 

    (cond

 

      ((= x (* 2 num-states)) '())

 

      ((< n x)

 

                (cons (vector-ref tm1-def n)

 

                  (cross-tms tm1-def tm2-def  n (add1 x))))

 

      (else

 

                (cons (vector-ref tm2-def n)

 

                  (cross-tms tm1-def tm2-def  n (add1 x))))

 

)))

 

 

 

(define cross-tms-old

 

  (lambda (tm1-def tm2-def n)

 

    (cond

 

      ((= n (* 2 num-states)) '())

 

      (else

 

            (cons (cross-state (vector-ref tm1-def n)(vector-ref tm2-def n))

 

                  (cross-tms tm1-def tm2-def (add1 n)))))))

 

;trace cross-tms)

 

 

 

(define mutate-state

 

  (lambda ()

 

    (> mutate-rate  (random 100))))

 

;trace mutate-state)

 

 

 

(define cross-state

 

  (lambda (st1-v st2-v)

 

    (if (equal? st1-v st2-v)

 

            (if (mutate-state)

 

                (begin

 

                  (vector-set! st1-v (random num-state-bits)

 

                                       (if (even? (random 10)) 1 0))

 

                  st1-v)

 

                st1-v)

 

            (begin

 

              (let* ((cross-point (random num-state-bits))

 

                        (st1-bit (vector-ref st1-v cross-point))

 

                        (st2-bit (vector-ref st2-v cross-point)))

 

                (vector-set! st1-v cross-point (xor st1-bit st2-bit))

 

                st1-v)))))

 

;trace cross-state)

 

 

 

 ; returns a list of length l with a random distribution of zeros and ones.

 

(define v1-list

 

  (lambda (l)

 

    (cond

 

     ((zero? l) '())

 

     (else

 

      (cons

 

       (if (even? (random 10)) 1 0)

 

       (v1-list (- l 1)))))))

 

 

 

 

 

;returns a vector of length l + 1

 

;the first element of each vector is reserved to hold the value of the

 

;calculated fitness of that gene/vector....the value is referenced often

 

;during each cycle so we do not wish to have to recalculate it each time.

 

(define v1

 

  (lambda (w)

 

  (list->vector

 

         (cons .01 (v1-list w)))))

 

 

 

 

 

 

 

(define v2 ;l vectors of w length

 

  (lambda (l w)

 

    (list->vector (v2-list l w))))

 

 

 

 

 

(define v2-list ;returns l vectors

 

  (lambda (l w)

 

    (cond

 

     ((zero? l) '())

 

     (else

 

      (cons (v1 w) (v2-list (- l 1) w))))))

 

 

 

;the following is just a bunch of auxilliary stuff that I used in figuring

 

;out the properties of genetic algorithms

 

 

 

;dna is a 5*5 matrix

 

;I use it to test my GA on optimizing f(x)=x^2

 

(define dna (v2 5 5))

 

 

 

;this is the function to be optimized.

 

(define fx3

 

  (lambda (n)

 

    (expt n 3)))

 

 

 

;takes a two dimensional matrix and applies fx to it for n cycles

 

;each cycle behaves as described in the above specifications

 

(define cycle

 

  (lambda (n matrix fx)

 

    (cond

 

     ((zero? n) (pretty-print matrix))

 

     (else

 

      (begin

 

            (display "generation# = ")

 

            (pretty-print n)

 

            (display "matrix =")

 

            (pretty-print matrix)  

 

            (set! matrix (evolve matrix fx))

 

            (cycle (- n 1) matrix fx))))))

 

;trace cycle)

 

 

 

 

 

 

 

;takes a gene/vector and applies fx to it, returning a decimal value

 

(define f-val

 

  (lambda (fx gene)

 

    (fx (bin->dec gene))))

 

 

 

;returns the sum of all the f-vals in a 2*2 vector-space...used to determine

 

;the fitness of each individual gene...and to spin the roulette wheel

 

(define calc-sum

 

  (lambda (chromo fx)

 

    (let ((l (vector-length chromo)))

 

      (letrec ((loop

 

                        (lambda (gene-posit)

 

                          (cond

 

                           ((zero? gene-posit) 0)

 

                           (else

 

                            (+ (f-val fx (vector-ref chromo (- gene-posit 1)))

 

                                          (loop (- gene-posit 1))))))))

 

            (loop l)))))

 

;trace calc-sum)

 

 

 

;I am calling a 2*2 matrix a chromosome...it is composed of genes.

 

;the fitness of a gene is f-val/sum where f-val is fx applied to the gene

 

;  and sum is the summations of all the f-val's of the other genes in the space

 

(define set-fitness

 

  (lambda (chromo fx)

 

    (let ((l (vector-length chromo))

 

              (sum (calc-sum chromo fx)))

 

      (letrec ((loop

 

                        (lambda (gene-posit)

 

                          (cond

 

                           ((zero? gene-posit) 'ok)

 

                           (else

 

                            (begin

 

                            (vector-set!

 

                             (vector-ref chromo (- gene-posit 1))

 

                             0

 

                             (/ (f-val fx (vector-ref chromo (- gene-posit 1)))

 

                                    sum))

 

                            (loop (- gene-posit 1))))))))

 

            (loop l)))))

 

;trace set-fitness)

 

 

 

 

 

;this procedure take a 2D matrix and a function to be maximized.

 

;the fitness of each gene/vector in the matrix is calculated and then placed

 

; at location zero in the gene/vector

 

;chromo-copy is used to hold the two offspring of the mating of two genes.

 

(define evolve

 

  (lambda (chromo fx)

 

    (set-fitness chromo fx)

 

    (let ((chromo-copy (vector-copy chromo))

 

              (l (vector-length chromo)))

 

      (letrec ((loop

 

                        (lambda (l chromo chromo-copy)

 

                          (cond

 

                           ((< l 2);each looping mates 2 genes so only l/2 loops are

 

                                        ;nescessary

 

                            (begin

 

                            (set! chromo chromo-copy)

 

                            chromo))

 

                           (else

 

                            (let* ((mate1  (roulette chromo))

 

                                       (mate2  (roulette chromo))

 

                                       (cross-over ;the point of cross-over between mate1&2

 

                                        (add1

 

                                                (random (- (vector-length

 

                                                             (vector-ref chromo 0)) 1) )))

 

                                       (mutate-probability 2)

 

;I am using a rather high mutation factor due to the low number of cyles

 

;occuring before a local optimum is reached.

 

                                       (mutate-comparator (random 10))

 

                                       (mutate (< mutate-comparator mutate-probability))

 

                               (bin1 (vector-ref (vector-ref chromo mate1) cross-over))

 

                               (bin2 (vector-ref (vector-ref chromo mate2) cross-over))

 

                                       )

 

                              (if (and (or (equal? mate1 mate2)

 

                                                   (equal? bin1 bin2))

 

                                           (not mutate))

 

                                           (loop l chromo chromo-copy)

 

;do not want to mate a gene with itself unless it is going to get mutated

 

                                      (begin

 

                                        (if trace-set

 

                                                (begin

 

                                        (display "mating ")

 

                                        (display mate1)

 

                                        (display " with ")

 

                                        (display mate2)

 

                                        (display " at ")

 

                                        (display cross-over)

 

                                        (display " bin1= ")

 

                                        (display bin1)

 

                                        (display " bin2= ")

 

                                        (pretty-print bin2)))

 

;switch the bits....bin1 is from mate1 at cross-over

 

;                   bin2 is from mate2 at cross-over

 

                                        (vector-set! chromo-copy (- l 1)

 

                                                (mate-f chromo mate1 bin2 cross-over))

 

                                     ;   (display "chromo-copy1= ")

 

                                     ;   (pretty-print (vector-ref chromo-copy (- l 1)))

 

                                        (vector-set! chromo-copy (- l 2)

 

                                                (mate-f chromo mate2  bin1 cross-over))

 

                                     ;   (display "chromo-copy2= ")

 

                                     ;   (pretty-print (vector-ref chromo-copy (- l 2)))

 

                                        (if mutate

 

;mutate takes a random position in the vector and places a 0 or 1 into it

 

; according to randomness                              

 

                                                (begin

 

                                                  (if trace-set

 

                                                  (pretty-print "mutating!"))

 

                                                  (vector-set!

 

                                                   (vector-ref chromo mate1)

 

                                                   (add1 (random (- (vector-length

 

                                                                (vector-ref chromo mate1)) 1)))

 

                                                   (vector-ref (vector-ref chromo mate2)

 

                                                                   (add1 (random

 

                                                                        (- (vector-length

 

                                                                        (vector-ref chromo mate2)

 

                                                                        ) 1)))))))

 

                                        (loop (- l 2) chromo chromo-copy)))))))))

 

            (loop l chromo chromo-copy)))))

 

;trace evolve)

 

 

 

;returns a gene which is the gene at position m in chomo, with bin in its

 

; position m.

 

(define mate-f

 

  (lambda (chromo m bin cross-over)

 

    (let ((temp-vec (vector-copy (vector-ref chromo m))))

 

      (vector-set! temp-vec cross-over bin)

 

      temp-vec)))

 

;trace mate-f)

 

 

 

 

 

;if you describe the sectors of a roulette wheel such that each sector has an

 

; arc length equal to the f-val of a gene then when the wheel is spun the

 

; marker will land on a particular sector with a probability equal the size

 

;of the sector. If we let the circumference of the roulette equal 1 then the

 

;sum of all the arc lengths of the sectors must equal 1. Since the f-val's

 

;of all the genes are calculated to be fractions such that all the f-val's

 

;sum to one we can use each genes f-val to represent the arc length of a sector

 

; on the roulette wheel. Let 'spin' be a random # s.t {0<=spin<=1} then

 

; spin may represent a point on the circumference of the roulette wheel. to

 

; determine which gene corresponds to this point we just add the f-val's of

 

;the genes until their sum is greater than spin...the last gene whose f-val

 

;we added is the gene we want.

 

(define roulette

 

  (lambda (chromo)

 

    (let ((spin (/(random 1000) 1000))

 

              (sum 0))

 

      (letrec ((loop

 

                        (lambda (posit sum)

 

                          (set! sum (+ sum (vector-ref

 

                                    (vector-ref chromo posit)

 

                                                                        0)))             

 

                          (if (or (> sum spin)

 

                                      (= sum spin));sum goes to 1,spin's max is 1

 

                              (if (< posit (vector-length chromo))

 

                                      posit

 

                                      (begin

 

                                        (pretty-print "errror")

 

                                        (display "sum=")                       

 

                                        (pretty-print sum)

 

                                        (display "spin=")

 

                                        (pretty-print spin)                    

 

                                        (pretty-print posit)))

 

                              (begin

 

;                       (pretty-print posit)

 

;                       (display "sum=")

 

;                       (pretty-print sum)

 

;                       (display "spin=")

 

;                       (pretty-print spin)

 

;                       (display "posit-gene-f-val=")

 

;                       (pretty-print (vector-ref (vector-ref chromo posit) 0))

 

                              (loop (add1 posit) sum ))))))

 

            (loop 0 0)))))

 

;trace roulette)

 

 

 

(define disp-square

 

  (lambda (square)

 

    (let ((l (vector-length square)))

 

      (letrec ((loop

 

                        (lambda (posit)

 

                          (cond

 

                           ((equal? posit l) 'done)

 

                           (else

 

                            (begin

 

                              (disp-vec (vector-ref square posit))

 

                              (loop (add1 posit))))))))

 

            (loop 0)))))

 

(define disp-vec

 

  (lambda (vec)

 

    (let* ((lvec (vector->list vec))

 

              (allele (cdr lvec)))

 

      (pretty-print allele))))

 

 

 

;below are some procedures that I made to test the idea of using GA's to

 

;find optimizations of many functions on many dimensional vector spaces.

 

;it seems to me that to make these GA's useful they must be able to store

 

;relational data...ie, between various functions. If each vector could be

 

;transformed into a function according to it's bit pattern....and these

 

;funtions could be related to external enviroments then (I believe) it may

 

;be able to emulate a net.....

 

;....addendum: the function traces a line through the phase space. The

 

;attractor is the optimization

 

(define v3

 

  (lambda (d l w)

 

  (list->vector (v3-list d l w))))

 

 

 

(define v3-list

 

  (lambda (d l w)

 

    (cond

 

     ((zero? d ) '())

 

     (else

 

      (cons (v2 l w) (v3-list (- d 1) l w))))))

 

 

 

 

 

;cube is a 3 dimensional vector space.

 

;I use it to test the competition of two functions in the space.

 

;It is reference by the procedure conv-test...described below

 

(define cube (v3 5 5 5))

 

 

 

;one of the functions used in my 3-dimensional space...

 

;returns the absolute value of cosine(n) s.t {-1<n<32}

 

(define f-cos

 

  (lambda (n)

 

    (- (* (abs (cos (* n (/ 3.1472 31)))) 31) 31)))

 

;returns the absolute value of sine(n) s.t {-1<n<32}

 

(define f-sin

 

  (lambda (n)

 

    (* (abs (sin (* n (/ 3.1472 31)))) 31)))

 

;note that the two functions above intersect at two points

 

 

 

;run with (conv-test some-number)

 

(define conv-test

 

  (lambda (n)

 

    (cond

 

     ((zero? n) (disp-cube cube))

 

     (else

 

      (begin

 

            (letrec ((loop-cos

 

                          (lambda (s)

 

                            (if (negative? s)

 

                                    (loop-sin 4)

 

                                    (begin

 

                                      (vector-set!  cube s

 

                                                (evolve (vector-ref cube s) f-cos))

 

                                      (loop-cos (sub1 s))))))

 

                         (loop-sin

 

                          (lambda (tv)

 

                            (if (negative? tv)

 

                                    (display "cycle-complete")

 

                                    (begin

 

                                      (vector-set! cube tv

 

                                                (evolve (vector-ref cube tv) f-cos))

 

                                      (loop-sin (- tv 1)))))))

 

              (loop-sin 4)

 

            (conv-test (- n 1))

 

            ))))))

 

;trace conv-test)

 

 

 

 

 

 

 

 

 

(define disp-cube

 

  (lambda (cube)

 

    (let ((l (vector-length cube)))

 

      (letrec ((loop

 

                        (lambda (posit)

 

                          (cond

 

                           ((equal? posit l) 'done)

 

                           (else

 

                            (begin

 

                              (display "z = ")

 

                              (pretty-print posit)      

 

                              (disp-square (vector-ref cube posit))

 

                              (loop (add1 posit))))))))

 

            (loop 0)))))

 

 

 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

 

;number base conversion routines

 

 

 

(define hex->dec

 

  (lambda (word);a vector like #(f a 1 8)

 

      (bin->dec

 

      (hex->bin word 32))));32 is probably the largest size possible

 

;;trace hex->dec)

 

 

 

(define hex->bin

 

  (lambda (word l)

 

    (let ((len (vector-length word)))

 

      (add-z

 

      (list->vector (hex-bin word 0 len)) l))))

 

;;trace hex->bin)

 

(define add-z

 

  (lambda (bin-v l)

 

    (let ((len (vector-length bin-v)))

 

      (if (= len l) bin-v

 

              (add-z

 

              (list->vector (append '(0 0 0 0)(vector->list bin-v))) l)))))

 

 

 

(define hex-bin

 

  (lambda (word pos len)

 

      (if (= pos len) '()   

 

              (let ((char (convert (vector-ref word pos))))

 

                (append char (hex-bin word (add1 pos) len))))))

 

                                                 

 

;;trace hex-bin)

 

 

 

(define convert

 

  (lambda (alpha-num)

 

    (cond

 

     ((equal? alpha-num '0 ) '(0 0 0 0))

 

     ((equal? alpha-num '1 ) '(0 0 0 1))

 

     ((equal? alpha-num '2 ) '(0 0 1 0))

 

     ((equal? alpha-num '3 ) '(0 0 1 1))

 

     ((equal? alpha-num '4 ) '(0 1 0 0))

 

     ((equal? alpha-num '5 ) '(0 1 0 1))

 

     ((equal? alpha-num '6 ) '(0 1 1 0))

 

     ((equal? alpha-num '7 ) '(0 1 1 1))

 

     ((equal? alpha-num '8 ) '(1 0 0 0))

 

     ((equal? alpha-num '9 ) '(1 0 0 1))

 

     ((equal? alpha-num 'A ) '(1 0 1 0))

 

     ((equal? alpha-num 'B ) '(1 0 1 1))

 

     ((equal? alpha-num 'C ) '(1 1 0 0))

 

     ((equal? alpha-num 'D ) '(1 1 0 1))

 

     ((equal? alpha-num 'E ) '(1 1 1 0))

 

     ((equal? alpha-num 'F ) '(1 1 1 1)))))

 

;;trace convert)

 

 

 

(define dec->hex

 

  (lambda (n v-len)

 

    (let* ((bin (dec->bin n v-len))

 

               (len (vector-length bin)))

 

      (list->vector (bin->hex bin len)))))

 

;;trace dec->hex)

 

 

 

(define bin->hex

 

  (lambda (bin len)

 

    (bin-hex bin 0 len)))

 

;;trace bin->hex)

 

 

 

(define bin-hex

 

  (lambda (bin pos len)

 

    (cond

 

     ((= pos  len) '())

 

     (else

 

      (let* ((a (vector-ref bin pos ))

 

                (b (vector-ref bin (+ pos 1)))

 

                (c (vector-ref bin (+ pos 2)))

 

                (d (vector-ref bin (+ pos 3)))

 

                (sub-val (cons a (cons b (cons c (cons d '())))))

 

                (hex-char (convert->hex sub-val))

 

                )

 

            (cons hex-char (bin-hex bin (+ pos 4) len)))))))

 

;;trace bin-hex)

 

 

 

(define convert->hex

 

  (lambda (bin-list)

 

    (cond

 

     ((equal? bin-list '(0 0 0 0) ) '0 )

 

     ((equal? bin-list '(0 0 0 1) ) '1 )

 

     ((equal? bin-list '(0 0 1 0) ) '2 )

 

     ((equal? bin-list '(0 0 1 1) ) '3 )

 

     ((equal? bin-list '(0 1 0 0) ) '4 )

 

     ((equal? bin-list '(0 1 0 1) ) '5 )

 

     ((equal? bin-list '(0 1 1 0) ) '6 )

 

     ((equal? bin-list '(0 1 1 1) ) '7 )

 

     ((equal? bin-list '(1 0 0 0) ) '8 )

 

     ((equal? bin-list '(1 0 0 1) ) '9 )

 

     ((equal? bin-list '(1 0 1 0) ) 'A )

 

     ((equal? bin-list '(1 0 1 1) ) 'B )

 

     ((equal? bin-list '(1 1 0 0) ) 'C )

 

     ((equal? bin-list '(1 1 0 1) ) 'D )

 

     ((equal? bin-list '(1 1 1 0) ) 'E )

 

     ((equal? bin-list '(1 1 1 1) ) 'F ))))

 

;;trace convert->hex)

 

 

 

;!!!!this is wrong...get correct version from microcode.s

 

 

 

;takes a binary vector and returns the decimal value

 

(define bin->dec

 

  (lambda (gene)

 

    (let ((l (vector-length gene)))

 

      (bin->dec1 gene 1 l (vector-ref gene 0)))))

 

;;trace bin->dec)

 

 

 

(define bin->dec1

 

  (lambda (gene len l val)

 

    (cond

 

     ((equal? l 1) val)

 

     ((equal? len l) val)

 

     (else

 

      (bin->dec1 gene (add1 len) l

 

            (+ (* val 2)(vector-ref gene len)))))))

 

;;trace bin->dec1)

 

 

 

(define dec->bin

 

  (lambda (n len)

 

    (let ((bin-vec (dec-bin n len)))

 

      (letrec ((loop (lambda (vec len)

 

                               (if (>= (vector-length vec) len) vec

 

                                       (loop (list->vector (cons '0 (vector->list vec)))

 

                                                 len)))))

 

            (loop bin-vec len)))))

 

;;trace dec->bin)

 

 

 

(define dec-bin

 

  (lambda (n len)

 

    (letrec ((loop

 

                  (lambda (v x)

 

                        (cond

 

                         ((and (= x 1)(> v 1))

 

                          (pretty-print

 

                           'error-len-too-small-for-dec->bin ))

 

                         ((equal? x 0) '())

 

                         ((equal? v 0)(cons 0 (loop 0 (- x 1))))

 

                         ((equal? v 1) (cons 1 (loop 0 (- x 1))))

 

                         ((even? v) (cons 0 (loop (/ v 2)(- x 1))))

 

                         (else

 

                          (cons 1 (loop (/ (- v 1) 2)(- x 1))))))))

 

      (list->vector (reverse (loop n len))))))

 

;;trace dec-bin)

 

 

 

(define or-g (lambda (a b)(if (= a 0) b a)))

 

(define xor (lambda (a b)(if (equal? a b) 0 1)))

 

(define xand (lambda (a b)(if (equal? a b) 1 0)))

 

(define not-g (lambda (bit)(if (= bit 1) 0 1)))

 

 

 

(define add1

 

  (lambda (n)

 

    ( + n 1)))

 

 

 

 

 

(define Tm:rtd (make-record-type "Tm-record" '(age str posit Tm-def curr-state in)))

 

 

 

(define Tm-make (record-constructor Tm:rtd))

 

 

 

(define Tm-age? (record-accessor Tm:rtd 'age))

 

(define Tm-str? (record-accessor Tm:rtd 'str))

 

(define Tm-posit? (record-accessor Tm:rtd 'posit))

 

(define Tm-def? (record-accessor Tm:rtd 'Tm-def))

 

(define Tm-curr-state? (record-accessor Tm:rtd 'curr-state))

 

(define Tm-in? (record-accessor Tm:rtd 'in))

 

 

 

(define Tm-record? (record-predicate Tm:rtd))

 

 

 

(define Tm-age! (record-modifier Tm:rtd 'age))

 

(define Tm-str! (record-modifier Tm:rtd 'str))

 

(define Tm-posit! (record-modifier Tm:rtd 'posit))

 

(define Tm-def! (record-modifier Tm:rtd 'Tm-def))

 

(define Tm-curr-state! (record-modifier Tm:rtd 'curr-state))

 

(define Tm-in! (record-modifier Tm:rtd 'in))

 

 

 

 

 

(record-type-field-names Tm:rtd)

 

; ->    (age str posit tm-def curr-state)

 

(record-type-name Tm:rtd)

 

; -> Tm-record

 

;(define Tm1 (Tm-make '1 '2 '3 '4 '5))

 

;(Tm-age! Tm1 '10)

 

 

 

 

 

(define draw-cell

 

   (lambda (posit code)

 

     (let ((x (car posit))

 

           (y (cadr posit)))

 

            ;(if (= code 0) (graphics-operation grid 'set-foreground-color "blue"))

 

            ;(if (= code 15) (graphics-operation grid 'set-foreground-color "black"))

 

            (graphics-set-drawing-mode grid code) ;Not for Win32s

 

            (graphics-draw-point grid

 

                (+ cell-mid (* cell-size x))

 

                (+ cell-mid (* cell-size y))))))

 

 

 

(define draw-tm

 

   (lambda (Tm code)

 

     (let* ((p1 (Tm-posit? tm ))

 

            (x1 (* cell-size (car p1)))

 

            (y1 (* cell-size (cadr p1)))

 

            (x2 (- (+ cell-size x1) 1))

 

            (y2 (- (+ cell-size y1) 1)))

 

            ;(if (= code 0) (graphics-operation grid 'set-foreground-color "red"))

 

          ;(if (= code 15) (graphics-operation grid 'set-foreground-color "black"))

 

          (graphics-set-drawing-mode grid code) ;Not for Win32s

 

          (graphics-draw-line grid x1 y1 x2 y1 )

 

          (graphics-draw-line grid x1 y1 x1 y2 )

 

          (graphics-draw-line grid x1 y2 x2 y2 )

 

          (graphics-draw-line grid x2 y1 x2 y2 )

 

          )))

 

 

 

(define draw-plant

 

   (lambda (Tm code)

 

     (let* ((p1 (Tm-posit? tm ))

 

            (x  (+ (/ cell-size 2) (* cell-size (car p1))))

 

            (y  (+ (/ cell-size 2) (* cell-size (cadr p1))))

 

            (x1 (* cell-size (car p1)))

 

            (y1 (* cell-size (cadr p1)))

 

            (x2 (+ cell-size x1))

 

            (y2 (+ cell-size y1)))

 

            ;(if (= code 0) (graphics-operation grid 'set-foreground-color "green"))

 

          ;(if (= code 15) (graphics-operation grid 'set-foreground-color "black"))

 

          (graphics-set-drawing-mode grid code) ;Not for Win32s

 

          (graphics-draw-line grid x1 y1 x y )

 

          (graphics-draw-line grid x2 y1 x y )

 

          (graphics-draw-line grid x y1 x y )

 

          (graphics-draw-line grid x y2 x y )

 

          )))

 

 

 

 

 

(define plot-old-tms

 

  (lambda (lst code)

 

    (cond

 

      ((null? lst) '())

 

      (else

 

      (draw-tm (car lst) code)

 

              (plot-old-tms (cdr lst) code)))))

 

 

 

 

 

 

 

 

 

(define plot-environment

 

   (lambda ()

 

   (plot-env  (- env-width 1) (- env-height 1) 'redraw)))

 

 

 

(define plot-env

 

   (lambda (x y fn)

 

     (cond

 

      ((< y 0 ) '())

 

     (else

 

      (begin

 

      (plot-x x y fn)

 

      (plot-env x (- y 1) fn))))))

 

;trace plot-env)

 

 

 

(define plot-x

 

    (lambda (x y fn)

 

      (cond

 

      ((< x 0 ) '())

 

      (else

 

      (begin

 

      (plot-cell x y fn)

 

      (plot-x (- x 1) y fn))))))

 

;trace plot-x)

 

 

 

(define plot-cell

 

  (lambda (x y fn)

 

   (let* ( (posit (list x y))

 

           (contents (env-ref posit))

 

        )

 

     (cond

 

      ((and (equal? fn 'redraw) (equal? contents 0))

 

            (update-env posit 0))

 

      ((and (equal? fn 'redraw) (equal? contents 1))

 

            (update-env posit 1))

 

 

 

      ((and (equal? fn 'redraw)

 

            (pair? contents)

 

            (equal? (car contents) 'pl))

 

             (draw-plant (cadr (env-ref posit)) off))

 

 

 

      ((and (equal? fn 'kill-pl)

 

            (pair? contents)

 

            (equal? (car contents) 'pl))

 

             (kill-pl (cadr (env-ref posit)) posit))

 

 

 

      ((and (equal? fn 'redraw)

 

            (pair? contents)

 

            (equal? (car contents) 'tm))

 

             (draw-tm (cadr (env-ref posit)) off))

 

 

 

      ((and (equal? fn 'kill-tm)

 

            (pair? contents)

 

            (equal? (car contents) 'tm))

 

             (kill-tm (cadr (env-ref posit)) posit))

 

     (else

 

       (if (eq? contents 0)

 

           (draw-cell posit 0) 

 

           (draw-cell posit 15) 

 

       )

 

       (if (eq? contents 1)

 

           (draw-cell posit 15) 

 

           (draw-cell posit 0) 

 

       )

 

     )))))

 

;trace plot-cell)

 

    

 

 

 

 

 

(display 'Begin_Run! )

 

 

 

 

 

(make-random-tms 20)

 

(make-random-plants 100)

 

 

 

;(plot-environment)

 

(cycle-env -1)

 

 

 

;(graphics-close grid)