Add basis for tests to GA module
This commit is contained in:
parent
db55ec0716
commit
84c876f1b5
26
src/GA.hs
26
src/GA.hs
|
@ -4,6 +4,7 @@
|
||||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
|
||||||
module GA where
|
module GA where
|
||||||
|
@ -20,19 +21,7 @@ import Pretty
|
||||||
import Protolude
|
import Protolude
|
||||||
import Test.QuickCheck hiding (sample, shuffle)
|
import Test.QuickCheck hiding (sample, shuffle)
|
||||||
import Test.QuickCheck.Instances
|
import Test.QuickCheck.Instances
|
||||||
|
import Test.QuickCheck.Monadic
|
||||||
-- TODO using sample here was a quick hack
|
|
||||||
{-|
|
|
||||||
Shuffles a non-empty list.
|
|
||||||
-}
|
|
||||||
shuffle' :: (MonadRandom m) => NonEmpty a -> m (NonEmpty a)
|
|
||||||
shuffle' xs = do
|
|
||||||
i <- sample . uniform 0 $ NE.length xs - 1
|
|
||||||
let x = xs NE.!! i
|
|
||||||
xs' <- sample . shuffle $ deleteI i xs
|
|
||||||
return $ x :| xs'
|
|
||||||
where
|
|
||||||
deleteI i xs = fst (NE.splitAt (i - 1) xs) ++ snd (NE.splitAt i xs)
|
|
||||||
|
|
||||||
-- TODO enforce this being > 0
|
-- TODO enforce this being > 0
|
||||||
type N = Int
|
type N = Int
|
||||||
|
@ -98,6 +87,12 @@ newtype Population a = Pop {unPop :: NonEmpty a}
|
||||||
instance (Arbitrary i) => Arbitrary (Population i) where
|
instance (Arbitrary i) => Arbitrary (Population i) where
|
||||||
arbitrary = Pop <$> arbitrary
|
arbitrary = Pop <$> arbitrary
|
||||||
|
|
||||||
|
{-|
|
||||||
|
The population's size (the length of the internally used non-empty list).
|
||||||
|
-}
|
||||||
|
size :: Population a -> N
|
||||||
|
size = NE.length . unPop
|
||||||
|
|
||||||
{-|
|
{-|
|
||||||
Selects one individual from the population using proportionate selection.
|
Selects one individual from the population using proportionate selection.
|
||||||
-}
|
-}
|
||||||
|
@ -140,6 +135,7 @@ children2 nX i1 i2 = do
|
||||||
The @k@ best individuals in the population when comparing using the supplied
|
The @k@ best individuals in the population when comparing using the supplied
|
||||||
function.
|
function.
|
||||||
-}
|
-}
|
||||||
|
-- TODO do this without a complete sort
|
||||||
bestsBy :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
|
bestsBy :: (Individual i, Monad m) => N -> (i -> m R) -> Population i -> m [i]
|
||||||
bestsBy k f =
|
bestsBy k f =
|
||||||
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
|
fmap (NE.take k . fmap fst . NE.sortBy (comparing (Down . snd)))
|
||||||
|
@ -218,3 +214,7 @@ Termination after a number of steps.
|
||||||
-}
|
-}
|
||||||
steps :: N -> Termination i
|
steps :: N -> Termination i
|
||||||
steps tEnd _ t = t >= tEnd
|
steps tEnd _ t = t >= tEnd
|
||||||
|
|
||||||
|
return []
|
||||||
|
|
||||||
|
runTests = $quickCheckAll
|
||||||
|
|
|
@ -4,8 +4,10 @@ module Main where
|
||||||
|
|
||||||
import Protolude
|
import Protolude
|
||||||
import qualified Seminar
|
import qualified Seminar
|
||||||
|
import qualified GA
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main = do
|
||||||
_ <- Seminar.runTests
|
_ <- Seminar.runTests
|
||||||
|
_ <- GA.runTests
|
||||||
return ()
|
return ()
|
||||||
|
|
Loading…
Reference in New Issue
Block a user