{-# LANGUAGE DefaultSignatures     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE ScopedTypeVariables   #-}
-- | The core typeclasses and associated methods of goblins.
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


-- | The state we carry as we perform goblins actions.
data GoblinData g = GoblinData
  { -- | Remaining genes, controlling how a goblin operates.
    GoblinData g -> Genome g
_genes       :: !(Genome g)
    -- | A goblin's bag of tricks contains items of many differnt types. When
    -- tinkering, a goblin (depending on its genome) might look in its bag of
    -- tricks to see whether it has anything of the appropriate type to replace
    -- what it's currently tinkering with (or, depending on the type, do
    -- something different - for example, utilise a monoid instance to add
    -- things together).
  , GoblinData g -> TypeRepMap []
_bagOfTricks :: !(TypeRepMap [])
  }
makeLenses 'GoblinData

-- | Tinker monad.
type TinkerM g = State (GoblinData g)


-- | The interface to goblins. This class defines two actions
--   - `tinker`ing with an existing value
--   - `conjure`ing a new value
class (GeneOps g, Typeable a) => Goblin g a where
  -- | Tinker with an item of type 'a'.
  tinker :: Gen a -> TinkerM g (Gen a)

  -- | As well as tinkering, goblins can conjure fresh items into existence.
  conjure :: TinkerM g a


-- | Helper function to save a value in the bagOfTricks, and return it.
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

-- | Construct a tinker function given a set of possible things to do.
--
--   Each 'toy' is a function taking the original value and one grabbed from the
--   bag of tricks or conjured.
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

-- | Either tinker with a rummaged value, conjure a new value, or save the
-- argument in the bagOfTricks and return it.
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)

--------------------------------------------------------------------------------
-- Gene operations
--------------------------------------------------------------------------------

-- | Read (and consume) a gene from the genome.
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

-- | A typeclass for actions over genomes.
class GeneOps g where
  -- | Choose between two actions based on the value of a gene.
  onGene
    :: TinkerM g a
    -- ^ When gene is on.
    -> TinkerM g a
    -- ^ When gene is off.
    -> TinkerM g a

  -- | Transcribe sufficient genes to get an integer in the range [0..n].
  transcribeGenesAsInt
    :: Int
    -> TinkerM g Int


--------------------------------------------------------------------------------
-- Bag of tricks
--------------------------------------------------------------------------------

-- | Fetch something from the bag of tricks if there's something there.
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
    -- @mhueschen: \/ will not shrink, I believe
    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

-- | Fetch everything from the bag of tricks.
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 []
    -- @mhueschen: \/ will not shrink, I believe
    Just [a]
xs -> [a] -> TinkerM g [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [a]
xs

-- | Fetch something from the bag of tricks, or else conjure it up.
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

-- | Attempt to rummage. If a value is available, either tinker with it or
-- leave it intact. If no value is available, conjure a fresh one and add
-- shrinks to it.
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)


--------------------------------------------------------------------------------
-- AddShrinks class
--------------------------------------------------------------------------------

-- | Whereas `pure` creates a Hedgehog tree with no shrinks, `addShrinks`
--   creates a tree with shrinks.
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

-- | Use an Enum instance to create a shrink tree which shrinks towards
-- `toEnum 0`.
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


--------------------------------------------------------------------------------
-- SeedGoblin class
--------------------------------------------------------------------------------

-- | Recur down a datatype, adding the sub-datatypes to the `TinkerM` `TypeRepMap`
class SeedGoblin a where
  -- | Recur down a type, adding elements to the TypeRepMap
  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


--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------

-- | Spawn a goblin from a given genome and a bag of tricks.
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

-- | Spawn a goblin from a genome, with an empty TypeRepMap.
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

-- | Use the genome to generate an index within the bounds
-- of the provided list.
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)

-- | Convenience Hedgehog generator.
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)))