{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Goblin.Core
( module Test.Goblin.Core
, (<$$>)
, (<**>)
) where
import Control.Monad (replicateM)
import Control.Monad.Trans.State.Strict (State)
import Data.Typeable (Typeable)
import Data.TypeRepMap (TypeRepMap)
import qualified Data.TypeRepMap as TM
import Hedgehog (Gen)
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import Lens.Micro.Mtl ((%=), (.=), use)
import Lens.Micro.TH (makeLenses)
import Moo.GeneticAlgorithm.Types (Genome, Population)
import Test.Goblin.Util
data GoblinData g = GoblinData
{
GoblinData g -> Genome g
_genes :: !(Genome g)
, GoblinData g -> TypeRepMap []
_bagOfTricks :: !(TypeRepMap [])
}
makeLenses 'GoblinData
type TinkerM g = State (GoblinData g)
class (GeneOps g, Typeable a) => Goblin g a where
tinker :: Gen a -> TinkerM g (Gen a)
conjure :: TinkerM g a
saveInBagOfTricks :: forall g a. Typeable a => a -> TinkerM g a
saveInBagOfTricks :: a -> TinkerM g a
saveInBagOfTricks a
x = do
(TypeRepMap [] -> Identity (TypeRepMap []))
-> GoblinData g -> Identity (GoblinData g)
forall g. Lens' (GoblinData g) (TypeRepMap [])
bagOfTricks ((TypeRepMap [] -> Identity (TypeRepMap []))
-> GoblinData g -> Identity (GoblinData g))
-> (TypeRepMap [] -> TypeRepMap [])
-> StateT (GoblinData g) Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= TypeRepMap [] -> TypeRepMap []
consOrInsert
a -> TinkerM g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
where
consOrInsert :: TypeRepMap [] -> TypeRepMap []
consOrInsert :: TypeRepMap [] -> TypeRepMap []
consOrInsert TypeRepMap []
trm = if TypeRepMap [] -> Bool
forall k (a :: k) (f :: k -> *). Typeable a => TypeRepMap f -> Bool
TM.member @a TypeRepMap []
trm
then ([a] -> [a]) -> TypeRepMap [] -> TypeRepMap []
forall k (a :: k) (f :: k -> *).
Typeable a =>
(f a -> f a) -> TypeRepMap f -> TypeRepMap f
TM.adjust (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) TypeRepMap []
trm
else [a] -> TypeRepMap [] -> TypeRepMap []
forall k (a :: k) (f :: k -> *).
Typeable a =>
f a -> TypeRepMap f -> TypeRepMap f
TM.insert [a
x] TypeRepMap []
trm
tinkerWithToys
:: (AddShrinks a, Goblin g a)
=> [Gen a -> Gen a -> Gen a]
-> (Gen a -> TinkerM g (Gen a))
tinkerWithToys :: [Gen a -> Gen a -> Gen a] -> Gen a -> TinkerM g (Gen a)
tinkerWithToys [Gen a -> Gen a -> Gen a]
toys Gen a
a =
let
defaultToys :: [a -> a -> a]
defaultToys = [a -> a -> a
forall a b. a -> b -> a
const, (a -> a -> a) -> a -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> a -> a
forall a b. a -> b -> a
const]
allToys :: [Gen a -> Gen a -> Gen a]
allToys = [Gen a -> Gen a -> Gen a]
forall a. [a -> a -> a]
defaultToys [Gen a -> Gen a -> Gen a]
-> [Gen a -> Gen a -> Gen a] -> [Gen a -> Gen a -> Gen a]
forall a. [a] -> [a] -> [a]
++ [Gen a -> Gen a -> Gen a]
toys
in TinkerM g (Gen a) -> TinkerM g (Gen a)
forall g a.
(Goblin g a, AddShrinks a) =>
TinkerM g (Gen a) -> TinkerM g (Gen a)
tinkerRummagedOrConjureOrSave (TinkerM g (Gen a) -> TinkerM g (Gen a))
-> TinkerM g (Gen a) -> TinkerM g (Gen a)
forall a b. (a -> b) -> a -> b
$ do
Gen a -> Gen a -> Gen a
toy <- ([Gen a -> Gen a -> Gen a]
allToys [Gen a -> Gen a -> Gen a] -> Int -> Gen a -> Gen a -> Gen a
forall a. [a] -> Int -> a
!!) (Int -> Gen a -> Gen a -> Gen a)
-> StateT (GoblinData g) Identity Int
-> StateT (GoblinData g) Identity (Gen a -> Gen a -> Gen a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Gen a -> Gen a -> Gen a] -> StateT (GoblinData g) Identity Int
forall g a. GeneOps g => [a] -> TinkerM g Int
geneListIndex [Gen a -> Gen a -> Gen a]
allToys
Gen a -> Gen a -> Gen a
toy Gen a
a (Gen a -> Gen a) -> TinkerM g (Gen a) -> TinkerM g (Gen a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TinkerM g (Gen a)
forall a g. (Goblin g a, AddShrinks a) => TinkerM g (Gen a)
tinkerRummagedOrConjure
tinkerRummagedOrConjureOrSave :: (Goblin g a, AddShrinks a)
=> TinkerM g (Gen a) -> TinkerM g (Gen a)
tinkerRummagedOrConjureOrSave :: TinkerM g (Gen a) -> TinkerM g (Gen a)
tinkerRummagedOrConjureOrSave TinkerM g (Gen a)
m =
TinkerM g (Gen a) -> TinkerM g (Gen a) -> TinkerM g (Gen a)
forall g a. GeneOps g => TinkerM g a -> TinkerM g a -> TinkerM g a
onGene TinkerM g (Gen a)
forall a g. (Goblin g a, AddShrinks a) => TinkerM g (Gen a)
tinkerRummagedOrConjure (Gen a -> TinkerM g (Gen a)
forall g a. Typeable a => a -> TinkerM g a
saveInBagOfTricks (Gen a -> TinkerM g (Gen a))
-> TinkerM g (Gen a) -> TinkerM g (Gen a)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TinkerM g (Gen a)
m)
transcribeGene :: TinkerM g g
transcribeGene :: TinkerM g g
transcribeGene = do
Genome g
g <- Getting (Genome g) (GoblinData g) (Genome g)
-> StateT (GoblinData g) Identity (Genome g)
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (Genome g) (GoblinData g) (Genome g)
forall g g.
Lens (GoblinData g) (GoblinData g) (Genome g) (Genome g)
genes
case Genome g
g of
[] -> [Char] -> TinkerM g g
forall a. HasCallStack => [Char] -> a
error [Char]
"Genome has run out! Try increasing the size of the genome."
(g
x : Genome g
xs) -> do
(Genome g -> Identity (Genome g))
-> GoblinData g -> Identity (GoblinData g)
forall g g.
Lens (GoblinData g) (GoblinData g) (Genome g) (Genome g)
genes ((Genome g -> Identity (Genome g))
-> GoblinData g -> Identity (GoblinData g))
-> Genome g -> StateT (GoblinData g) Identity ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Genome g
xs
g -> TinkerM g g
forall (m :: * -> *) a. Monad m => a -> m a
return g
x
class GeneOps g where
onGene
:: TinkerM g a
-> TinkerM g a
-> TinkerM g a
transcribeGenesAsInt
:: Int
-> TinkerM g Int
rummage :: forall a g . (GeneOps g, Typeable a) => TinkerM g (Maybe a)
rummage :: TinkerM g (Maybe a)
rummage = do
TypeRepMap []
bag <- Getting (TypeRepMap []) (GoblinData g) (TypeRepMap [])
-> StateT (GoblinData g) Identity (TypeRepMap [])
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (TypeRepMap []) (GoblinData g) (TypeRepMap [])
forall g. Lens' (GoblinData g) (TypeRepMap [])
bagOfTricks
case TypeRepMap [] -> Maybe [Maybe a]
forall k (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
TM.lookup TypeRepMap []
bag of
Maybe [Maybe a]
Nothing -> Maybe a -> TinkerM g (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
Just [Maybe a]
xs ->
([Maybe a]
xs [Maybe a] -> Int -> Maybe a
forall a. [a] -> Int -> a
!!) (Int -> Maybe a)
-> StateT (GoblinData g) Identity Int -> TinkerM g (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe a] -> StateT (GoblinData g) Identity Int
forall g a. GeneOps g => [a] -> TinkerM g Int
geneListIndex [Maybe a]
xs
rummageAll :: forall a g . Typeable a => TinkerM g [a]
rummageAll :: TinkerM g [a]
rummageAll = do
TypeRepMap []
bag <- Getting (TypeRepMap []) (GoblinData g) (TypeRepMap [])
-> StateT (GoblinData g) Identity (TypeRepMap [])
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Getting (TypeRepMap []) (GoblinData g) (TypeRepMap [])
forall g. Lens' (GoblinData g) (TypeRepMap [])
bagOfTricks
case TypeRepMap [] -> Maybe [a]
forall k (a :: k) (f :: k -> *).
Typeable a =>
TypeRepMap f -> Maybe (f a)
TM.lookup TypeRepMap []
bag of
Maybe [a]
Nothing -> [a] -> TinkerM g [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
Just [a]
xs -> [a] -> TinkerM g [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs
rummageOrConjure :: forall a g . Goblin g a => TinkerM g a
rummageOrConjure :: TinkerM g a
rummageOrConjure = TinkerM g a -> (a -> TinkerM g a) -> Maybe a -> TinkerM g a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TinkerM g a
forall g a. Goblin g a => TinkerM g a
conjure a -> TinkerM g a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> TinkerM g a)
-> StateT (GoblinData g) Identity (Maybe a) -> TinkerM g a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StateT (GoblinData g) Identity (Maybe a)
forall a g. (GeneOps g, Typeable a) => TinkerM g (Maybe a)
rummage
tinkerRummagedOrConjure :: forall a g . (Goblin g a, AddShrinks a)
=> TinkerM g (Gen a)
tinkerRummagedOrConjure :: TinkerM g (Gen a)
tinkerRummagedOrConjure = do
Maybe (Gen a)
mR <- TinkerM g (Maybe (Gen a))
forall a g. (GeneOps g, Typeable a) => TinkerM g (Maybe a)
rummage
case Maybe (Gen a)
mR of
Maybe (Gen a)
Nothing -> a -> Gen a
forall a. AddShrinks a => a -> Gen a
addShrinks (a -> Gen a)
-> StateT (GoblinData g) Identity a -> TinkerM g (Gen a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (GoblinData g) Identity a
forall g a. Goblin g a => TinkerM g a
conjure
Just Gen a
v -> TinkerM g (Gen a) -> TinkerM g (Gen a) -> TinkerM g (Gen a)
forall g a. GeneOps g => TinkerM g a -> TinkerM g a -> TinkerM g a
onGene (Gen a -> TinkerM g (Gen a)
forall g a. Goblin g a => Gen a -> TinkerM g (Gen a)
tinker Gen a
v) (Gen a -> TinkerM g (Gen a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Gen a
v)
class AddShrinks a where
addShrinks :: a -> Gen a
default addShrinks
:: Enum a
=> a
-> Gen a
addShrinks = (a -> [a]) -> Gen a -> Gen a
forall (m :: * -> *) a. MonadGen m => (a -> [a]) -> m a -> m a
Gen.shrink a -> [a]
forall a. Enum a => a -> [a]
shrinkEnum (Gen a -> Gen a) -> (a -> Gen a) -> a -> Gen a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
shrinkEnum :: Enum a => a -> [a]
shrinkEnum :: a -> [a]
shrinkEnum a
x = Int -> a
forall a. Enum a => Int -> a
toEnum (Int -> a) -> [Int] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
if Int
e Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then []
else [Int] -> [Int]
forall a. [a] -> [a]
tail (Int -> Int -> Int -> [Int]
forall a. Enum a => a -> a -> a -> [a]
enumFromThenTo Int
e Int
e1 Int
0)
where
absDecr :: a -> a
absDecr a
v = a -> a
forall a. Num a => a -> a
signum a
v a -> a -> a
forall a. Num a => a -> a -> a
* (a -> a
forall a. Num a => a -> a
abs a
v a -> a -> a
forall a. Num a => a -> a -> a
- a
1)
e :: Int
e = a -> Int
forall a. Enum a => a -> Int
fromEnum a
x
e1 :: Int
e1 = Int -> Int
forall a. Num a => a -> a
absDecr Int
e
class SeedGoblin a where
seeder :: a -> TinkerM g ()
default seeder
:: Typeable a
=> a
-> TinkerM g ()
seeder a
x = () () -> StateT (GoblinData g) Identity a -> TinkerM g ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ a -> StateT (GoblinData g) Identity a
forall g a. Typeable a => a -> TinkerM g a
saveInBagOfTricks a
x
mkGoblin :: Genome g -> TypeRepMap [] -> GoblinData g
mkGoblin :: Genome g -> TypeRepMap [] -> GoblinData g
mkGoblin = Genome g -> TypeRepMap [] -> GoblinData g
forall g. Genome g -> TypeRepMap [] -> GoblinData g
GoblinData
mkEmptyGoblin :: Genome g -> GoblinData g
mkEmptyGoblin :: Genome g -> GoblinData g
mkEmptyGoblin Genome g
genome = Genome g -> TypeRepMap [] -> GoblinData g
forall g. Genome g -> TypeRepMap [] -> GoblinData g
GoblinData Genome g
genome TypeRepMap []
forall k (f :: k -> *). TypeRepMap f
TM.empty
geneListIndex :: GeneOps g => [a] -> TinkerM g Int
geneListIndex :: [a] -> TinkerM g Int
geneListIndex [a]
xs = Int -> TinkerM g Int
forall g. GeneOps g => Int -> TinkerM g Int
transcribeGenesAsInt ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
genPopulation :: Gen (Population Bool)
genPopulation :: Gen (Population Bool)
genPopulation = do
Int
genomeSize <- Range Int -> GenT Identity Int
forall (m :: * -> *). MonadGen m => Range Int -> m Int
Gen.int (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
1000)
Range Int
-> GenT Identity ([Bool], Double) -> Gen (Population Bool)
forall (m :: * -> *) a. MonadGen m => Range Int -> m a -> m [a]
Gen.list (Int -> Int -> Range Int
forall a. Integral a => a -> a -> Range a
Range.linear Int
0 Int
300) (GenT Identity ([Bool], Double) -> Gen (Population Bool))
-> GenT Identity ([Bool], Double) -> Gen (Population Bool)
forall a b. (a -> b) -> a -> b
$ do
[Bool]
genome <- Int -> GenT Identity Bool -> GenT Identity [Bool]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
genomeSize GenT Identity Bool
forall (m :: * -> *). MonadGen m => m Bool
Gen.bool
(,) ([Bool] -> Double -> ([Bool], Double))
-> GenT Identity [Bool]
-> GenT Identity (Double -> ([Bool], Double))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Bool] -> GenT Identity [Bool]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Bool]
genome GenT Identity (Double -> ([Bool], Double))
-> GenT Identity Double -> GenT Identity ([Bool], Double)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Range Double -> GenT Identity Double
forall (m :: * -> *). MonadGen m => Range Double -> m Double
Gen.double (Double -> Double -> Range Double
forall a. a -> a -> Range a
Range.constant Double
0 (Double
10.0Double -> Int -> Double
forall a b. (Fractional a, Integral b) => a -> b -> a
^^(Int
3::Int)))