added EnzymeTree-Generator via QuickCheck
This commit is contained in:
parent
85ce37b106
commit
723df072c1
32
app/Main.hs
32
app/Main.hs
@ -19,7 +19,7 @@ import System.IO
|
||||
-- Enzymes
|
||||
|
||||
pps :: Enzyme -- uses Phosphor from Substrate to produce PP
|
||||
pps = Enzyme "PPS" [(Substrate Phosphor,1)] ((Substrate Phosphor,(-1)),(Produced PP,1)) Nothing
|
||||
pps = Enzyme "PPS" [(Substrate Phosphor,1)] ((Substrate Phosphor,-1),(Produced PP,1)) Nothing
|
||||
|
||||
fpps :: Enzyme -- PP -> FPP
|
||||
fpps = makeSimpleEnzyme (Produced PP) (Produced FPP)
|
||||
@ -40,7 +40,7 @@ exampleEnvironment =
|
||||
]
|
||||
, predators = [ (greenfly, 0.1) ]
|
||||
, metabolismIteration = 100
|
||||
, maxCompound = maxCompoundWithoutGeneric + 100
|
||||
, maxCompound = maxCompoundWithoutGeneric
|
||||
, toxicCompounds = [(Produced FPP,0.5)] --FPP kills 100% if produced amount above 0.2 units
|
||||
, possibleEnzymes = [pps,fpps]
|
||||
}
|
||||
@ -61,10 +61,10 @@ examplePlants = (\g -> Plant g defaultAbsorption) <$> genomes
|
||||
a <- activation
|
||||
return $ (,,) <$> e' <*> [q] <*> [a]
|
||||
|
||||
defaultAbsorption = soil <$> ask >>= return . fmap ( limit Phosphor 2
|
||||
. limit Nitrate 1
|
||||
. limit Sulfur 0
|
||||
)
|
||||
defaultAbsorption = fmap ( limit Phosphor 2
|
||||
. limit Nitrate 1
|
||||
. limit Sulfur 0
|
||||
) <$> asks soil
|
||||
-- custom absorbtion with helper-function:
|
||||
limit :: Nutrient -> Amount -> (Nutrient, Amount) -> (Nutrient, Amount)
|
||||
limit n a (n', a')
|
||||
@ -75,23 +75,23 @@ examplePlants = (\g -> Plant g defaultAbsorption) <$> genomes
|
||||
-- ----------------------
|
||||
|
||||
loop :: Int -> [Plant] -> Environment -> IO ()
|
||||
loop loopAmount plants e = loop' loopAmount 0 plants e
|
||||
loop loopAmount = loop' loopAmount 0
|
||||
|
||||
where
|
||||
loop' :: Int -> Int -> [Plant] -> Environment -> IO ()
|
||||
loop' loopAmount curLoop plants e = unless (loopAmount == curLoop) $ do
|
||||
putStr $ "\ESC[2J\ESC[H"
|
||||
putStr "\ESC[2J\ESC[H"
|
||||
printEnvironment e
|
||||
putStrLn ""
|
||||
putStrLn $ "Generation " ++ show curLoop ++ " of " ++ show loopAmount ++ ":"
|
||||
newPlants <- (flip runReaderT) e $ do
|
||||
newPlants <- flip runReaderT e $ do
|
||||
fs <- sequence $ fitness <$> plants
|
||||
let fps = zip plants fs -- gives us plants & their fitness in a tuple
|
||||
sumFitness = sum fs
|
||||
pe <- possibleEnzymes <$> ask
|
||||
pe <- asks possibleEnzymes
|
||||
liftIO $ printPopulation pe fps
|
||||
-- generate 100 new plants.
|
||||
sequence . (flip fmap) [1..100] $ \_ -> do
|
||||
sequence . flip fmap [1..100] $ \_ -> do
|
||||
parent' <- liftIO $ randomRIO (0,sumFitness)
|
||||
let
|
||||
-- if we only have one parent in our list, take it.
|
||||
@ -141,12 +141,12 @@ printPopulation :: [Enzyme] -> [(Plant,Double)] -> IO ()
|
||||
printPopulation es ps = do
|
||||
let padded i str = take i $ str ++ repeat ' '
|
||||
putStr $ padded 40 "Population:"
|
||||
forM_ ps $ \((_,f)) -> putStr (printColor f '█')
|
||||
forM_ ps $ \(_,f) -> putStr (printColor f '█')
|
||||
putStrLn colorOff
|
||||
forM_ es $ \e -> do
|
||||
putStr $ padded 40 (show (enzymeName e))
|
||||
forM_ ps $ \((Plant g _,_)) -> do
|
||||
let curE = sum $ map (\(_,q,a) -> (fromIntegral q)*a)
|
||||
forM_ ps $ \(Plant g _,_) -> do
|
||||
let curE = sum $ map (\(_,q,a) -> fromIntegral q*a)
|
||||
. filter (\(e',_,_) -> e == e')
|
||||
$ g
|
||||
plot x
|
||||
@ -161,8 +161,8 @@ printPopulation es ps = do
|
||||
|
||||
printColor :: Double -> Char -> String
|
||||
printColor x c
|
||||
| x*x < 0.5 = "\ESC[38;5;" ++ (show $ 16 + 36*5 + 6*(floor $ 5*2*x') + 0) ++ "m" ++ [c] ++ ""
|
||||
| otherwise = "\ESC[38;5;" ++ (show $ 16 + 36*(floor $ 5*2*(1-x')) + 6*5 + 0) ++ "m" ++ [c] ++ ""
|
||||
| x*x < 0.5 = "\ESC[38;5;" ++ show (16 + 36*5 + 6*floor (5*2*x') + 0) ++ "m" ++ [c] ++ ""
|
||||
| otherwise = "\ESC[38;5;" ++ show (16 + 36*floor (5*2*(1-x')) + 6*5 + 0) ++ "m" ++ [c] ++ ""
|
||||
-- 32 bit
|
||||
-- | x*x < 0.5 = "\ESC[38;2;255;" ++ (show . floor $ 255*2*x') ++ ";0m" ++ [c] ++ ""
|
||||
-- | otherwise = "\ESC[38;2;" ++ (show . floor $ 255*2*(1-x')) ++ ";255;0m" ++ [c] ++ ""
|
||||
|
||||
@ -24,6 +24,8 @@ dependencies:
|
||||
- hmatrix
|
||||
- mtl
|
||||
- random
|
||||
- QuickCheck
|
||||
- pretty-simple
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
@ -154,9 +154,10 @@ plant.
|
||||
> | Photosynthesis
|
||||
> deriving (Show, Enum, Bounded, Eq)
|
||||
>
|
||||
> data Component = PP
|
||||
> data Component = GenericComponent Int
|
||||
> | PP
|
||||
> | FPP
|
||||
> deriving (Show, Enum, Bounded, Eq)
|
||||
> deriving (Show, Eq)
|
||||
|
||||
Compounds are either direct nutrients or already processed components
|
||||
|
||||
@ -173,15 +174,14 @@ Enzymes
|
||||
|
||||
Enzymes are the main reaction-driver behind synthesis of intricate compounds.
|
||||
|
||||
> data Synthesis = Synthesis [(Compound, Amount)] (Compound,Amount)
|
||||
> data Enzyme = Enzyme
|
||||
> { enzymeName :: String
|
||||
> -- ^ Name of the Enzyme. Enzymes with the same name are supposed
|
||||
> -- to be identical.
|
||||
> , substrateRequirements :: [(Nutrient,Amount)]
|
||||
> -- ^ needed for reaction to take place
|
||||
> , substrateIntolerance :: [(Nutrient,Amount)]
|
||||
> -- ^ inhibits reaction if given nutrients are above the given concentration
|
||||
> , synthesis :: [(Compound,Amount)] -> [(Compound,Amount)]
|
||||
> , synthesis :: [Synthesis]
|
||||
> -- ^ given x in amount a, this will produce y in amount b
|
||||
> , dominance :: Maybe Amount
|
||||
> -- ^ in case of competition for nutrients this denotes the priority
|
||||
@ -199,18 +199,14 @@ Enzymes are the main reaction-driver behind synthesis of intricate compounds.
|
||||
Example "enzymes" could be:
|
||||
|
||||
> pps :: Enzyme -- uses Phosphor from Substrate to produce PP
|
||||
> pps = Enzyme "PPS" [(Phosphor,1)] [] syn Nothing
|
||||
> pps = Enzyme "PPS" [(Phosphor,1)] syn Nothing
|
||||
> where
|
||||
> syn compAvailable = [(Substrate Phosphor,i*(-1)),(Produced PP,i)]
|
||||
> where
|
||||
> i = getAmountOf (Substrate Phosphor) compAvailable
|
||||
> syn = [Synthesis [(Substrate Phosphor, 1)] (PP, 1)]
|
||||
>
|
||||
> fpps :: Enzyme -- PP -> FPP
|
||||
> fpps = Enzyme "FPPS" [] [] syn Nothing
|
||||
> fpps :: Enzyme
|
||||
> fpps = Enzyme "FPPS" [] syn Nothing
|
||||
> where
|
||||
> syn compAvailable = [(Produced PP,i*(-1)),(Produced FPP,i*0.5)]
|
||||
> where
|
||||
> i = getAmountOf (Produced PP) compAvailable
|
||||
> syn = [Synthesis [(PP, 1)] (FPP, 1)]
|
||||
|
||||
|
||||
---
|
||||
@ -272,7 +268,7 @@ internal state how many nutrients and compounds are currently inside the plant.
|
||||
> data Plant = Plant
|
||||
> { genome :: Genome
|
||||
> -- ^ the genetic characteristic of the plant
|
||||
> , absorbNutrients :: Environment -> [(Nutrient,Amount)]
|
||||
> , absorbNutrients :: Environment -> [(Component,Amount)]
|
||||
> -- ^ the capability to absorb nutrients given an environment
|
||||
> }
|
||||
> instance Show Plant where
|
||||
@ -303,7 +299,8 @@ The following example yields in the example-environment this population:
|
||||
> a <- activation
|
||||
> return $ (,,) <$> e' <*> [q] <*> [a]
|
||||
>
|
||||
> defaultAbsorption (Environment s _) = limit Phosphor 2
|
||||
> defaultAbsorption (Environment s _) = (\(a,b) -> (Substrate a,b))
|
||||
> . limit Phosphor 2
|
||||
> . limit Nitrate 1
|
||||
> . limit Sulfur 0
|
||||
> <$> s
|
||||
@ -334,10 +331,10 @@ an environment.
|
||||
|
||||
---
|
||||
|
||||
> produceCompounds :: Plant -> [(Nutrient, Amount)] -> [Compound]
|
||||
> produceCompounds :: Plant -> [(Compound, Amount)] -> [Compound]
|
||||
> produceCompounds (Plant genes _) = undefined
|
||||
> -- this will take some constrained linear algebra-solving
|
||||
|
||||
>
|
||||
> deterPredators :: [(Predator, Probability)] -> [Compound] -> Probability
|
||||
> deterPredators ps cs = sum $ do
|
||||
> c <- cs -- for every compound
|
||||
|
||||
54
src/Arbitrary.hs
Normal file
54
src/Arbitrary.hs
Normal file
@ -0,0 +1,54 @@
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Arbitrary where
|
||||
|
||||
import Test.QuickCheck
|
||||
import GHC.Generics (Generic(..))
|
||||
import Text.Pretty.Simple
|
||||
import Data.List
|
||||
|
||||
data TreeShape = Root
|
||||
{ treeSize :: Int
|
||||
, treeSubSizes :: [TreeShape]
|
||||
} deriving (Show, Eq)
|
||||
|
||||
data EnzymeTree s a = EnzymeTree TreeShape a [EnzymeTree TreeShape a] deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
|
||||
|
||||
instance Applicative (EnzymeTree s) where
|
||||
pure a = EnzymeTree (Root 1 []) a []
|
||||
EnzymeTree s f fs <*> EnzymeTree _ a as = EnzymeTree s (f a) (zipWith (<*>) fs as)
|
||||
|
||||
instance Arbitrary a => Arbitrary (EnzymeTree s a) where
|
||||
arbitrary = sized arbitrarySizedEnzymeTree
|
||||
|
||||
arbitrarySizedEnzymeTree :: Arbitrary a => Int -> Gen (EnzymeTree s a)
|
||||
arbitrarySizedEnzymeTree m = do
|
||||
t <- arbitrary
|
||||
n <- choose (m `div` 4, m)
|
||||
ts <- if n == 0 then return []
|
||||
else sequenceA $ replicate (2*n) (arbitrarySizedEnzymeTree (n `div` 2))
|
||||
let (_,ts') = foldr (go m) (0,[]) ts
|
||||
go :: Int -> EnzymeTree s a -> (Int, [EnzymeTree s a]) -> (Int, [EnzymeTree s a])
|
||||
go m x (s,ts)
|
||||
| m == 0 = (s,ts)
|
||||
| s + getTreeSize x > m = (s,ts)
|
||||
| otherwise = (s + getTreeSize x, x:ts)
|
||||
|
||||
sz = sum $ getTreeSize <$> ts'
|
||||
ss = (\(EnzymeTree a _ _) -> a) <$> ts'
|
||||
return (EnzymeTree (Root (sz+1) ss) t ts')
|
||||
|
||||
getTreeSize :: EnzymeTree s a -> Int
|
||||
getTreeSize (EnzymeTree (Root a _) _ _) = a
|
||||
|
||||
getShape :: EnzymeTree s a -> TreeShape
|
||||
getShape (EnzymeTree s _ _) = s
|
||||
|
||||
treeFromList :: TreeShape -> [a] -> EnzymeTree s a
|
||||
treeFromList (Root n ns) (a:as) = EnzymeTree (Root n ns) a (unfoldr go (ns,as))
|
||||
where
|
||||
go :: ([TreeShape],[a]) -> Maybe (EnzymeTree s a,([TreeShape],[a]))
|
||||
go (n:ns,as) = Just (treeFromList n (take (treeSize n) as), (ns, drop (treeSize n) as))
|
||||
go ([],_) = Nothing
|
||||
Loading…
Reference in New Issue
Block a user