;;; ga.scm -- a simple genetic algorithm example in Scheme

; *** STOP PRESS: 
; ***
; *** Because the code runs very slowly, you are NOT required to 
; *** answer parts K, L, or M of the Genetic Algorithm problems in
; *** Problem Set 10. 

; *** It would still be instructive to examine the code to see how a simple
; *** genetic algorithm is written. There are explanatory notes below.

; *** Because the code runs so slowly, you may want to use a
; *** shorter target string than the one in the PS10 assignment. 
; *** For exmaple, use a target of '(t h i r t y f o u r)
; *** with a popsize=10, nruns=10, and repros=1000. 
; *** That is, call: (ga-multi 10 10 1000 '(t h i r t y f o u r))


; This code implements a genetic algorithm that gradually evolves a
; `population' of individual `genomes'. Each genome is a string of
; characters from an alphabet specified in the function rand-char, and
; the fitness of each genome is the number of characters that match at
; homologous positions on a `target' string, passed as an argument to
; the function eval-fit.

; The style of genetic algorithm is "steady state" (rather than
; "generational"): on each iteration, an individual is selected to be
; reproduced and another individual is selected to be replaced. The
; individual to be reproduced is copied with errors ("mutations") into
; the individual to be replaced. Thus, reproduction is _asexual_
; (there is no "recombination" or "crossover). Sexual repoduction
; could be introduced by using the gene-copy function.

; In the current version, the best individual in the population is
; selected for reproduction, with a random choice if more than one
; individual holds the highest fitness score. Alternative selection
; methods could be used by altering the code in the reproduce function.

; The ga function performs one ga experiment-- it takes as arguments a
; population size (popsize), the number of reproductions (repros), the
; target string (target) and the mutation rate (mrate). Because this
; is a steady-state GA, the number of `generations' can be determined
; by the number of reproductions divided by the population size

; Because GAs are stochastic systems, it is generally necessary to
; make make multiple runs and compute summary statistics such as the
; mean and standard deviation. The ga-multi function does this for
; you: the argument nruns specifies how many runs are to be executed,
; and ga-multi displays a count of the number of runs that terminated
; with success (i.e., having evolved a string that matches the
; target), along with the mean and standard deviation of the number of
; reproductions necessary for a success. Note also that ga-multi does
; NOT take a mutation-rate parameter: instead, it estimates the
; optimal mutation rate at (1/length-of-target-string) -- there are
; theoretical arguments for doing things this way, but for current
; pruposes you can consider this a convenient hack.

; The style of the code betrays the author's C-oriented style rather
; than a Scheme style. A native speaker of Scheme would probably write
; things differently, but to the same effect,




;;; rand-char: generate a character at random from the given alphabet
(define (rand-char)
  (let ( (alphabet '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) 
       )
       (list-ref alphabet (random (length alphabet)))))


;;; mutate-char: randomly pick a character different from c
(define (mutate-char c)
   (do ( (r c)
       )
       ( (not (eq? r c)) r)
       (set! r (rand-char))))


;;; rand-str: generate a random string n characters long
(define (rand-str n)
 (let ( (l ())
      )
  (do ( (c 0 (+ c 1))
      ) 
      ((= c n) l)
      (set! l (append l (list (rand-char)))) )))


;;; eval-fit: evaluate fitness of string s wrt target t
(define (eval-fit s t)
   (let ( (l (min (length s) (length t)))
          (n 0)
        )
        (do ( (c 0 (+ c 1))
            )
            ( (= c l) n)
            (if (eq? (list-ref s c) (list-ref t c))
                (set! n (+ n 1))))))



;;; rand-pop: create a population with popsize members, 
;;;           each as long as target
;;;           and assign each a fitness wrt target
(define (rand-pop popsize target)
  (let ( (p ())
         (s ())
         (f 0)
         (strlen (length target))
       )
       (do ( (i 0 (+ i 1))
           )
           ((= i popsize) p)
           ( begin (set! s (rand-str strlen))      ;;;create an individual
                   (set! f (eval-fit s target))    ;;;evaluate its fitness
                   (set! p (append p (list (list s f)))) ;;;add it 
           ))))


;;;fitness: return the fitness of the i'th member of the population
(define (fitness pop i)
   (cadr (list-ref pop i)))

;;;genome: return the genome of the i'th member of the population
(define (genome pop i)
   (car (list-ref pop i)))

;;;fitter?: is i1 fitter than i2?
(define (fitter? i1 i2)
   (> (cadr i1) (cadr i2)))

;;;mutate-gene: return a mutated version of a genome, error rate set by rate
(define (mutate-gene gene rate)
   (let ( (m ())
        )
        ( do ( (c 0 (+ c 1))
             )         
             ((= c (length gene)) m)
             (if (< rate (random 1.0))
                 (set! m (append m (list (list-ref gene c))))
                 (set! m (append m (list (mutate-char (list-ref gene c)))))))))


;;; gene-copy: return a gene formed by copying characters 0 to (xover-1) 
;;;            from i2 and xover to (length i1) from i1
(define (gene-copy pop i1 i2 xover)
  (let ( (g1 ())
         (g2 ())
         (kid ())
         (g 'a)
       )
       ( begin
         (set! g2 (genome pop i2))
         (set! g1 (genome pop i1))
         (do ( (c 0 (+ c 1))  
             )
             ( (= c (length g1)) kid)
             ( begin
               ( if (< c xover)
                    (set! g (list-ref g2 c))
                    (set! g (list-ref g1 c)) 
             )
             (set! kid (append kid (list g))))))))

;;;count number of elites
(define (elite-count l)
  (let ( (c 0)
       )
       (do ( (i 0 (+ i 1))
           )
           ( (= i (length l)) c)
           ( if (= (fitness l 0) (fitness l i))
                (set! c (+ c 1))))))


;;;return the first n elements of a list
(define (firstn l n)
  (let ( (f ())
       )
       ( do ( (i 0 (+ i 1))
            )
            ( (= i n) f )
            ( set! f (append f (list (list-ref l i)))))))

  
;;; reproduce: do selection and reproduction to create one new individual
;;;            return the population with the new individual present.
(define (reproduce pop mrate target)
  (let ( (kid ())
         (fit 0)
         (kidfit)
         (newpop)
       )
       ( begin
         ;;;sort population so fittest is first
         (set! pop (sort pop fitter?))     
         ;;;copy ones of the elite genomes into kid
         (set! kid (genome pop (random (elite-count pop))))
         ;;;mutate the kid
         (set! kid (mutate-gene kid mrate))
         (set! fit (eval-fit kid target))
         (set! kidfit (list kid fit))
         (set! newpop (append (firstn pop (- (length pop) 1)) 
                              (list kidfit)))
         newpop 
       )))


;;; ga: one ga experiment
;;;     returns a list: first element is success flag (0=> failed), 
;;;                     second element is number of reproductions
(define (ga popsize repros target mrate) 
  (let ( (success 0)
         (popln ())
       )
       (begin 
          ;;;create a population
          (set! popln (rand-pop popsize target))
          (do ( (r 0 (+ r 1))
              )
              ( (or (= r repros) (= 1 success)) 
                    (begin (display "\nFinished after ")
                           (display r) (display " reproductions\n")
                           (list success r)
                    )
              )
              ( begin 
                  (set! popln (reproduce popln mrate target))
                  (if (eq? (length target) (fitness popln 0))
                      (set! success 1)
                  )
                  (display "\nRepro=") (display r)
                  (display " Current best: ")
                  (display (car popln))
                  (display "\n"))))))


;;;ga-multi: does multiple runs of a ga, 
;;;          guesses mutation rateas 1/(length target)            
(define (ga-multi nruns popsize repros target)
  (let ( (n 0)
         (sum 0.0)
         (sumsq 0.0)
         (mrate (/ 1.0 (length target)))
         (nr 0)
         (results ())
         (mean 0)
         (sdev 0.0)
       )
       ( begin     
          ( do ( (e 0 (+ e 1))
              )
              ((= e nruns) (begin (display "All finished\n") ) )
              ( begin
                (display "\nExperiment ") (display e) (display "\n")
                (set! results (ga popsize repros target mrate))
                (if (eq? 1 (car results)) ;;;success?
                    (begin
                      (set! n (+ 1 n))
                      (set! nr (cadr results))
                      (set! sum (+ nr sum))
                      (set! sumsq (+ (* nr nr) sumsq))))))
         ( if (> n 0)
              (begin 
                 (set! mean (/ sum n))
                 (set! sdev (sqrt (- (/ sumsq n) (* mean mean))))
                 (display n) (display " successes: mean=") (display mean)
                 (display " sdev=") (display sdev) (display "\n")
              )
              (display "\nno successes\n")))))