#lang scheme/base
; genetic programming scheme

(require "range.ss")
(provide (all-defined-out))

; make a function description for the dictionary
(define (make-dict-fn name range) (cons name range))
(define (dict-fn-name df) (car df))
(define (dict-fn-range df) (cdr df))

; utilities
(define (pick l)
  (list-ref l (random (length l))))

(define (trunc l n)
  (cond 
   ((zero? n) '())
   ((null? l) '())
   (else (cons (car l) 
               (trunc (cdr l) (- n 1))))))

(define (rndf)
  (/ (random 1000) 1000))

; creates a random program from the dictionary upto depth deep
(define (create-random-program dict depth)
  (if (or (zero? depth) (zero? (random 3)))
      (random 100)
      (let ((fn (pick dict)))
        (cons (dict-fn-name fn) 
              (build-list (random-range (dict-fn-range fn))
                          (lambda (_)
                            (create-random-program dict (- depth 1))))))))

; gets the maximum depth of a tree
(define (get-max-depth tree)
  (define (_ tree d)
    (cond
     ((null? tree) d)
     ((list? (car tree)) 
      (_ (cdr tree) (_ (car tree) (+ d 1))))
     (else (_ (cdr tree) d))))
  (_ tree 1))

; returns a randum subprogram (or subtree) of this program
(define (random-subprogram tree)
  (define (_ tree depth)
    (cond
     ((not (list? tree)) tree)
     ((eq? 1 (length tree)) tree)
     ((zero? depth) (pick (cdr tree)))
     (else (_ (pick (cdr tree)) (- depth 1)))))
  (_ tree (random (get-max-depth tree))))

; mutates the supplied program by the rate specified
(define (create-mutated-program tree rate dict)
  (define (a t)
    (cond
     ((null? t) t)
     ((and (list? t) (list? (car t))) 
      (cons (_ (car t)) (a (cdr t))))
     (else (cons 
            (if (< (rndf) rate)
                (if (zero? (random 2))
                    (create-random-program dict (get-max-depth t))
                    (random-subprogram tree))
                (car t))
            (a (cdr t))))))
  (define (_ t)
    (if (list? t)
        (cons (car t) (a (cdr t)))
        t))
  (_ tree))

; creates a population of random individuals
(define (create-random-population size dict depth)
  (build-list size 
              (lambda (_) 
                (create-random-program dict depth))))
     
; creates a population of mutated versions of the seed 
(define (create-population-from-seed size seed rate dict)
  (build-list
   size
   (lambda (_)
     (create-mutated-program seed rate dict))))

; sorts the population using the supplied scoring procedure
(define (sort-population pop score-proc target)
  (map
   (lambda (s) (cdr s))
   (sort 
    (map
     (lambda (i)
       (cons (score-proc i target) i))
     pop)
    (lambda (a b) 
      (< (car a) (car b))))))

; the main gp loop procedure
(define (iterate-population p dict depth target rate fitness)
  (let ((sorted (sort-population p fitness target)))
    (append
     ; add the previous best individual
     (list (car sorted))
     ; make 75% of the rest of the population from mutated versions
     (create-population-from-seed 
      (inexact->exact (* (length p) 0.75)) (car sorted) rate dict)
     ; and 25%-1 from new random individuals
     (create-random-population 
      (- (inexact->exact (* (length p) 0.25)) 1) dict depth))))

; prints out the program in more human readable form
(define (pretty-print-program p)
  (cond
   ((not (list? p))
      (display p))
   (else
    (display "(")(display (object-name (car p)))
    (for-each
     (lambda (i)
       (display " ")
       (pretty-print-program i))
     (cdr p))
    (display ")"))))