restructuring done

This commit is contained in:
Johannes Merl 2024-02-27 13:20:33 +01:00
parent a4012804fb
commit 233bc40a51
5 changed files with 141 additions and 146 deletions

259
src/GA.hs
View File

@ -1,11 +1,12 @@
{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- | -- |
-- Module : GA -- Module : GA
-- Description : Abstract genetic algorithm -- Description : Abstract genetic algorithm
@ -19,18 +20,18 @@
-- In order to use it for a certain problem, basically, you have to make your -- 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' -- solution type an instance of 'Individual' and then simply call the 'run'
-- function. -- function.
module GA ( Environment,new, population, mutate, crossover1,crossover, Evaluator, fitness, calc, Individual, GA.run, tournament, N, R, Population, steps, bests, runTests) where module GA (Environment, new, population, mutate, crossover1, crossover, nX, Evaluator, fitness, calc, Individual, GA.run, Tournament (..), N, R, Population, steps, bests, runTests) where
import Control.Arrow hiding (first, second) import Control.Arrow hiding (first, second)
import Data.List.NonEmpty ((<|)) import Data.List.NonEmpty ((<|))
import qualified Data.Map.Strict as Map
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.List.NonEmpty.Extra as NE (appendl) import qualified Data.List.NonEmpty.Extra as NE (appendl)
import qualified Data.Map.Strict as Map
import Data.Random import Data.Random
import System.Random.MWC (create)
import Pipes import Pipes
import Protolude
import Pretty import Pretty
import Protolude
import System.Random.MWC (create)
import Test.QuickCheck hiding (sample, shuffle) import Test.QuickCheck hiding (sample, shuffle)
import Test.QuickCheck.Instances () import Test.QuickCheck.Instances ()
import Test.QuickCheck.Monadic import Test.QuickCheck.Monadic
@ -42,15 +43,12 @@ type N = Int
type R = Double type R = Double
-- | -- |
-- An Environment that Individuals of type i can be created from -- An Environment that Individuals of type i can be created from
-- It stores all information required to create and change Individuals correctly -- 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 where
-- | -- |
-- Generates a completely random individual. -- Generates a completely random individual.
--
new :: e -> RVar i new :: e -> RVar i
-- | -- |
@ -64,6 +62,7 @@ class (Pretty e, Individual i) => Environment i e where
crossover1 :: e -> i -> i -> RVar (Maybe (i, i)) crossover1 :: e -> i -> i -> RVar (Maybe (i, i))
nX :: e -> N
-- | -- |
-- Performs an n-point crossover. -- Performs an n-point crossover.
@ -71,17 +70,19 @@ class (Pretty e, Individual i) => Environment i e where
-- Given the function for single-point crossover, 'crossover1', this function can -- Given the function for single-point crossover, 'crossover1', this function can
-- be derived through recursion and a monad combinator (which is also the default -- be derived through recursion and a monad combinator (which is also the default
-- implementation). -- implementation).
crossover :: e -> N -> i -> i -> RVar (Maybe (i, i)) crossover :: e -> i -> i -> RVar (Maybe (i, i))
crossover env n i1 i2 crossover e = crossover' e (nX e)
crossover' :: e -> N -> i -> i -> RVar (Maybe (i, i))
crossover' env n i1 i2
| n <= 0 = return $ Just (i1, i2) | n <= 0 = return $ Just (i1, i2)
| otherwise = do | otherwise = do
isM <- crossover1 env i1 i2 isM <- crossover1 env i1 i2
maybe (return Nothing) (uncurry (crossover env (n - 1))) isM maybe (return Nothing) (uncurry (crossover' env (n - 1))) isM
-- | -- |
-- An Evaluator that Individuals of type i can be evaluated by -- An Evaluator that Individuals of type i can be evaluated by
-- It stores all information required to evaluate an individuals fitness -- It stores all information required to evaluate an individuals fitness
--
class (Individual i) => Evaluator i e where class (Individual i) => Evaluator i e where
-- | -- |
-- An individual's fitness. Higher values are considered “better”. -- An individual's fitness. Higher values are considered “better”.
@ -91,15 +92,12 @@ class (Individual i) => Evaluator i e where
fitness :: e -> i -> R fitness :: e -> i -> R
-- TODO kinda hacky?!? -- TODO kinda hacky?!?
calc :: e -> Population i -> IO e calc :: e -> Population i -> IO e
calc eval _ = do calc eval _ = do
return eval return eval
class (Pretty i, Ord i) => Individual i class (Pretty i, Ord i) => Individual i
-- | -- |
-- Populations are just basic non-empty lists. -- Populations are just basic non-empty lists.
type Population i = NonEmpty i type Population i = NonEmpty i
@ -109,20 +107,17 @@ type Population i = NonEmpty i
children :: children ::
(Individual i, Environment i e) => (Individual i, Environment i e) =>
e -> e ->
-- | The @nX@ of the @nX@-point crossover operator
N ->
NonEmpty i -> NonEmpty i ->
RVar (NonEmpty i) RVar (NonEmpty i)
children e _ (i :| []) = (:| []) <$> mutate e i children e (i :| []) = (:| []) <$> mutate e i
children e nX (i1 :| [i2]) = children2 e nX i1 i2 children e (i1 :| [i2]) = children2 e i1 i2
children e nX (i1 :| i2 : is') = children e (i1 :| i2 : is') =
(<>) <$> children2 e nX i1 i2 <*> children e nX (NE.fromList is') (<>) <$> children2 e i1 i2 <*> children e (NE.fromList is')
children2 :: (Individual i, Environment i e) => e -> i -> i -> RVar (NonEmpty i)
children2 :: (Individual i, Environment i e) => e -> N -> i -> i -> RVar (NonEmpty i) children2 e i1 i2 = do
children2 e nX i1 i2 = do
-- TODO Add crossover probability? -- TODO Add crossover probability?
(i3, i4) <- fromMaybe (i1, i2) <$> crossover e nX i1 i2 (i3, i4) <- fromMaybe (i1, i2) <$> crossover e i1 i2
i5 <- mutate e i3 i5 <- mutate e i3
i6 <- mutate e i4 i6 <- mutate e i4
return $ i5 :| [i6] return $ i5 :| [i6]
@ -140,8 +135,9 @@ bestsBy ::
(NonEmpty i, [i]) (NonEmpty i, [i])
bestsBy k f pop bestsBy k f pop
| k <= 0 = bestsBy 1 f pop | k <= 0 = bestsBy 1 f pop
| otherwise = let (elites, rest) = NE.splitAt k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop | otherwise =
in (NE.fromList elites, rest) let (elites, rest) = NE.splitAt k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
in (NE.fromList elites, rest)
-- | -- |
-- The @k@ best individuals in the population when comparing using the supplied -- The @k@ best individuals in the population when comparing using the supplied
@ -151,7 +147,6 @@ bestsBy' k f pop
| k <= 0 = bestsBy' 1 f pop | k <= 0 = bestsBy' 1 f pop
| otherwise = NE.take k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop | otherwise = NE.take k $ map fst $ NE.sortBy (comparing (Down . snd)) $ map (\i -> (i, f i)) pop
-- | -- |
-- The @k@ worst individuals in the population (and the rest of the population). -- The @k@ worst individuals in the population (and the rest of the population).
worst :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i]) worst :: (Individual i, Evaluator i e) => e -> N -> Population i -> (NonEmpty i, [i])
@ -164,109 +159,95 @@ bests e k = bestsBy k (fitness e)
-- TODO add top x percent parent selection (select n guys, sort by fitness first) -- TODO add top x percent parent selection (select n guys, sort by fitness first)
-- | reproduce ::
-- Performs one iteration of a steady state genetic algorithm that in each (Individual i, Environment i env, Evaluator i eval, SelectionType s) =>
-- iteration that creates @k@ offspring simply deletes the worst @k@ individuals
-- while making sure that the given percentage of elitists survive (at least 1
-- elitist, even if the percentage is 0 or low enough for rounding to result in 0
-- elitists).
stepSteady ::
(Individual i, Evaluator i eval, Environment i env ) =>
eval -> eval ->
env -> env ->
-- | Mechanism for selecting parents -- | Mechanism for selecting parents
Selection RVar i -> s ->
-- | Number of parents @nParents@ for creating @nParents@ children -- | Number of parents @nParents@ for creating @nParents@ children
N -> N ->
-- | How many crossover points (the @nX@ in @nX@-point crossover) Population i ->
N -> RVar (Population i)
reproduce eval env selectT nParents pop = do
iParents <- select selectT nParents pop eval
iChildren <- NE.filter (`notElem` pop) <$> children env iParents
let pop' = pop `NE.appendl` iChildren
return pop'
selectBest ::
(Individual i, Evaluator i eval) =>
eval ->
-- | Elitism ratio @pElite@ -- | Elitism ratio @pElite@
R -> R ->
Population i -> Population i ->
-- | How many individuals should be selected
N ->
RVar (Population i) RVar (Population i)
stepSteady eval env select nParents nX pElite pop = do selectBest eval pElite pop nPop = do
-- TODO Consider keeping the fitness evaluations already done for pop (so we let eliteSize = floor . (pElite *) . fromIntegral $ nPop
-- only reevaluate iChildren) let (elitists, rest) = bests eval eliteSize pop
iParents <- select nParents pop
iChildren <- NE.filter (`notElem` pop) <$> children env nX iParents
let pop' = pop `NE.appendl` iChildren
-- TODO kinda hacky?!?
eval <- liftIO $ calc eval pop'
let eliteSize = floor . (pElite *) . fromIntegral $ NE.length pop
let (elitists, rest) = bests eval eliteSize pop'
case rest of case rest of
[] -> return elitists [] -> return elitists
_notEmpty -> _notEmpty ->
-- NOTE 'bests' always returns at least one individual, thus we need this -- NOTE 'bests' always returns at least one individual, thus we need this
-- slightly ugly branching -- slightly ugly branching
if length elitists == length pop if length elitists == nPop
then return elitists then return elitists
else else return $ elitists <> (fst $ bests eval (nPop - length elitists) (NE.fromList rest))
return $ elitists <> (fst $ bests eval (length pop - length elitists) (NE.fromList rest))
-- |
-- Given an Enviroment and Evaluator, runs the GA until the termination criterion is
-- fulfilled.
--
-- Uses the pipes library to, in each step, 'Pipes.yield' the currently best known
-- solution.
run :: run ::
(Individual i, Evaluator i eval, Environment i env ) => (Individual i, Evaluator i eval, Environment i env, SelectionType s) =>
eval -> eval ->
env -> env ->
-- | Mechanism for selecting parents -- | Mechanism for selecting parents
Selection RVar i -> s ->
-- | Number of parents @nParents@ for creating @nParents@ children -- | Number of parents @nParents@ for creating @nParents@ children
N -> N ->
-- | How many crossover points (the @nX@ in @nX@-point crossover)
N ->
-- | Elitism ratio @pElite@ -- | Elitism ratio @pElite@
R -> R ->
-- | Population size -- | Population size
N -> N ->
Termination i -> Termination i ->
Producer (Int, R) IO (Population i) Producer (Int, R) IO (Population i)
run eval env select nParents nX pElite nPop term = do run eval env selectionType nParents pElite nPop term = do
mwc <- lift create mwc <- liftIO create
let x = \currPop generation -> do let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
currPop' <- lift $ sampleFrom mwc $ currPop firstPop <- liftIO $ smpl $ (population env nPop)
if term currPop' generation _ <- liftIO $ putText $ pretty $ NE.head firstPop
then return currPop' firstPop <- liftIO $ smpl $ (population env nPop)
else do _ <- liftIO $ putText $ pretty $ NE.head firstPop
let nextPop = stepSteady eval env select nParents nX pElite currPop' res <- runIter eval 0 firstPop smpl
let fBest = fitness eval $ NE.head $ fst $ bests eval 1 currPop' return res
Pipes.yield (generation, fBest) where
x nextPop (generation + 1) runIter eval count pop smpl =
x (population env nPop) 0 if term pop count
then do
return pop
else do
eval <- liftIO $ calc eval pop
withKids <- liftIO $ smpl $ reproduce eval env selectionType 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
Pipes.yield (count, fBest)
res <- runIter eval (count + 1) resPop smpl
return res
-- * Selection mechanisms -- * Selection mechanisms
-- | -- |
-- A function generating a monadic action which selects a given number of -- A function generating a monadic action which selects a given number of
-- individuals from the given population. -- individuals from the given population.
type Selection m i = N -> Population i -> m (NonEmpty i) data Tournament = Tournament N
-- | class SelectionType t where
-- Selects @n@ individuals from the population the given mechanism by repeatedly select :: (Individual i, Evaluator i e) => t -> N -> Population i -> e -> RVar (NonEmpty i)
-- selecting a single individual using the given selection mechanism (with
-- replacement, so the same individual can be selected multiple times).
chain ::
(Individual i) =>
(Population i -> RVar i) ->
Selection RVar i
-- TODO Ensure that the same individual is not selected multiple times
-- (require Selections to partition)
chain select1 n pop
| n > 1 = (<|) <$> select1 pop <*> chain select1 (n - 1) pop
| otherwise = (:|) <$> select1 pop <*> return []
-- | -- type Selection m i = N -> Population i -> m (NonEmpty i)
-- Selects @n@ individuals from the population by repeatedly selecting a single
-- indidual using a tournament of the given size (the same individual can be instance SelectionType Tournament where
-- selected multiple times, see 'chain'). select (Tournament i) count pop eval = fmap NE.fromList (replicateM count (tournament1 eval i pop))
tournament :: (Individual i, Evaluator i e) => e -> N -> Selection RVar i
tournament eval nTrnmnt = chain (tournament1 eval nTrnmnt)
-- | -- |
-- Selects one individual from the population using tournament selection. -- Selects one individual from the population using tournament selection.
@ -281,8 +262,8 @@ tournament1 eval nTrnmnt pop
-- TODO Use Positive for this constraint -- TODO Use Positive for this constraint
| nTrnmnt <= 0 = undefined | nTrnmnt <= 0 = undefined
| otherwise = do | otherwise = do
paricipants <- withoutReplacement nTrnmnt pop paricipants <- withoutReplacement nTrnmnt pop
return $ NE.head $ fst $ bests eval 1 paricipants return $ NE.head $ fst $ bests eval 1 paricipants
-- | -- |
-- Selects @n@ individuals uniformly at random from the population (without -- Selects @n@ individuals uniformly at random from the population (without
@ -317,35 +298,32 @@ shuffle' :: NonEmpty a -> RVar (NonEmpty a)
shuffle' xs@(_ :| []) = return xs shuffle' xs@(_ :| []) = return xs
shuffle' xs = fmap (NE.fromList) (shuffle (toList xs)) shuffle' xs = fmap (NE.fromList) (shuffle (toList xs))
instance Pretty Integer where instance Pretty Integer where
pretty i = "Found int: " <> show i pretty i = "Found int: " <> show i
instance Individual Integer instance Individual Integer
newtype IntTestEnviroment = IntTestEnviroment ((Integer,Integer),Integer) deriving (Eq) -- IntTestEnviroment ((0,100000),10) newtype IntTestEnviroment = IntTestEnviroment ((Integer, Integer), Integer, N) deriving (Eq) -- IntTestEnviroment ((0,100000),10)
instance Pretty IntTestEnviroment where instance Pretty IntTestEnviroment where
-- instance Pretty (Maybe Student) where -- instance Pretty (Maybe Student) where
pretty (IntTestEnviroment ((i,j),k)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k) pretty (IntTestEnviroment ((i, j), k, _)) = "IntTestEnviroment of Individuals between " <> (show i) <> " and " <> (show j) <> " variance when mutating is " <> (show k)
instance Environment Integer IntTestEnviroment where instance Environment Integer IntTestEnviroment where
new (IntTestEnviroment ((from, to), _, _)) = uniform from to
new (IntTestEnviroment ((from,to),_)) = uniform from to nX (IntTestEnviroment ((_, _), _, n)) = n
mutate (IntTestEnviroment ((from,to),wiggle)) i = uniform (max from (i - wiggle)) (min to (i + wiggle)) mutate (IntTestEnviroment ((from, to), wiggle, _)) i = uniform (max from (i - wiggle)) (min to (i + wiggle))
crossover1 _ i1 i2 = do crossover1 _ i1 i2 = do
i1' <- uniform i1 i2 i1' <- uniform i1 i2
i2' <- uniform i1 i2 i2' <- uniform i1 i2
return $ Just (i1',i2') return $ Just (i1', i2')
data NoData = NoData deriving (Eq) data NoData = NoData deriving (Eq)
instance Evaluator Integer NoData where instance Evaluator Integer NoData where
fitness _ = fromIntegral . negate fitness _ = fromIntegral . negate
prop_children_asManyAsParents :: prop_children_asManyAsParents ::
@ -354,12 +332,11 @@ prop_children_asManyAsParents nX is =
again $ again $
monadicIO $ monadicIO $
do do
let e = IntTestEnviroment ((0,100000),10) let e = IntTestEnviroment ((0, 100000), 10, nX)
mwc <- Test.QuickCheck.Monadic.run create mwc <- Test.QuickCheck.Monadic.run create
is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children e nX is) is' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (children e is)
return $ counterexample (show is') $ length is' == length is return $ counterexample (show is') $ length is' == length is
prop_bestsBy_isBestsBy' :: Int -> Population Integer -> Property prop_bestsBy_isBestsBy' :: Int -> Population Integer -> Property
prop_bestsBy_isBestsBy' k pop = prop_bestsBy_isBestsBy' k pop =
k > 0 ==> k > 0 ==>
@ -375,21 +352,23 @@ prop_bestsBy_lengths k pop =
let (bests, rest) = bestsBy k (fitness NoData) pop let (bests, rest) = bestsBy k (fitness NoData) pop
assert $ assert $
length bests == min k (length pop) && length bests + length rest == length pop length bests == min k (length pop) && length bests + length rest == length pop
prop_stepSteady_constantPopSize ::
NonEmpty Integer -> Property -- TODO: re-add!
prop_stepSteady_constantPopSize pop = -- prop_stepSteady_constantPopSize ::
forAll -- NonEmpty Integer -> Property
( (,) -- prop_stepSteady_constantPopSize pop =
<$> choose (1, length pop) -- forAll
<*> choose (1, length pop) -- ( (,)
) -- <$> choose (1, length pop)
$ \(nParents, nX) -> monadicIO $ do -- <*> choose (1, length pop)
let pElite = 0.1 -- )
let eval = NoData -- $ \(nParents, nX) -> monadicIO $ do
let env = IntTestEnviroment ((0,100000),10) -- let pElite = 0.1
mwc <- Test.QuickCheck.Monadic.run create -- let eval = NoData
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady eval env (tournament eval 4) nParents nX pElite pop) -- let env = IntTestEnviroment ((0, 100000), 10, nX)
return . counterexample (show pop') $ length pop' == length pop -- mwc <- Test.QuickCheck.Monadic.run create
-- pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (stepSteady eval env (tournament eval 4) nParents nX pElite pop)
-- return . counterexample (show pop') $ length pop' == length pop
prop_tournament_selectsN :: Int -> Int -> NonEmpty Integer -> Property prop_tournament_selectsN :: Int -> Int -> NonEmpty Integer -> Property
prop_tournament_selectsN nTrnmnt n pop = prop_tournament_selectsN nTrnmnt n pop =
@ -399,21 +378,27 @@ prop_tournament_selectsN nTrnmnt n pop =
==> monadicIO ==> monadicIO
$ do $ do
mwc <- Test.QuickCheck.Monadic.run create mwc <- Test.QuickCheck.Monadic.run create
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (tournament NoData 2 n pop) pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (select (Tournament 2) n pop NoData)
assert $ length pop' == n assert $ length pop' == n
prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
prop_withoutReplacement_selectsN n pop = prop_withoutReplacement_selectsN n pop =
0 < n && n <= length pop ==> monadicIO (do 0 < n && n <= length pop ==>
mwc <- Test.QuickCheck.Monadic.run create monadicIO
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop) ( do
assert $ length pop' == n) mwc <- Test.QuickCheck.Monadic.run create
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
assert $ length pop' == n
)
prop_shuffle_length :: NonEmpty a -> Property prop_shuffle_length :: NonEmpty a -> Property
prop_shuffle_length xs = monadicIO(do prop_shuffle_length xs =
mwc <- Test.QuickCheck.Monadic.run create monadicIO
xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs) ( do
assert $ length xs' == length xs) mwc <- Test.QuickCheck.Monadic.run create
xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
assert $ length xs' == length xs
)
runTests :: IO Bool runTests :: IO Bool
runTests = $quickCheckAll runTests = $quickCheckAll

View File

@ -5,12 +5,15 @@
{-# LANGUAGE Trustworthy #-} {-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
module LambdaCalculus where module LambdaCalculus where
import Data.Dynamic import Data.Dynamic
import Data.List (foldr1, last, lookup, zipWith3, (!!), (\\)) import Data.List (foldr1, last, lookup, zipWith3, (!!), (\\))
import Data.List.Extra (delete, nubOrd, nubOrdOn) import Data.List.Extra (delete, nubOrd, nubOrdOn)
import Data.Tuple.Extra
import qualified Data.List.NonEmpty as NE import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map import qualified Data.Map.Strict as Map
import Data.Maybe import Data.Maybe
@ -242,7 +245,6 @@ genLambdaVar' tr varType varNumber trs env@(LambdaEnviroment functions constants
ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar ret <- genLambdaVar' rest varType varNumber (trs ++ [newTypeRequ]) env depthLeft target boundVar
return ret return ret
instance Environment TypeRequester LambdaEnviroment where instance Environment TypeRequester LambdaEnviroment where
new env@(LambdaEnviroment _ _ target maxDepth _) = do new env@(LambdaEnviroment _ _ target maxDepth _) = do
tr <- genTypeRequester env maxDepth target [] tr <- genTypeRequester env maxDepth target []
@ -255,6 +257,8 @@ instance Environment TypeRequester LambdaEnviroment where
res <- genTypeRequester env depthAt trep bound res <- genTypeRequester env depthAt trep bound
return $ replaceAtR selectedTR tr res return $ replaceAtR selectedTR tr res
nX _ = 3 --todo!
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
return Nothing return Nothing
@ -278,18 +282,21 @@ instance Evaluator TypeRequester LamdaExecutionEnv where
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)] evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)]
evalResults ex trs = mapM (evalResult ex) trs evalResults ex trs = mapM (evalResult ex) trs
data IrisClass = Setosa | Virginica | Versicolor data IrisClass = Setosa | Virginica | Versicolor deriving (Eq, Generic, Show)
instance FromRecord IrisClass
instance ToRecord IrisClass
evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R) evalResult :: LamdaExecutionEnv -> TypeRequester -> Hint.InterpreterT IO (TypeRequester, R)
evalResult ex tr = do evalResult ex tr = do
Hint.loadModules (map show (imports ex)) Hint.loadModules (map show (imports ex))
result <- Hint.interpret (show (toLambdaExpressionS tr)) (Hint.as ::R -> R -> R -> IrisClass) result <- Hint.interpret (show (toLambdaExpressionS tr)) (Hint.as ::R -> R -> R -> IrisClass)
csv <- liftIO $ B.readFile (trainingDataset ex) csv <- liftIO $ B.readFile (trainingDataset ex)
let recs = toList $ fromRight undefined $ decode NoHeader csv let recs = (toList $ fromRight undefined $ decode NoHeader csv) :: [(R,R,R)]
let res = map (show (uncurry result)) recs let res = map ((uncurry3 result)) recs
csvRes <- liftIO $ B.readFile (trainingDatasetRes ex) csvRes <- liftIO $ B.readFile (trainingDatasetRes ex)
let recsRes = toList $ fromRight undefined $ decode NoHeader csvRes let recsRes = (toList $ fromRight undefined $ decode NoHeader csvRes) :: [IrisClass]
let score = (foldr (\ts s -> if fst ts == snd ts then s + 1 else s - 1) 0 (zip recsRes res)) :: R let score = (foldr (\ts s -> if (fst ts) == (snd ts) then s + 1 else s - 1) 0 (zip recsRes res)) :: R
return (tr, score) return (tr, score)

View File

@ -49,7 +49,8 @@ main =
execParser optionsWithHelp >>= \opts -> do execParser optionsWithHelp >>= \opts -> do
hSetBuffering stdout NoBuffering hSetBuffering stdout NoBuffering
let env = AssignmentEnviroment (students prios, topics prios) let env = AssignmentEnviroment (students prios, topics prios)
let run' = run prios env (tournament prios 2) 2 1 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment) let selType = Tournament 2
let run' = run prios env selType 2 (5 / 100) (populationSize opts) (steps (iterations opts)) :: Producer (Int, R) IO (Population Assignment)
pop' <- pop' <-
runEffect (for run' logCsv) runEffect (for run' logCsv)
let (res, _) = bests prios 5 pop' let (res, _) = bests prios 5 pop'

View File

@ -116,6 +116,8 @@ instance Environment Assignment AssignmentEnviroment where
mixedAssignables <- shuffle paddedAssignables mixedAssignables <- shuffle paddedAssignables
return $ zip paddedPersons mixedAssignables return $ zip paddedPersons mixedAssignables
nX _ = 1
mutate _ assignment = do mutate _ assignment = do
x <- uniform 0 (length assignment - 1) x <- uniform 0 (length assignment - 1)
y <- uniform 0 (length assignment - 1) y <- uniform 0 (length assignment - 1)

View File

@ -24,9 +24,9 @@ main = do
--_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text) --_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Int -> Int -> Int -> Text))))) :: Text)
--_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text) --_ <- putStrLn $ ((show (typeRepArgs (Ref.SomeTypeRep (Ref.TypeRep @(Text))))) :: Text)
mwc <- createSystemRandom mwc <- createSystemRandom
r <- sampleFrom mwc $ LambdaCalculus.new LambdaCalculus.exampleLE r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r _ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
r <- sampleFrom mwc $ LambdaCalculus.new LambdaCalculus.exampleLE r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r _ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
--_ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect) --_ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
--_ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text) --_ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)