Genetic Algorithm Implementation In Scheme

genetic-algorithm.scm

(define (remove-at index list)
  (map car (filter (lambda (x) (if (= (- (cdr x) 1) index) false true))
                 (map cons list (iota (length list) 1)))))

(define (random-shuffle lst)
  (sort lst (lambda (x y) (equal? 0 (random 2)))))

(define (make-random-bit-mask size num-ones)
  (if (< size num-ones)
      (error "Invalid size -- MAKE-RANDOM-BIT-MASK" size num-ones)
      (random-shuffle (append (make-list num-ones 1)
                              (make-list (- size num-ones) 0)))))

;; Operators on individuals

(define (random-bit) (random 2))

(define (make-random-genome num-bits)
  (map (lambda (x) (random-bit)) (iota num-bits 1)))

(define (make-probabilistic-bit-flipper num-bits)
  (define (flip-bit bit)
    (if (= 1 bit) 0 1))
  (define (bit-flipper bit)
    (let ((bit-array (append '(1) (make-list (- num-bits 1) 0))))
      (if (= 1 (list-ref bit-array (random num-bits)))
          (flip-bit bit)
          bit)))
  bit-flipper)

(define (mutate genome)
  (map (make-probabilistic-bit-flipper (length genome)) genome))

(define (crossover g1 g2)
  (let ((crossover-point (random (length g1))))
    (cons (append (list-head g1 crossover-point)
                  (list-tail g2 crossover-point))
          (append (list-head g2 crossover-point)
                  (list-tail g1 crossover-point)))))


;; Operators on populations

(define (make-random-population population-size make-member-func)
  (map (lambda (x) (make-member-func)) (iota population-size 1)))

(define (get-member-fitness population fitness-func)
  (map fitness-func population))

(define (get-average-fitness population fitness-func)
  (/ (reduce + 0 (get-member-fitness population fitness-func))
     (exact->inexact (length population))))

(define (select-for-tournament population tournament-size)
  (map car
     (filter (lambda (x) (= (cdr x) 1))
             (map cons
                population
                (make-random-bit-mask (length population)
                                      tournament-size)))))

(define (select-fittest population fitness-func num-to-select)
  (list-head
   (sort population
         (lambda (x y) (> (fitness-func x) (fitness-func y))))
   num-to-select))

(define (next-generation population fitness-func)
  (define (produce-next-generation-member)
    (if (= 1 (random 2))
        (let ((tournament-members (select-for-tournament population 3)))
          ((if (= 1 (random 2)) car cdr)
           (apply crossover
                  (select-fittest tournament-members fitness-func 2))))
        (mutate (car (select-for-tournament population 1)))))
  (map (lambda (x) (produce-next-generation-member))
     (iota (length population) 1)))

;; Simulations

(define (display-line prompt value)
  (display prompt)
  (display " ")
  (display value)
  (newline))

(define (run init-population fitness-func num-generations)
  (define (make-hof genome fitness)
    (list genome fitness))
  (define (hof-get-fitness hof)
    (cadr hof))
  (define (hof-get-genome hof)
    (car hof))
  (define (iter population generation hall-of-fame)
    (if (> generation num-generations)
        (begin (newline)
               (display "[Hall Of Fame]")
               (newline)
               (display-line "Fitness:" (hof-get-fitness hall-of-fame))
               (display-line "Value:" (hof-get-genome hall-of-fame)))
        (let ((fitnesses (get-member-fitness population fitness-func)))
          (display-line "Generation:" generation)
          (display-line "Max Fitness:" (apply max fitnesses))
          (display-line "Min Fitness:" (apply min fitnesses))
          (display-line "Average Fitness:" (get-average-fitness population fitness-func))
          (display population)
          (newline)
          (let ((next-gen (next-generation population fitness-func)))
            (iter 
             next-gen
             (+ 1 generation)
             (let ((fittest (car (select-fittest next-gen fitness-func 1))))
               (if (> (hof-get-fitness hall-of-fame)
                      (fitness-func fittest))
                   hall-of-fame
                   (make-hof fittest (fitness-func fittest)))))))))
  (let ((fittest (car (select-fittest init-population fitness-func 1))))
    (iter init-population 0 (make-hof fittest (fitness-func fittest)))))

;; Simple equation optimization

(define (bits->int genome)
  (reduce + 0
   (map (lambda (x y) (* x (expt 2 y)))
      genome
      (reverse (map (lambda (x) (- x 1)) (iota (length genome) 1))))))

(define population
  (make-random-population 10 (lambda () (make-random-genome 10))))

(next-generation population bits->int)

(run population bits->int 10)