;(require-library "trace.ss")
;(require-library "tracec.ss")

; This is an implementation of the basic genetic algorithm suitable
;   for constructing a unary random number generator (cf. Koza, p.
;   400).  
; Here individuals have two components -- an expresssion tree and
;   a fitness (accessible by calling GET-TREE and GET-FITNESS
;   respectively.	       
			

; These functions need to be defined specially either because they
;   are not primitives, or to avoid illegal input.
						      
(define (mysquare y) (* y y))
(define (mysqrt y) (if (negative? y) 0 (sqrt y)))
(define (my/ x y) (if (zero? y) 0 (/ x y)))


; This is the test data, more or less as given in the text

(define test-data '((0.36 . 0.216) (0.64 . 0.512) (1 . 1)
                    (1.69 . 2.197) (6.25 . 15.625) (9 . 27)
                    (16 . 64)))


; This function constructs an initial population of individuals.
; The population size is N.  The data type for expression trees is
;   defined at the end of this file.

(define (initial-population n)
  (define (get-tree)
    (cond ((< (random 10) 3) (build-tree (get-random binary)
					  (get-tree)
					  (get-tree)))
    	    ((< (random 10) 3) (build-tree (get-random unary)
                                       empty-tree
                                       (get-tree)))
	  (else (build-tree (get-random nullary)
			    empty-tree
			    empty-tree))))
  (cond ((zero? n) '())
	(else (cons (build-individual (get-tree) )
		    (initial-population (sub1 n))))))


; This function evaluates an expression tree, given an association
;   list of bindings for the variables. 

(define (eval-tree tree alist)
  (cond ((nullary? tree) (let* ((value (data tree))
                             (binding (assoc (data tree) alist)))
                        (if binding (cdr binding) value)))
	((unary? tree) (eval (list (data tree)
				    (eval-tree (right tree) alist))))
        (else (eval (list (data tree)
                          (eval-tree (left tree) alist)
                          (eval-tree (right tree) alist))))))



; This fitness function sums the scores for each input point
; These scores are obtained by computing the percentage 
;   that the computed output is of the target.  The score
;   ranges from 0 to 100 and back down to 0 as the percentage
;   ranges from 0 to 100 and up to 200.  If the 
;   percentage is not in the range 0-200, 0 is returned.

(define (fitness t)
  (define (point-fitness target computed)
    (let ((pct (* 100 (/ computed target))))
      (cond ((< pct 0) 0)
	    ((> pct 200) 0)
	    ((< pct 100) pct)
	    (else (- 200 pct)))))
  (eval (cons + (map
                 (lambda (x)
                   (point-fitness (cdr x)
				  (eval-tree t
					     (list (cons 'a (car x))))))
                 test-data))))



; This is the crossover function.  For each of its two input trees
;   (in the representation described at the end of this file),
;   it determines an edge to cut.  This edge is represented as 
;   a pair consisting of the edge's' parent and a selector "left" 
;   or "right" (or the identity function if the entire tree is to
;   be swapped).  The body of the function just cuts and pastes
;   according to the possible cases for which children are to be
;   swapped.  Note that the size field of each tree has to be updated.
; The input is a list of trees, not of individuals.  The output 
;   is a list of the two resulting trees. 

(define (crossover t1 t2)
  (define (parent pfc) (car pfc))       ; selectors for the pairs
  (define (direction pfc) (cadr pfc))   ;   representing edges
  
  ; Find a place for crossover.  Each edge is chosen with equal
  ;   probability, including the dummy edge to the root.
  
  (define (place-for-crossover t) 
    (define (aux t parent r dir)
      (cond ((zero? r) (list parent  dir))
	    ((empty-tree? (left t)) (aux (right t) t (sub1 r) right))
	    ((<= r (size (left t))) (aux (left t) t (sub1 r) left))
	    (else (aux (right t) t 
		       (- r (add1 (size (left t)))) right))))
    (aux t t (random (size t)) (lambda (x) x)))
  
  ; begin CROSSOVER
  (let* ((place1 (place-for-crossover t1))
	 (place2 (place-for-crossover t2))
	 (parent1 (parent place1))
	 (parent2 (parent place2))
	 (direction1 (direction place1))
	 (direction2 (direction place2))
	 (branch1 (direction1 parent1))
	 (branch2 (direction2 parent2)))
    (cond ((equal? direction1 left)
	   (set-left! parent1 branch2))
	  ((equal? direction1 right)
	   (set-right! parent1 branch2))
	  (else (set! t1 branch2)))
    (cond ((equal? direction2 left)
	   (set-left! parent2 branch1))
	  ((equal? direction2 right)
	   (set-right! parent2 branch1))
	  (else (set! t2 branch1)))
    (set-size! t1)
    (set-size! t2)
    (list t1 t2)))


; This function constructs the next generation's population, given 
;   the current population POP.  The new population size will be 
;   the same as the old.  
; It works by first constructing a mating pool, selecting its
;   individuals one at a time by fitness-proportional reproduction
;   (note that this requires knowledge of the TOTAL fitness of
;   the population).  It then calls the function MATE to construct
;   new individuals two at a time.
; The auxiliary function use a list FITNESSES of the fitnesses of
;   the individuals in the old population.
; No mutation operators are currently used.  

(define (next-generation pop)
  
  ; The work of this function is done by its auxiliary ITER, 
  ;   which builds a mating pool by repeatedly calling 
  ;   MATING-INDIVIDUAL to select the next individual for
  ;   the mating pool.  It makes copies of each individual,
  ;   so that crossing over of one individual will not affect
  ;   an identical individual occuring later in the population.
  
  (define (build-mating-pop pop fitnesses total) 
    (define (mating-individual pop fitnesses r)
      (cond ((null? (cdr pop)) (car pop))
	    ((< r (car fitnesses)) (car pop))
	    (else (mating-individual (cdr pop)
				     (cdr fitnesses)
				     (- r (car fitnesses))))))
    (define (iter pop fitnesses total n)
      (cond ((zero? n) '())
	    (else (cons (copy 
			 (mating-individual 
			  pop 
			  fitnesses 
			  (if (zero? (round total)) 0
			      (random (inexact->exact (round total))))))
			(iter pop fitnesses total (sub1 n))))))
    
    ;begin BUILD-MATING-POP
    (iter pop fitnesses total (length fitnesses)))
  
  ; MATE is a straightforward recursive function that applies
  ;   crossover to its input pool two elements at a time.
  
  (define (mate pool)
    (cond ((null? pool) '())
	  (else (append (map build-individual 
			 (crossover (get-tree (car pool))
				    (get-tree (cadr pool))))
			(mate (cddr pool))))))
  
  ; begin NEXT-GENERATION -- construct a list of all the 
  ;   individual fitnesses, find their total, construct
  ;   a mating pool, and let the mating begin.
  
  (let* ((fitnesses (map get-fitness pop))
	 (total (eval (cons + fitnesses)))
	 (mating-pool (build-mating-pop pop fitnesses total)))
    (mate mating-pool)))


; This is the top-level function for the genetic algorithm.
; Its parameters are the number of individuals in the population
;   (this number is constant) and the number of generations for
;   which the algorithm is to be run.
; It expects the function FITNESS to be defined and accessible.
; It uses an auxiliary function AUX to recursively count through
;   the generations and construct the successive populations,
; and an auxiliary function REPORT to print a few statistics about
;   each generation.  REPORT has its own auxiliary function to
;   locate the fittest member of each generation.
; It returns the final population.

(define (genetic population-size number-of-generations)
  (define (report pop)
    (define (where-is-max list-of-numbers)
      (define (aux list-of-numbers max-so-far position number-seen)
	(cond ((null? list-of-numbers) position)
	      ((< (car list-of-numbers) max-so-far)
	       (aux (cdr list-of-numbers) max-so-far position 
		    (add1 number-seen)))
	      (else (aux (cdr list-of-numbers) (car list-of-numbers)
			 (add1 number-seen) (add1 number-seen)))))	   
      (aux (cdr list-of-numbers) (car list-of-numbers) 0 0))
    (let* ((fitnesses
	    (map (lambda (x) (get-fitness x)) pop))
	   (posn (where-is-max fitnesses)))      
      (display "average fitness: ")
      (display (/ (eval (cons '+ fitnesses)) population-size))
      (newline)
      (display "best individual: ")
      (display (list-ref pop posn))
      (newline)
      (display "its fitness: ")
      (display (list-ref fitnesses posn))
      (newline)
      (newline)))
  (define (aux pop n)
    (report pop)
    (cond ((zero? n) pop)
	  (else (aux (next-generation pop) (- n 1)))))
  (aux (initial-population population-size) number-of-generations))






; This is a generator of random number generators in the style 
;   of Abelson & Sussman.  To create a random number generator 
;   called R, type            (define r (make-randomizer 12345))
;   where 12345 may be replaced by any positive integer less 
;   than 2,147,483,647.  To get a random integer between 0 and 
;   N, type                    (r N)
;   To reseed the generator R, type
;                              ((r 'reseed) 12345)
;   where again 12345 may be replaced by a positive integer in the
;   range given above.

(define (make-randomizer s)
  (define (update)
    (set! s (modulo (* 65539 s) 2147483647)) )
  (define (random n)
    (update)
    (floor (/ (* s n) 2147483647)))
  (define (reseed seed)
    (set! s seed))
  (define (dispatch message)
    (cond ((eq? message 'reseed)
           reseed)
	  ((integer? message)
           (random message))))
  dispatch)

(define (new-random old-random)
  (modulo (* 65539 old-random) 2147483647))
(define (new-r old-r)
  (define (frac x) (- x (floor x)))
  (frac (* 65539 old-r)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;; Selectors and constructors for expression trees ;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; The CHOICES data type stores the length of a list of choices
;   as well as the list elements.

(define (build-choices s) (cons (length s) s))
(define (count choices) (car choices))
(define (get-choices choices) (cdr choices))


; These are the binary, unary, and nullary operators respectively

(define binary (build-choices '(* + my/ - )))
(define unary (build-choices '(mysquare mysqrt)))
(define nullary (build-choices '(a)))


; This function makes a random choice from a CHOICE data structure.

(define (get-random choices)
  (list-ref  (get-choices choices)(random (count choices))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;; Selectors and constructors for individuals ;;;;;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; There are two constructors -- one where the fitness is computed
;   from the tree (a potentially expensive operation) and one
;   where it is given as an argument.

(define (build-individual t)
  (list (fitness t) t))
(define (build-fit-individual f t)
  (list f t))
(define (get-tree i) (cadr i))
(define (get-fitness i) (car i))


; This merely copies an individual.  It's necessary in the genetic
;   algorithm in case an individual appears more than once in a 
;   mating pool.

(define (copy individual)
  (define (copy tree)
    (if (empty-tree? tree) 
	empty-tree
	(build-tree (data tree)
		    (copy (left tree))
		    (copy (right tree)))))
    (build-fit-individual (get-fitness individual) 
			  (copy (get-tree individual))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;; Tree selectors, constructors, predicates, mutators ;;;;;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;; selectors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
(define (data tree) (car tree))
(define (left tree)   (cadr tree))
(define (right tree)  (caddr tree))
(define (size tree) (cadddr tree))
  
;;;;;;;;;;;;;;;;;;;;;; constructor ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; Note that this constructor expects only the data for the root,
;   the left subtree, and the right subtree.  It determines its
;   own size, and updates its representation accordingly.

(define (build-tree data left right) 
  (let ((t (list data left right 0)))
    (set-size! t)
    t))

;;;;;;;;;;;;;;;;;;;;;;;;; mutator ;;;;;;;;;;;;;;;;;;;;;;;;

; This function takes a tree and updates its representation to
;   contain the correct tree size.  It returns the new size.

(define (set-size! tree) 
  (define (modify! tree n)
    (set-car! (cdddr tree) n)
    n)
   (cond ((null? tree) 0)
	 ((null? (left tree)) 
	  (modify! tree (add1 (set-size! (right tree)))))
	 ((null? (right tree))
	  (modify! tree (add1 (set-size! (left tree)))))
	 (else (modify! tree
		     (+ 1
			(set-size! (left tree))
			(set-size! (right tree)))))))


; These mutators update the left and right subtree of a given
;   tree, to have a given new value.  Their values are 
;   indeterminate

(define (set-left! tree val) (set-car! (cdr tree) val))
(define (set-right! tree val) (set-car! (cddr tree) val))

;;;;;;;;;;;;;;;;;;;;;;;;;; predicates ;;;;;;;;;;;;;;;;;;;;;;;;

(define (empty-tree? tree) (null? tree))
(define (nullary? tree) (empty-tree? (right tree))) ; ok here
(define (unary? tree) (empty-tree? (left tree)))

;;;;;;;;;;;;;;;;;; miscellaneous tree functions ;;;;;;;;;;;;;;;

(define empty-tree '())


  
; This is an attempt at pretty-printing a tree

(define (print-tree tree)     
  (define (visit x indenting)
    (display (make-string indenting #\space))
    (print x)
    (newline))
  (define (print-indented tree indenting)
    (cond ((empty-tree? tree) '())
	  (else 
	   (print-indented (left tree) (+ indenting 2))
	   (visit (data tree) indenting)
	   (print-indented (right tree) (+ indenting 2))
	   )))
  (print-indented tree 0))


; These sample trees are perhaps useful in testing the crossover
;   operation.
 
(define t (build-tree '* (build-tree 'a empty-tree empty-tree)
                         (build-tree 2 empty-tree empty-tree)))
(define u (build-tree '+ 
		      (build-tree 'b empty-tree empty-tree)
		      (build-tree '- 
				  (build-tree 'c 
					      empty-tree 
					      empty-tree)
				  (build-tree 3 
					      empty-tree 
					      empty-tree))))