Modified Constraint Differential Evolution algorithm

de.scm

;; Differential evolution minimization algorithm
;; 
;; f                -- minimized function
;; feasible?        -- predicate for checking feasibility of a vector
;; initial-population
;; F                -- value in v1 + F(v2 - v3). Must be in [0..2]
;; CR               -- probability of crossing in crossover
;; generations      -- maximal number of generations
(define (differential-evolution f feasible? initial-population F CR generations)
    ;; Auxiliary function breed
    ;; Calculates next population
    ;; population -- some population
    (define (breed population)
        ;; Mutate i-th vector in population
        (define (mutate i)
            ;; Generate m unique indices for list of
            ;; length n
            (define (generate-indices n m)
                ;; Generate unique random number with
                ;; given list of forbidden numbers
                (define (random-unique forbidden)
                    (let ((value (random-integer n)))
                        (if (or (= value i) 
                                (list-member? forbidden value))
                            (random-unique forbidden)
                            value)))
                ;; Helper for generating indices
                (define (generate-indices-helper indices j)
                    (if (= j m)
                        indices
                        (generate-indices-helper 
                            (cons (random-unique indices) 
                                  indices) 
                            (+ j 1))))
                (generate-indices-helper '() 0))
            ;; Get values from list using
            ;; given list of indices
            (define (list-ref-multi source indices)
                ;; Helper
                (define (list-ref-multi-helper values list-indices)
                    (if (null? list-indices)
                        (reverse values)
                        (list-ref-multi-helper 
                            (cons (list-ref source (car list-indices)) 
                                  values) 
                            (cdr list-indices))))
                (list-ref-multi-helper '() indices))
            ;; Mutation algorithm itself
            (let* ((mixins (list-ref-multi 
                               population 
                               (generate-indices (length population) 3)))
                   (v1 (car   mixins))
                   (v2 (cadr  mixins))
                   (v3 (caddr mixins)))
                (map + v1 (map (lambda (x) (* x F)) (map - v2 v3)))))
        ;; Crossover with father
        (define (crossover father trial)
            (define (crossover-helper crossed-genes father trial)
                (if (null? father)
                    (reverse crossed-genes)
                    (crossover-helper (cons (if (< (random-real) CR)
                                                (car father)
                                                (car trial))
                                            crossed-genes)
                                      (cdr father)
                                      (cdr trial))))
            (crossover-helper '() father trial))
        ;; Main breeding algorithm
        (define (breed-helper breeded i)
            (if (= i (length population))
                (reverse breeded)
                (let* ((father (list-ref population i))
                       (trial  (crossover father
                                          (mutate i)))
                       (trial-fitness  (f trial))
                       (father-fitness (f father))
                       (survived (if (and (< trial-fitness father-fitness) 
                                          (feasible? trial))
                                     trial
                                     father)))
                (breed-helper (cons survived  breeded) (+ i 1)))))
        (breed-helper '() 0))
    ;; Main evolution algorithm
    (define (differential-evolution-helper breeded i)
        (if (= i generations)
            breeded
            (differential-evolution-helper 
                (breed breeded) 
                (+ i 1))))
    (differential-evolution-helper initial-population 0))