;(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. ;The functions MYMOD and MYQUOT are Koza's MOD% and QUOTE%, i.e., ; they check for a 2nd argument of 0, but otherwise are identical ; to MODULO and QUOTIENT. (define (mymod x y) (if (zero? y) 0 (modulo x y))) (define (myquot x y) (if (zero? y) 0 (quotient x y))) ; 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) 4) (build-tree (get-random binary) (get-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. In the application to ; random number generators, the value is constrained to be 1 ; if the tree has a positive value and 0 otherwise. (define (eval-tree tree alist) (define (eval-rec tree alist) (cond ((nullary? tree) (let* ((value (data tree)) (binding (assoc (data tree) alist))) (if binding (cdr binding) value))) (else (eval (list (data tree) (eval-rec (left tree) alist) (eval-rec (right tree) alist)))))) (if (> (eval-rec tree alist) 0) 1 0)) ; This fitness function for the application to random number ; generators is parametrized by an integer N. It applies ; the function to the first m integers, to get a list of bits ; of length m. The distribution of the substrings of length N ; of this string is determined (and stored in a vector called ; TABLE). Note that the number of these strings is m-(N-1). ; The entropy of this distribution is then determined and used ; as the fitness. In the current version, there are 128 bit ; strings. ; A natural way to extend this function would be to look at ; substrings of different lengths (Koza does so, and adds the ; results together). ; Currently the fitness function is called automatically when ; an individual is constructed. (define (fitness t) (define number-of-trials 128) (define n 4) ; n is the number of bits used ; Evaluate the tree T for input from START to STOP, in each ; case adding the result to OUTPUT. (define (construct-output t start stop output) (cond ((> start stop) output) (else (construct-output t (add1 start) stop (cons (eval-tree t (list (cons 'j start))) output))))) ; Compute the entropy of the distribution of substrings of ; length N of the string BITS. Do so by maintaining in ; the variable PARTIALS the values of the last N-1, N-2, ..., 1 ; bits read. (define (entropy bits n) (define (suffix n bits) (if (zero? n) bits (suffix (sub1 n) (cdr bits)))) ; Construct the initial value PARTIALS for a given N and bit ; string BITS in the variable LIST. This value is constructed ; in reverse, so it is up to the caller to reverse it back. (define (init-partials bits n list) (cond ((= n 1) list) (else (init-partials (cdr bits) (- n 1) (map (lambda (x) (+ x x (car bits))) (cons 0 list)))))) ; Compute x/n * -log(x/n) (define (info x n) (cond ((zero? x) 0) (else (let ((p (/ x n))) (- (* p (log p))))))) ; Repeatedly and recursively update the output TABLE ; (and the variable PARTIALS) by processing the next ; bit of the bit string BITS. Compute and return ; the entropy when there are no more bits. Note that ; this is computed as a natural log, so there has to be ; a conversion to base 2 before it is output. (define (entropy-rec partials bits table) (cond ((null? bits) (display "table: ") (display table) (newline) (/ (eval (cons '+ (map (lambda (x) (info x number-of-trials)) (vector->list table)))) (log 2))) (else (let ((new-partials (map (lambda (x) (+ x x (car bits))) (append partials '(0))))) (vector-set! table (car new-partials) (add1 (vector-ref table (car new-partials)))) (entropy-rec (cdr new-partials) (cdr bits) table))))) ; begin ENTROPY -- call the recursive version with an empty ; table and the properly initialized value of PARTIALS. (let ((table (make-vector (expt 2 n) 0))) (entropy-rec (reverse (init-partials bits n '())) (suffix (sub1 n) bits) table))) ; begin FITNESS -- compute the entropy (entropy (construct-output t 1 (+ number-of-trials (sub1 n)) '()) n)) ; 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)) ; In the randomizer application, there are only binary and ; nullary operators. In the nullary case, the variable ; accounts for 50% of the choices, as in Koza. (define binary (build-choices '(* + - myquot mymod))) (define nullary (build-choices '(j j j 1 2 3))) ; 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))))