2018-05-02 21:39:22 +00:00
{- # LANGUAGE TypeApplications # -}
2018-05-01 15:09:25 +00:00
module Main where
2018-05-02 21:39:22 +00:00
import Environment
import Text.Printf
import Control.Monad.Reader
import Numeric.LinearAlgebra
import Data.List
import System.Random
import Control.Concurrent
import qualified Debug.Trace as Debug
import System.IO
-- Example definitions
-- -------------------
-- Enzymes
pps :: Enzyme -- uses Phosphor from Substrate to produce PP
2018-05-04 22:23:40 +00:00
pps = Enzyme " PPS " [ ( Substrate Phosphor , 1 ) ] ( ( Substrate Phosphor , - 1 ) , ( Produced PP , 1 ) ) Nothing
2018-05-02 21:39:22 +00:00
fpps :: Enzyme -- PP -> FPP
fpps = makeSimpleEnzyme ( Produced PP ) ( Produced FPP )
-- Predator
greenfly :: Predator -- 20% of plants die to greenfly, but the fly is
greenfly = Predator [] 0.2 -- killed by any toxic Component
-- Environment
exampleEnvironment :: Environment
exampleEnvironment =
Environment
{ soil = [ ( Nitrate , 2 )
, ( Phosphor , 3 )
, ( Photosynthesis , 10 )
]
, predators = [ ( greenfly , 0.1 ) ]
, metabolismIteration = 100
2018-05-04 22:23:40 +00:00
, maxCompound = maxCompoundWithoutGeneric
2018-05-02 21:39:22 +00:00
, toxicCompounds = [ ( Produced FPP , 0.5 ) ] --FPP kills 100% if produced amount above 0.2 units
, possibleEnzymes = [ pps , fpps ]
}
-- Plants
examplePlants :: [ Plant ]
examplePlants = ( \ g -> Plant g defaultAbsorption ) <$> genomes
where
enzymes = [ pps , fpps ]
quantity = [ 1 , 2 ] :: [ Quantity ]
activation = [ 0.7 , 0.9 , 1 ]
genomes = do
e <- permutations enzymes
e' <- subsequences e
q <- quantity
a <- activation
return $ ( , , ) <$> e' <*> [ q ] <*> [ a ]
2018-05-04 22:23:40 +00:00
defaultAbsorption = fmap ( limit Phosphor 2
. limit Nitrate 1
. limit Sulfur 0
) <$> asks soil
2018-05-02 21:39:22 +00:00
-- custom absorbtion with helper-function:
limit :: Nutrient -> Amount -> ( Nutrient , Amount ) -> ( Nutrient , Amount )
limit n a ( n' , a' )
| n == n' = ( n , min a a' ) -- if we should limit, then we do ;)
| otherwise = ( n' , a' )
-- Running the simulation
-- ----------------------
loop :: Int -> [ Plant ] -> Environment -> IO ()
2018-05-04 22:23:40 +00:00
loop loopAmount = loop' loopAmount 0
2018-05-02 21:39:22 +00:00
where
loop' :: Int -> Int -> [ Plant ] -> Environment -> IO ()
loop' loopAmount curLoop plants e = unless ( loopAmount == curLoop ) $ do
2018-05-04 22:23:40 +00:00
putStr " \ ESC [2J \ ESC [H "
2018-05-02 21:39:22 +00:00
printEnvironment e
putStrLn " "
putStrLn $ " Generation " ++ show curLoop ++ " of " ++ show loopAmount ++ " : "
2018-05-04 22:23:40 +00:00
newPlants <- flip runReaderT e $ do
2018-05-02 21:39:22 +00:00
fs <- sequence $ fitness <$> plants
let fps = zip plants fs -- gives us plants & their fitness in a tuple
sumFitness = sum fs
2018-05-04 22:23:40 +00:00
pe <- asks possibleEnzymes
2018-05-02 21:39:22 +00:00
liftIO $ printPopulation pe fps
-- generate 100 new plants.
2018-05-04 22:23:40 +00:00
sequence . flip fmap [ 1 .. 100 ] $ \ _ -> do
2018-05-02 21:39:22 +00:00
parent' <- liftIO $ randomRIO ( 0 , sumFitness )
let
-- if we only have one parent in our list, take it.
findParent :: Double -> [ ( Plant , Double ) ] -> Plant
findParent _ [ ( last , _ ) ] = last
-- otherwise count down x to find the parent in the list
findParent x ( ( p , f ) : ps )
| x < f = p
| otherwise = findParent ( x - f ) ps
parent = findParent parent' fps
haploMate parent
hFlush stdout
threadDelay $ 100 * 1000 -- sleep 100ms
loop' loopAmount ( curLoop + 1 ) newPlants e
2018-05-01 15:09:25 +00:00
main :: IO ()
2018-05-02 21:39:22 +00:00
main = do
hSetBuffering stdin NoBuffering
hSetBuffering stdout NoBuffering
let emptyPlants = replicate 100 emptyPlant
printEnvironment exampleEnvironment
putStr " \ ESC [?1049h "
loop 100 emptyPlants exampleEnvironment
putStrLn " Simulation ended. Press key to exit. "
_ <- getChar
putStr " \ ESC [?1049l "
-- fitness <- runReaderT (sequence $ (\a -> do p <- absorbNutrients a >>= produceCompounds a; (,,) a p <$> deterPredators p) <$> emptyPlants) exampleEnvironment
-- mapM_ (printf "%15.15s, " . show . toEnum @Compound) [0..maxCompoundWithoutGeneric]
-- putStrLn "Fitness"
-- forM_ fitness $ \(p, c, f) -> do
-- mapM_ (printf "%15.2f, ") (toList c)
-- printf "%15.2f" f
-- putStr "\n"
printEnvironment :: Environment -> IO ()
printEnvironment ( Environment soil pred metaIter maxComp toxic possEnz ) =
do
putStrLn " Environment: "
putStrLn $ " Soil: " ++ show soil
putStrLn $ " Predators: " ++ show pred
putStrLn $ " PSM Iters: " ++ show metaIter
putStrLn $ " Compounds: " ++ show ( ( toEnum <$> [ 0 .. maxComp ] ) :: [ Compound ] )
putStrLn $ " Toxic: " ++ show toxic
printPopulation :: [ Enzyme ] -> [ ( Plant , Double ) ] -> IO ()
printPopulation es ps = do
let padded i str = take i $ str ++ repeat ' '
putStr $ padded 40 " Population: "
2018-05-04 22:23:40 +00:00
forM_ ps $ \ ( _ , f ) -> putStr ( printColor f '█' )
2018-05-02 21:39:22 +00:00
putStrLn colorOff
forM_ es $ \ e -> do
putStr $ padded 40 ( show ( enzymeName e ) )
2018-05-04 22:23:40 +00:00
forM_ ps $ \ ( Plant g _ , _ ) -> do
let curE = sum $ map ( \ ( _ , q , a ) -> fromIntegral q * a )
2018-05-02 21:39:22 +00:00
. filter ( \ ( e' , _ , _ ) -> e == e' )
$ g
plot x
| x > 2 = " O "
| x > 1 = " + "
| x > 0.7 = " ö "
| x > 0.5 = " o "
| x > 0 = " . "
| otherwise = " _ "
putStr ( plot curE )
putStrLn " "
printColor :: Double -> Char -> String
printColor x c
2018-05-04 22:23:40 +00:00
| 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 ] ++ " "
2018-05-02 21:39:22 +00:00
-- 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] ++ ""
where x' = x * x
colorOff :: String
colorOff = " \ ESC [0m "