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

A Foxes & Rabbits Simulation


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)






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




;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




(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))


(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' 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


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

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



    (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))



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


        (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


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

    (letrec ((loop (lambda ()

;                (flush-input)

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

                             (set! trap (read-char))


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

                                        (equal? trap '#\H )

                                        (equal? trap '#\P )

                                        (equal? trap '#\M ))



                               ((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)


                                     (display-stat 'invalid-command trap)



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


                                     #t ))))



(define make-random-tms

  (lambda (n)


      ((zero? n) '())


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

                  (y (random env-height)))

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


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


(define make-random-plants

  (lambda (n)


      ((zero? n) '())


            (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)


      ((= n 0) #t)

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

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




              (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)


      ((null? lst) '())


      (run-tm (car lst) 'pl)

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

;trace cycle-plants)



(define cycle-tms

  (lambda (lst)


      ((null? lst) 'done)



              (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 '()))))))



      ((eq? type 'tm)


         (draw-tm tm on)     

         (if (replicant-str age strength)

             (replicate tm posit)


         (if (> age senile-age)

                  (begin (kill-tm tm posit) )


              (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)


         ;(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))


               ((equal? data 0)

                 (draw-cell posit off))

               ((equal? data 1)

                 (draw-cell posit on))


              'tm-name )))))

;trace update-env)


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

  (lambda (out b1 b2 posit tm-name)

    (let ((new-posit 'fooey )



            ((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)


              ((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)


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

               (set! draw #t)))

              (else 'undefined-env-tm ))

            (if draw ;if location OK to occupy


                  (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 '()))))))



    ((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)


      ((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)


       (set! draw #f)))

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


    (if draw ;if location OK to occupy


          (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))))



                ((<= 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)


                ((maturity age1 str1 age2 str2)


                            (mate tm1 p1 tm2 p2)

                            (draw-tm tm1 on)

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


                   #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)))


            ((zero? n) sim)


              (+ 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)


                (kill-tm tm2 p2)

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



                (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)


       ((null? lst) #t)



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

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


(define slew-weakest

   (lambda (n)


    ((zero? n) '())

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


       (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)


        ((null? rest) worst)


     (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)


      ((null? lst) '())

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


            (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)


      ((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))


    #f ))))

;trace find-open-square)


(define find-open-square-r

  (lambda (posit start tries)


      ((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))


        (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


           ;pp 'mate!)

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

                   (set! Tm (list->vector


                                  (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)




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


      ((< n x)


                (cons (vector-ref tm1-def n)


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




                (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)




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




            (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)




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


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








              (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))




;trace cross-state)




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


(define v1-list


  (lambda (l)




     ((zero? l) '())






       (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)




         (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)




     ((zero? l) '())




      (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)




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






            (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)




                           ((zero? gene-posit) 0)




                            (+ (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)




                           ((zero? gene-posit) 'ok)








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




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




                            (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)




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






                            (set! chromo chromo-copy)






                            (let* ((mate1  (roulette chromo))


                                       (mate2  (roulette chromo))


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




                                                (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




                                        (if trace-set




                                        (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                              




                                                  (if trace-set


                                                  (pretty-print "mutating!"))




                                                   (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)




;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)




                          (if (or (> sum spin)


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


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






                                        (pretty-print "errror")


                                        (display "sum=")                       


                                        (pretty-print sum)


                                        (display "spin=")


                                        (pretty-print spin)                    


                                        (pretty-print posit)))




;                       (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)




                           ((equal? posit l) 'done)






                              (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)




     ((zero? d ) '())




      (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)




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






            (letrec ((loop-cos


                          (lambda (s)


                            (if (negative? s)


                                    (loop-sin 4)




                                      (vector-set!  cube s


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


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




                          (lambda (tv)


                            (if (negative? tv)


                                    (display "cycle-complete")




                                      (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)




                           ((equal? posit l) 'done)






                              (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)




      (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)))




      (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




              (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)




     ((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)




     ((= pos  len) '())




      (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)




     ((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)




     ((equal? l 1) val)


     ((equal? len l) val)




      (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)))




            (loop bin-vec len)))))


;;trace dec->bin)




(define dec-bin


  (lambda (n len)


    (letrec ((loop


                  (lambda (v x)




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




                           '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))))




                          (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)




      ((null? lst) '())




      (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)




      ((< y 0 ) '())






      (plot-x x y fn)


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


;trace plot-env)




(define plot-x


    (lambda (x y fn)




      ((< x 0 ) '())






      (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))






      ((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))




       (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)






(cycle-env -1)




;(graphics-close grid)