diff --git a/lambda/src/Main.hs b/lambda/src/Main.hs index d258a6c..cccea44 100644 --- a/lambda/src/Main.hs +++ b/lambda/src/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -52,10 +53,16 @@ main = execParser optionsWithHelp >>= \opts -> do hSetBuffering stdout NoBuffering lEE <- shuffledLEE - let env = lE - let selType = Tournament 3 - let run' = run lEE env selType 120 (5 / 100) (populationSize opts) (steps (iterations opts)) - pop' <- runEffect (for run' logCsv) + let cfg = GaRunConfig { + enviroment = lE, + initialEvaluator = lEE, + selectionType = Tournament 3, + termination = (steps (iterations opts)), + poulationSize = (populationSize opts), + stepSize = 120, + elitismRatio = 5/100 + } + pop' <- runEffect (for (run cfg) logCsv) lEE' <- calc lEE pop' let (res, _) = bests lEE' 5 pop' let lEE' = lEE {training = False} diff --git a/lib/GA.hs b/lib/GA.hs index 9c422c3..82de9d0 100644 --- a/lib/GA.hs +++ b/lib/GA.hs @@ -6,7 +6,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} - +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : GA -- Description : Abstract genetic algorithm @@ -20,7 +24,7 @@ -- In order to use it for a certain problem, basically, you have to make your -- solution type an instance of 'Individual' and then simply call the 'run' -- function. -module GA (Environment, new, population, mutate, crossover1, crossover, nX, Fitness, getR, Evaluator, fitness,fitness', calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where +module GA (Environment (..), Fitness (..), Evaluator (..), Individual (..), GA.run, Tournament (..), N, R, Population, steps, bests, runTests, GaRunConfig (..)) where import Control.Arrow hiding (first, second) import Data.List.NonEmpty ((<|)) @@ -47,7 +51,7 @@ type R = Double -- | -- An Environment that Individuals of type i can be created from -- It stores all information required to create and change Individuals correctly -class (Pretty e, Individual i) => Environment i e | e -> i where +class (Pretty e, Individual i) => Environment i e | e -> i, i -> e where -- | -- Generates a completely random individual. new :: e -> RVar i @@ -84,7 +88,7 @@ class (Pretty e, Individual i) => Environment i e | e -> i where -- | -- An Evaluator that Individuals of type i can be evaluated by -- It stores all information required to evaluate an individuals fitness -class (Individual i, Fitness r) => Evaluator i e r | i -> e r where +class (Individual i, Fitness r) => Evaluator i e r | e -> i r, i -> e where -- | -- An individual's fitness. Higher values are considered “better”. -- @@ -212,21 +216,25 @@ selectBest eval pElite pop nPop = do then return elitists else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest)) -run :: - (Individual i, Evaluator i eval r, Environment i env, SelectionType s) => - eval -> - env -> - -- | Mechanism for selecting parents - s -> - -- | Number of parents @nParents@ for creating @nParents@ children - N -> - -- | Elitism ratio @pElite@ - R -> - -- | Population size - N -> - Termination i -> - Producer (Int, r) IO (Population i) -run eval env selectionType nParents pElite nPop term = do + +-- This class encapsulates everything needed to run a generic genetic Algorithm +data GaRunConfig i r eval env t where + GaRunConfig :: (Individual i, Fitness r, Evaluator i eval r, Environment i env, SelectionType t) => { + enviroment :: env, + initialEvaluator :: eval, + selectionType :: t, + termination :: (Termination i), + poulationSize :: N, + stepSize :: N, + elitismRatio :: R + } -> GaRunConfig i r eval env t + + +run :: GaRunConfig i r eval env t -> Producer (Int, r) IO (Population i) +run config@(GaRunConfig _ _ _ _ _ _ _) = do + let eval = initialEvaluator config + let env = enviroment config + let nPop = poulationSize config mwc <- liftIO createSystemRandom let smpl = ((sampleFrom mwc) :: RVar a -> IO a) firstPop <- liftIO $ smpl $ (population env nPop) @@ -234,12 +242,17 @@ run eval env selectionType nParents pElite nPop term = do return res where runIter eval count pop smpl = ( - if term pop count + if (termination config) pop count then do return pop else do + let env = enviroment config + let nPop = poulationSize config + let selecType = selectionType config + let nParents = stepSize config + let pElite = elitismRatio config eval <- liftIO $ calc eval pop - withKids <- liftIO $ smpl $ reproduce eval env selectionType nParents pop + withKids <- liftIO $ smpl $ reproduce eval env selecType nParents pop eval <- liftIO $ calc eval withKids resPop <- liftIO $ smpl $ selectBest eval pElite withKids nPop let fBest = fitness' eval $ NE.head $ fst $ bests eval 1 resPop diff --git a/src-students/Main.hs b/src-students/Main.hs index 387ab5f..55a60f5 100644 --- a/src-students/Main.hs +++ b/src-students/Main.hs @@ -48,15 +48,20 @@ main :: IO () main = execParser optionsWithHelp >>= \opts -> do hSetBuffering stdout NoBuffering - let seminarEE = prios - let env = AssignmentEnviroment (students seminarEE, topics seminarEE) - let selType = Tournament 3 - let run' = run seminarEE env selType 120 (5 / 100) (populationSize opts) (steps (iterations opts)) - pop' <- runEffect (for run' logCsv) - seminarEE' <- calc seminarEE pop' - let (res, _) = bests seminarEE' 5 pop' - seminarEE' <- calc seminarEE' res - mapM_ (format seminarEE') res + let cfg = GaRunConfig { + enviroment = AssignmentEnviroment (students prios, topics prios), + initialEvaluator = prios, + selectionType = Tournament 3, + termination = (steps (iterations opts)), + poulationSize = (populationSize opts), + stepSize = 120, + elitismRatio = 5/100 + } + pop' <- runEffect (for (run cfg) logCsv) + prios' <- calc prios pop' + let (res, _) = bests prios' 5 pop' + prios' <- calc prios' res + mapM_ (format prios') res where format seminarL s = do let f = fitness' seminarL s