#lang scheme/base
; basic genetic algorithm 

(require scheme/base)

(provide (all-defined-out))

; ------------------------------------------------------------
; mutation

(define (random-pick str)
    (string-ref str (random (string-length str))))

(define (mutator fn str rate)
    (let ((ret ""))
        (for ((i (in-range 0 (string-length str))))
            (cond
                ((< (random 1000) rate)
                    (set! ret (string-append ret (fn (string-ref str i))))) ; shuffle
                (else
                    (set! ret (string-append ret (string (string-ref str i)))))))
        ret))

(define (mutate-shuffle str rate)
    (mutator 
        (lambda (c)
            (string (random-pick str)))
        str rate))

(define (mutate-swap-new str rate vocab)
    (mutator 
        (lambda (c)
            (string (random-pick vocab)))
        str rate))

(define (mutate-insert-new str rate vocab)
    (mutator 
        (lambda (c)
            (string-append (string c) (string (random-pick vocab))))
        str rate))

(define (mutate-delete str rate)
    (mutator 
        (lambda (c)
            "")
        str rate))

(define (mutate-rrepeat str rate)
    (mutator 
        (lambda (c)
            (string-append (string c) (string c)))
        str rate))

(define (mutate str rate vocab)
    (set! str (mutate-shuffle str rate))
    (set! str (mutate-swap-new str rate vocab))
    (set! str (mutate-insert-new str rate vocab))
    (set! str (mutate-delete str rate))
    (set! str (mutate-rrepeat str rate))
    str)

;--------------------------------------------------------
; crossover two strings

(define (xover a b)
    (cond ((zero? (string-length a)) b)
        ((zero? (string-length b)) a)
        (else
            (let ((cp (random (min (string-length a) (string-length b)))))
                (string-append (substring a 0 cp) (substring b cp (string-length b)))))))

;--------------------------------------------------------
; genetic algorithm

; make an initial population by mutating an individual
(define (make-population size str rate vocab)
    (build-list size (lambda (n) (mutate str rate vocab))))

; returns a mutated version of this population
(define (mutate-population population rate vocab)
    (map
        (lambda (i)
            (mutate i rate vocab))
        population))

; gets a list of fitnesses of a population, using the supplied fitness function
(define (fitness-list population fitness-proc fitness-user-data)
    (map
        (lambda (i)
            (fitness-proc i fitness-user-data))
        population)) 

; helpers to get the min and max of a list
(define (list-max l)
    (foldl
        (lambda (e t)
            (if (> e t) e t))
        0
        l))

(define (list-min l)
    (foldl
        (lambda (e t)
            (if (< e t) e t))
        999999999
        l))

; culls the bottom part of the population (death)
(define (cull population fitlist score)
    (let* ((max (list-max fitlist))
            (min (list-min fitlist))
            (cutoff (+ min (* score (- max min)))))  
        (foldl
            (lambda (i f r)
                (if (>= f cutoff)
                    (cons i r) r))
            '()
            population
            fitlist)))

; makes a new population by random crossover of individuals (sex)
(define (recombine-population source-pop size)
    (if (null? source-pop)
        '()
        (build-list size 
            (lambda (n)
                (xover (list-ref source-pop (random (length source-pop)))
                    (list-ref source-pop (random (length source-pop)))))))) 

;--------------------------------------------------------
; example fitness function

(define (string-score a b)
    (define (sd a b score)
        (cond ((or (zero? (string-length a))
                    (zero? (string-length b)))
                score)
            (else
                (sd (substring a 1) (substring b 1)
                    (if (eq? (string-ref a 0)
                            (string-ref b 0))
                        (+ score 1)
                        score)))))
    (let ((lendiff (abs (- (string-length a) (string-length b))))) ; include the difference in length
        (if (> lendiff 0)
            (/ (sd a b 0) lendiff)
            (sd a b 0))))

;--------------------------------------------------------
; utils

(define (check l str)
    (foldl
        (lambda (i r)
            (if (string=? i str) #t r))
        #f
        l))

(define (fittest l)
    (cadr 
        (foldl
            (lambda (i r)
                (if (> i (caddr r)) 
                    (list (+ (car r) 1) (car r) i) 
                    (list (+ (car r) 1) (cadr r) (caddr r))))
            (list 0 0 0) ; current, fittest, fitness
            l)))


;--------------------------------------------------------