Genetic Algorithm in Elm

Genetic.elm

module Genetic exposing (Config, Goal(..), run)

import List.Extra as List
import Random exposing (Generator)
import Random.Extra as Random
import Random.List


type alias Config solution =
    { newSolution : Generator solution
    , mutate : solution -> Generator solution
    , crossover : solution -> solution -> Generator solution
    , fitness : solution -> Float
    , goal : Goal
    , generations : Int
    , populationSize : Int
    , initialPopulation : Maybe (List solution)
    , mutationRate : Float
    , crossoverRate : Float
    , elitismRate : Float
    }


type Goal
    = Minimize
    | Maximize


run : Config a -> Generator (Maybe { best : a, population : List a })
run config =
    let
        goalSortFn =
            case config.goal of
                Minimize ->
                    identity

                Maximize ->
                    negate

        sortFn =
            goalSortFn << config.fitness

        initialPopulation =
            config.initialPopulation
                |> Maybe.map Random.constant
                |> Maybe.withDefault (Random.list config.populationSize config.newSolution)

        eliteCount : Int
        eliteCount =
            round (toFloat config.populationSize * config.elitismRate)

        mutateCount : Int
        mutateCount =
            round (toFloat config.populationSize * config.mutationRate)

        crossoverCount : Int
        crossoverCount =
            2 * round (toFloat config.populationSize * config.crossoverRate)

        go : Int -> List a -> Generator (Maybe { best : a, population : List a })
        go generationsLeft currentPopulation =
            if generationsLeft > 0 then
                let
                    elite : List a
                    elite =
                        currentPopulation
                            |> List.sortBy sortFn
                            |> List.take eliteCount

                    newPopulation : Generator (List a)
                    newPopulation =
                        Random.map2
                            (\fromMutation fromCrossover ->
                                elite
                                    ++ fromMutation
                                    ++ fromCrossover
                            )
                            (Random.List.choices mutateCount currentPopulation
                                |> Random.andThen
                                    (Tuple.first
                                        >> List.map config.mutate
                                        >> Random.sequence
                                    )
                            )
                            (Random.List.choices crossoverCount currentPopulation
                                |> Random.andThen
                                    (Tuple.first
                                        >> List.groupsOf 2
                                        >> List.filterMap
                                            (\chosenTwo ->
                                                case chosenTwo of
                                                    [ x1, x2 ] ->
                                                        Just (config.crossover x1 x2)

                                                    _ ->
                                                        Nothing
                                            )
                                        >> Random.sequence
                                    )
                            )
                            |> Random.andThen
                                (\list ->
                                    let
                                        leftToGenerate : Int
                                        leftToGenerate =
                                            config.populationSize - List.length list
                                    in
                                    Random.list leftToGenerate config.newSolution
                                        |> Random.map ((++) list)
                                )
                in
                newPopulation
                    |> Random.andThen (go (generationsLeft - 1))

            else
                currentPopulation
                    |> List.sortBy sortFn
                    |> List.head
                    |> Maybe.map
                        (\best ->
                            { best = best
                            , population = currentPopulation
                            }
                        )
                    |> Random.constant
    in
    initialPopulation
        |> Random.andThen (go config.generations)