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