restructuring done
This commit is contained in:
Johannes Merl
parent
a4012804fb
commit
233bc40a51
259
src/GA.hs
259
src/GA.hs
|
|
@ -1,11 +1,12 @@
|
|||
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
-- |
|
||||
-- Module : GA
|
||||
-- Description : Abstract genetic algorithm
|
||||
|
|
@ -19,18 +20,18 @@
|
|||
-- 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, 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 Data.List.NonEmpty ((<|))
|
||||
import qualified Data.Map.Strict as Map
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.List.NonEmpty.Extra as NE (appendl)
|
||||
import qualified Data.Map.Strict as Map
|
||||
import Data.Random
|
||||
import System.Random.MWC (create)
|
||||
import Pipes
|
||||
import Protolude
|
||||
import Pretty
|
||||
import Protolude
|
||||
import System.Random.MWC (create)
|
||||
import Test.QuickCheck hiding (sample, shuffle)
|
||||
import Test.QuickCheck.Instances ()
|
||||
import Test.QuickCheck.Monadic
|
||||
|
|
@ -42,15 +43,12 @@ type N = Int
|
|||
|
||||
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 where
|
||||
class (Pretty e, Individual i) => Environment i e | e -> i where
|
||||
-- |
|
||||
-- Generates a completely random individual.
|
||||
--
|
||||
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))
|
||||
|
||||
nX :: e -> N
|
||||
|
||||
-- |
|
||||
-- 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
|
||||
-- be derived through recursion and a monad combinator (which is also the default
|
||||
-- implementation).
|
||||
crossover :: e -> N -> i -> i -> RVar (Maybe (i, i))
|
||||
crossover env n i1 i2
|
||||
crossover :: e -> i -> i -> RVar (Maybe (i, i))
|
||||
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)
|
||||
| otherwise = do
|
||||
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
|
||||
-- It stores all information required to evaluate an individuals fitness
|
||||
--
|
||||
class (Individual i) => Evaluator i e where
|
||||
-- |
|
||||
-- An individual's fitness. Higher values are considered “better”.
|
||||
|
|
@ -91,15 +92,12 @@ class (Individual i) => Evaluator i e where
|
|||
fitness :: e -> i -> R
|
||||
|
||||
-- TODO kinda hacky?!?
|
||||
calc :: e -> Population i -> IO e
|
||||
calc :: e -> Population i -> IO e
|
||||
calc eval _ = do
|
||||
return eval
|
||||
|
||||
|
||||
class (Pretty i, Ord i) => Individual i
|
||||
|
||||
|
||||
|
||||
-- |
|
||||
-- Populations are just basic non-empty lists.
|
||||
type Population i = NonEmpty i
|
||||
|
|
@ -109,20 +107,17 @@ type Population i = NonEmpty i
|
|||
children ::
|
||||
(Individual i, Environment i e) =>
|
||||
e ->
|
||||
-- | The @nX@ of the @nX@-point crossover operator
|
||||
N ->
|
||||
NonEmpty i ->
|
||||
RVar (NonEmpty i)
|
||||
children e _ (i :| []) = (:| []) <$> mutate e i
|
||||
children e nX (i1 :| [i2]) = children2 e nX i1 i2
|
||||
children e nX (i1 :| i2 : is') =
|
||||
(<>) <$> children2 e nX i1 i2 <*> children e nX (NE.fromList is')
|
||||
children e (i :| []) = (:| []) <$> mutate e i
|
||||
children e (i1 :| [i2]) = children2 e i1 i2
|
||||
children e (i1 :| i2 : is') =
|
||||
(<>) <$> children2 e i1 i2 <*> children e (NE.fromList is')
|
||||
|
||||
|
||||
children2 :: (Individual i, Environment i e) => e -> N -> i -> i -> RVar (NonEmpty i)
|
||||
children2 e nX i1 i2 = do
|
||||
children2 :: (Individual i, Environment i e) => e -> i -> i -> RVar (NonEmpty i)
|
||||
children2 e i1 i2 = do
|
||||
-- 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
|
||||
i6 <- mutate e i4
|
||||
return $ i5 :| [i6]
|
||||
|
|
@ -140,8 +135,9 @@ bestsBy ::
|
|||
(NonEmpty i, [i])
|
||||
bestsBy k 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
|
||||
in (NE.fromList elites, rest)
|
||||
| otherwise =
|
||||
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
|
||||
|
|
@ -151,7 +147,6 @@ bestsBy' k 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
|
||||
|
||||
|
||||
-- |
|
||||
-- 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])
|
||||
|
|
@ -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)
|
||||
|
||||
-- |
|
||||
-- Performs one iteration of a steady state genetic algorithm that in each
|
||||
-- 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 ) =>
|
||||
reproduce ::
|
||||
(Individual i, Environment i env, Evaluator i eval, SelectionType s) =>
|
||||
eval ->
|
||||
env ->
|
||||
-- | Mechanism for selecting parents
|
||||
Selection RVar i ->
|
||||
s ->
|
||||
-- | Number of parents @nParents@ for creating @nParents@ children
|
||||
N ->
|
||||
-- | How many crossover points (the @nX@ in @nX@-point crossover)
|
||||
N ->
|
||||
Population i ->
|
||||
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@
|
||||
R ->
|
||||
Population i ->
|
||||
-- | How many individuals should be selected
|
||||
N ->
|
||||
RVar (Population i)
|
||||
stepSteady eval env select nParents nX pElite pop = do
|
||||
-- TODO Consider keeping the fitness evaluations already done for pop (so we
|
||||
-- only reevaluate iChildren)
|
||||
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'
|
||||
selectBest eval pElite pop nPop = do
|
||||
let eliteSize = floor . (pElite *) . fromIntegral $ nPop
|
||||
let (elitists, rest) = bests eval eliteSize pop
|
||||
case rest of
|
||||
[] -> return elitists
|
||||
_notEmpty ->
|
||||
-- NOTE 'bests' always returns at least one individual, thus we need this
|
||||
-- slightly ugly branching
|
||||
if length elitists == length pop
|
||||
if length elitists == nPop
|
||||
then return elitists
|
||||
else
|
||||
return $ elitists <> (fst $ bests eval (length pop - length elitists) (NE.fromList rest))
|
||||
else return $ elitists <> (fst $ bests eval (nPop - 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 ::
|
||||
(Individual i, Evaluator i eval, Environment i env ) =>
|
||||
(Individual i, Evaluator i eval, Environment i env, SelectionType s) =>
|
||||
eval ->
|
||||
env ->
|
||||
-- | Mechanism for selecting parents
|
||||
Selection RVar i ->
|
||||
s ->
|
||||
-- | Number of parents @nParents@ for creating @nParents@ children
|
||||
N ->
|
||||
-- | How many crossover points (the @nX@ in @nX@-point crossover)
|
||||
N ->
|
||||
-- | Elitism ratio @pElite@
|
||||
R ->
|
||||
-- | Population size
|
||||
N ->
|
||||
Termination i ->
|
||||
Producer (Int, R) IO (Population i)
|
||||
run eval env select nParents nX pElite nPop term = do
|
||||
mwc <- lift create
|
||||
let x = \currPop generation -> do
|
||||
currPop' <- lift $ sampleFrom mwc $ currPop
|
||||
if term currPop' generation
|
||||
then return currPop'
|
||||
else do
|
||||
let nextPop = stepSteady eval env select nParents nX pElite currPop'
|
||||
let fBest = fitness eval $ NE.head $ fst $ bests eval 1 currPop'
|
||||
Pipes.yield (generation, fBest)
|
||||
x nextPop (generation + 1)
|
||||
x (population env nPop) 0
|
||||
|
||||
run eval env selectionType nParents pElite nPop term = do
|
||||
mwc <- liftIO create
|
||||
let smpl = ((sampleFrom mwc) :: RVar a -> IO a)
|
||||
firstPop <- liftIO $ smpl $ (population env nPop)
|
||||
_ <- liftIO $ putText $ pretty $ NE.head firstPop
|
||||
firstPop <- liftIO $ smpl $ (population env nPop)
|
||||
_ <- liftIO $ putText $ pretty $ NE.head firstPop
|
||||
res <- runIter eval 0 firstPop smpl
|
||||
return res
|
||||
where
|
||||
runIter eval count pop smpl =
|
||||
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
|
||||
|
||||
-- |
|
||||
-- A function generating a monadic action which selects a given number of
|
||||
-- individuals from the given population.
|
||||
type Selection m i = N -> Population i -> m (NonEmpty i)
|
||||
data Tournament = Tournament N
|
||||
|
||||
-- |
|
||||
-- Selects @n@ individuals from the population the given mechanism by repeatedly
|
||||
-- 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 []
|
||||
class SelectionType t where
|
||||
select :: (Individual i, Evaluator i e) => t -> N -> Population i -> e -> RVar (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
|
||||
-- selected multiple times, see 'chain').
|
||||
tournament :: (Individual i, Evaluator i e) => e -> N -> Selection RVar i
|
||||
tournament eval nTrnmnt = chain (tournament1 eval nTrnmnt)
|
||||
-- type Selection m i = N -> Population i -> m (NonEmpty i)
|
||||
|
||||
instance SelectionType Tournament where
|
||||
select (Tournament i) count pop eval = fmap NE.fromList (replicateM count (tournament1 eval i pop))
|
||||
|
||||
-- |
|
||||
-- Selects one individual from the population using tournament selection.
|
||||
|
|
@ -281,8 +262,8 @@ tournament1 eval nTrnmnt pop
|
|||
-- TODO Use Positive for this constraint
|
||||
| nTrnmnt <= 0 = undefined
|
||||
| otherwise = do
|
||||
paricipants <- withoutReplacement nTrnmnt pop
|
||||
return $ NE.head $ fst $ bests eval 1 paricipants
|
||||
paricipants <- withoutReplacement nTrnmnt pop
|
||||
return $ NE.head $ fst $ bests eval 1 paricipants
|
||||
|
||||
-- |
|
||||
-- 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 = fmap (NE.fromList) (shuffle (toList xs))
|
||||
|
||||
|
||||
|
||||
instance Pretty Integer where
|
||||
pretty i = "Found int: " <> show i
|
||||
|
||||
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 (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
|
||||
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
|
||||
i1' <- uniform i1 i2
|
||||
i2' <- uniform i1 i2
|
||||
return $ Just (i1',i2')
|
||||
return $ Just (i1', i2')
|
||||
|
||||
data NoData = NoData deriving (Eq)
|
||||
|
||||
instance Evaluator Integer NoData where
|
||||
|
||||
instance Evaluator Integer NoData where
|
||||
fitness _ = fromIntegral . negate
|
||||
|
||||
prop_children_asManyAsParents ::
|
||||
|
|
@ -354,12 +332,11 @@ prop_children_asManyAsParents nX is =
|
|||
again $
|
||||
monadicIO $
|
||||
do
|
||||
let e = IntTestEnviroment ((0,100000),10)
|
||||
let e = IntTestEnviroment ((0, 100000), 10, nX)
|
||||
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
|
||||
|
||||
|
||||
prop_bestsBy_isBestsBy' :: Int -> Population Integer -> Property
|
||||
prop_bestsBy_isBestsBy' k pop =
|
||||
k > 0 ==>
|
||||
|
|
@ -375,21 +352,23 @@ prop_bestsBy_lengths k pop =
|
|||
let (bests, rest) = bestsBy k (fitness NoData) pop
|
||||
assert $
|
||||
length bests == min k (length pop) && length bests + length rest == length pop
|
||||
prop_stepSteady_constantPopSize ::
|
||||
NonEmpty Integer -> Property
|
||||
prop_stepSteady_constantPopSize pop =
|
||||
forAll
|
||||
( (,)
|
||||
<$> choose (1, length pop)
|
||||
<*> choose (1, length pop)
|
||||
)
|
||||
$ \(nParents, nX) -> monadicIO $ do
|
||||
let pElite = 0.1
|
||||
let eval = NoData
|
||||
let env = IntTestEnviroment ((0,100000),10)
|
||||
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
|
||||
|
||||
-- TODO: re-add!
|
||||
-- prop_stepSteady_constantPopSize ::
|
||||
-- NonEmpty Integer -> Property
|
||||
-- prop_stepSteady_constantPopSize pop =
|
||||
-- forAll
|
||||
-- ( (,)
|
||||
-- <$> choose (1, length pop)
|
||||
-- <*> choose (1, length pop)
|
||||
-- )
|
||||
-- $ \(nParents, nX) -> monadicIO $ do
|
||||
-- let pElite = 0.1
|
||||
-- let eval = NoData
|
||||
-- let env = IntTestEnviroment ((0, 100000), 10, nX)
|
||||
-- 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 nTrnmnt n pop =
|
||||
|
|
@ -399,21 +378,27 @@ prop_tournament_selectsN nTrnmnt n pop =
|
|||
==> monadicIO
|
||||
$ do
|
||||
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
|
||||
|
||||
prop_withoutReplacement_selectsN :: Int -> NonEmpty a -> Property
|
||||
prop_withoutReplacement_selectsN n pop =
|
||||
0 < n && n <= length pop ==> monadicIO (do
|
||||
mwc <- Test.QuickCheck.Monadic.run create
|
||||
pop' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (withoutReplacement n pop)
|
||||
assert $ length pop' == n)
|
||||
0 < n && n <= length pop ==>
|
||||
monadicIO
|
||||
( do
|
||||
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 xs = monadicIO(do
|
||||
mwc <- Test.QuickCheck.Monadic.run create
|
||||
xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
|
||||
assert $ length xs' == length xs)
|
||||
prop_shuffle_length xs =
|
||||
monadicIO
|
||||
( do
|
||||
mwc <- Test.QuickCheck.Monadic.run create
|
||||
xs' <- Test.QuickCheck.Monadic.run $ sampleFrom mwc (shuffle' xs)
|
||||
assert $ length xs' == length xs
|
||||
)
|
||||
|
||||
runTests :: IO Bool
|
||||
runTests = $quickCheckAll
|
||||
|
|
|
|||
|
|
@ -5,12 +5,15 @@
|
|||
{-# LANGUAGE Trustworthy #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
||||
|
||||
module LambdaCalculus where
|
||||
|
||||
import Data.Dynamic
|
||||
import Data.List (foldr1, last, lookup, zipWith3, (!!), (\\))
|
||||
import Data.List.Extra (delete, nubOrd, nubOrdOn)
|
||||
import Data.Tuple.Extra
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import qualified Data.Map.Strict as Map
|
||||
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
|
||||
return ret
|
||||
|
||||
|
||||
instance Environment TypeRequester LambdaEnviroment where
|
||||
new env@(LambdaEnviroment _ _ target maxDepth _) = do
|
||||
tr <- genTypeRequester env maxDepth target []
|
||||
|
|
@ -255,6 +257,8 @@ instance Environment TypeRequester LambdaEnviroment where
|
|||
res <- genTypeRequester env depthAt trep bound
|
||||
return $ replaceAtR selectedTR tr res
|
||||
|
||||
nX _ = 3 --todo!
|
||||
|
||||
crossover1 env@(LambdaEnviroment _ _ _ maxDepth _) tr1 tr2 = do
|
||||
return Nothing
|
||||
|
||||
|
|
@ -278,18 +282,21 @@ instance Evaluator TypeRequester LamdaExecutionEnv where
|
|||
evalResults :: LamdaExecutionEnv -> [TypeRequester] -> Hint.InterpreterT IO [(TypeRequester, R)]
|
||||
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 ex tr = do
|
||||
Hint.loadModules (map show (imports ex))
|
||||
result <- Hint.interpret (show (toLambdaExpressionS tr)) (Hint.as ::R -> R -> R -> IrisClass)
|
||||
csv <- liftIO $ B.readFile (trainingDataset ex)
|
||||
let recs = toList $ fromRight undefined $ decode NoHeader csv
|
||||
let res = map (show (uncurry result)) recs
|
||||
let recs = (toList $ fromRight undefined $ decode NoHeader csv) :: [(R,R,R)]
|
||||
let res = map ((uncurry3 result)) recs
|
||||
csvRes <- liftIO $ B.readFile (trainingDatasetRes ex)
|
||||
let recsRes = toList $ fromRight undefined $ decode NoHeader csvRes
|
||||
let score = (foldr (\ts s -> if fst ts == snd ts then s + 1 else s - 1) 0 (zip recsRes res)) :: R
|
||||
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
|
||||
return (tr, score)
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -49,7 +49,8 @@ main =
|
|||
execParser optionsWithHelp >>= \opts -> do
|
||||
hSetBuffering stdout NoBuffering
|
||||
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' <-
|
||||
runEffect (for run' logCsv)
|
||||
let (res, _) = bests prios 5 pop'
|
||||
|
|
|
|||
|
|
@ -116,6 +116,8 @@ instance Environment Assignment AssignmentEnviroment where
|
|||
mixedAssignables <- shuffle paddedAssignables
|
||||
return $ zip paddedPersons mixedAssignables
|
||||
|
||||
nX _ = 1
|
||||
|
||||
mutate _ assignment = do
|
||||
x <- uniform 0 (length assignment - 1)
|
||||
y <- uniform 0 (length assignment - 1)
|
||||
|
|
|
|||
|
|
@ -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 @(Text))))) :: Text)
|
||||
mwc <- createSystemRandom
|
||||
r <- sampleFrom mwc $ LambdaCalculus.new LambdaCalculus.exampleLE
|
||||
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
|
||||
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
|
||||
r <- sampleFrom mwc $ LambdaCalculus.new LambdaCalculus.exampleLE
|
||||
r <- sampleFrom mwc $ GA.new LambdaCalculus.exampleLE
|
||||
_ <- putStrLn $ LambdaCalculus.toLambdaExpressionS $ r
|
||||
--_ <- putStrLn (LambdaCalculus.toLambdaExpressionShort LambdaCalculus.testIntToClassCorrect)
|
||||
--_ <- putStrLn $ ((show (LambdaCalculus.res 1)) :: Text)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user