diff --git a/TODO.txt b/TODO.txt index 20c5777..80c7305 100644 --- a/TODO.txt +++ b/TODO.txt @@ -1,10 +1,5 @@ ::TODO:: --switch benchmarks to relude - -do benchmarks for skellygen -add some punnet square sorta functions to genotype -DONE-do a package cleanup -DONE-switch to relude FFS --fix circleci [![CircleCI](https://circleci.com/gh/pdlla/animalclub.svg?style=svg)](https://circleci.com/gh/pdlla/animalclub) -new test cases -verify results of SkellyNode on worm test -verify reflected sides are indeed reflections of each other locally @@ -18,6 +13,11 @@ DONE-switch to relude FFS -try breeding to maximize volume and see what happens -try breeding to maximize bending joints and see what happens -consider moving parts of Builder.hs into Genetics +DONE-switch benchmarks to relude + DONE-do benchmarks for skellygen +DONE-do a package cleanup +DONE-switch to relude FFS +IGNORE-fix circleci [![CircleCI](https://circleci.com/gh/pdlla/animalclub.svg?style=svg)](https://circleci.com/gh/pdlla/animalclub) DONE-change scale to V3 instead of M33 -see comments in reduceBoneTrans in AnimalScript.hs IGNORE-switch LocalMesh to use storable vector diff --git a/benchmark/dna.hs b/benchmark/dna.hs index 9558643..ac1da03 100644 --- a/benchmark/dna.hs +++ b/benchmark/dna.hs @@ -1,25 +1,28 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} --{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -import AnimalClub.Genetics -import System.Random +import Relude -import Criterion.Main +import AnimalClub.Genetics + +import System.Random + +import Criterion.Main main :: IO () main = do - let - lns = [100, 1000, 10000] - stdg <- getStdGen - let - (g1,g2) = split stdg - dnas = map (makeRandDNA g1) lns - dnas2 = map (makeRandDNA g2) lns - defaultMain [ - bgroup "StdGen create" $ map (\l -> bench (show l) $ nf (makeRandDNA stdg) l) lns - ,bgroup "StdGen breed" $ map (\(l, dna1, dna2) -> bench (show l) $ nf (breed stdg dna1) dna2) (zip3 lns dnas dnas2) - ,bgroup "StdGen mutate 0.1" $ map (\(l, dna) -> bench (show l) $ nf (mutate 0.1 stdg) dna) (zip lns dnas) - --,bgroup "StdGen mutateOld 0.1" $ map (\(l, dna) -> bench (show l) $ nf (mutateOld 0.1 stdg) dna) (zip lns dnas) - ] + let + lns = [100, 1000, 10000] + stdg <- getStdGen + let + (g1,g2) = split stdg + dnas = map (makeRandDNA g1) lns + dnas2 = map (makeRandDNA g2) lns + defaultMain [ + bgroup "StdGen create" $ map (\l -> bench (show l) $ nf (makeRandDNA stdg) l) lns + ,bgroup "StdGen breed" $ map (\(l, dna1, dna2) -> bench (show l) $ nf (breed stdg dna1) dna2) (zip3 lns dnas dnas2) + ,bgroup "StdGen mutate 0.1" $ map (\(l, dna) -> bench (show l) $ nf (mutate 0.1 stdg) dna) (zip lns dnas) + --,bgroup "StdGen mutateOld 0.1" $ map (\(l, dna) -> bench (show l) $ nf (mutateOld 0.1 stdg) dna) (zip lns dnas) + ] diff --git a/benchmark/genotype.hs b/benchmark/genotype.hs index d1a9281..6a08e0e 100644 --- a/benchmark/genotype.hs +++ b/benchmark/genotype.hs @@ -1,19 +1,21 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} --{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} -import AnimalClub.Genetics +import Relude + +import AnimalClub.Genetics import qualified AnimalClub.Genetics.Internal.Unused.Genotype as Old -import System.Random +import System.Random -import qualified Control.Monad.Parallel as Par -import qualified Control.Monad as Seq -import Control.Monad.Writer (tell) -import Control.Monad.State (get) +import qualified Control.Monad as Seq +import qualified Control.Monad.Parallel as Par +import Control.Monad.State (get) +import Control.Monad.Writer (tell) -import Criterion.Main +import Criterion.Main -import Data.Time.Clock -import Control.DeepSeq +import Control.DeepSeq +import Data.Time.Clock splitCount :: Int splitCount = 40 @@ -22,86 +24,86 @@ splitCount = 40 gbComplicated :: Genotype StdGen [Int] Int gbComplicated = do - x <- gbSumRange (0, 99) - y <- gbTypical (0, 99) - z <- gbNormalizedSum - return $ round $ x + y + z + x <- gbSumRange (0, 99) + y <- gbTypical (0, 99) + z <- gbNormalizedSum + return $ round $ x + y + z gbComplicatedOld :: Old.Genotype StdGen [Int] Int gbComplicatedOld = do - x <- Old.gbSumRange (0, 99) - y <- Old.gbTypical (0, 99) - z <- Old.gbNormalizedSum - return $ round $ x + y + z + x <- Old.gbSumRange (0, 99) + y <- Old.gbTypical (0, 99) + z <- Old.gbNormalizedSum + return $ round $ x + y + z benchgtold :: Old.Genotype StdGen [Int] [Int] benchgtold = do - (dna,_) <- get - let - dnal = dnaLength dna - ml = dnal `quot` splitCount - Seq.forM [i*ml | i <- [0..(splitCount-1)]] $ \x -> do - Old.gbPush (Gene x ml) - r <- gbComplicatedOld - Old.gbPop - return r + (dna,_) <- get + let + dnal = dnaLength dna + ml = dnal `quot` splitCount + Seq.forM [i*ml | i <- [0..(splitCount-1)]] $ \x -> do + Old.gbPush (Gene x ml) + r <- gbComplicatedOld + Old.gbPop + return r benchgtseq :: Genotype StdGen [Int] [Int] benchgtseq = do - dnal <- gbDNALength - let - ml = dnal `quot` splitCount - Seq.forM [i*ml | i <- [0..(splitCount-1)]] (\x -> usingGene (Gene x ml) gbComplicated) + dnal <- gbDNALength + let + ml = dnal `quot` splitCount + Seq.forM [i*ml | i <- [0..(splitCount-1)]] (\x -> usingGene (Gene x ml) gbComplicated) benchgtpar :: Genotype StdGen [Int] [Int] benchgtpar = do - dnal <- gbDNALength - let - ml = dnal `quot` splitCount - Par.forM [i*ml | i <- [0..(splitCount-1)]] (\x -> usingGene (Gene x ml) gbComplicated) + dnal <- gbDNALength + let + ml = dnal `quot` splitCount + Par.forM [i*ml | i <- [0..(splitCount-1)]] (\x -> usingGene (Gene x ml) gbComplicated) markTime :: String -> UTCTime -> IO UTCTime markTime s t = do - t' <- getCurrentTime - putStrLn $ s ++ ": " ++ show (diffUTCTime t' t) - return t' + t' <- getCurrentTime + putStrLn $ s ++ ": " ++ show (diffUTCTime t' t) + return t' main :: IO () main = do - g <- getStdGen - let - dnal = 10000000 - dna = makeRandDNA g dnal - dna `deepseq` return () + g <- getStdGen + let + dnal = 10000000 + dna = makeRandDNA g dnal + dna `deepseq` return () - -- simplified benchmarks + -- simplified benchmarks - -- making correct # of sparks as expected but sparks almost all get GC or fizzled - t1 <- getCurrentTime - r1 <- return $ evalGeneBuilder (benchgtpar >>= tell) dna g - r1 `deepseq` return () - t2 <- markTime "par" t1 + -- making correct # of sparks as expected but sparks almost all get GC or fizzled + t1 <- getCurrentTime + r1 <- return $ evalGeneBuilder (benchgtpar >>= tell) dna g + r1 `deepseq` return () + t2 <- markTime "par" t1 - r2 <- return $ evalGeneBuilder (benchgtseq >>= tell) dna g - r2 `deepseq` return () - t3 <- markTime "seq" t2 + r2 <- return $ evalGeneBuilder (benchgtseq >>= tell) dna g + r2 `deepseq` return () + t3 <- markTime "seq" t2 - r3 <- return $ Old.evalGeneBuilder (benchgtold >>= tell) (dna, []) g - r3 `deepseq` return () - t4 <- markTime "old" t3 + r3 <- return $ Old.evalGeneBuilder (benchgtold >>= tell) (dna, []) g + r3 `deepseq` return () + t4 <- markTime "old" t3 - return () + return () - -- criterion benchmarks, disabled for now until I get the above to work properly - {- - defaultMain [ - bgroup "genotype" [ - bench "serial" $ nf (evalGeneBuilder (benchgtseq >>= tell) dna) g - ,bench "parallel" $ nf (evalGeneBuilder (benchgtpar >>= tell) dna) g - ,bench "old" $ nf (Old.evalGeneBuilder (benchgtold >>= tell) (dna, [])) g - ] - ]-} + -- criterion benchmarks, disabled for now until I get the above to work properly + {- + defaultMain [ + bgroup "genotype" [ + bench "serial" $ nf (evalGeneBuilder (benchgtseq >>= tell) dna) g + ,bench "parallel" $ nf (evalGeneBuilder (benchgtpar >>= tell) dna) g + ,bench "old" $ nf (Old.evalGeneBuilder (benchgtold >>= tell) (dna, [])) g + ] + ]-} diff --git a/benchmark/skellygen.hs b/benchmark/skellygen.hs new file mode 100644 index 0000000..c63fc42 --- /dev/null +++ b/benchmark/skellygen.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +--{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +import Relude + +import AnimalClub.Animals.Examples + +import AnimalClub.Animals +import AnimalClub.Genetics +import AnimalClub.Skellygen +import AnimalClub.Skellygen.Mesh + +import Control.DeepSeq +import System.Random + +import Criterion.Main + +main :: IO () +main = do + let + -- this is just to generate a dummy set of props + goatProps = generateAnimalProperties (makeBoneIdList goatAnimalNode) $ evalGenome goatGenome original where + goatDNALength = 1000 + goatGenome = makeGenomeFromPropertiesSimple goatDNALength [] goatPropertyList + original = makeRandDNA (mkStdGen 0) goatDNALength + skelly = animalNodeToSkellyNode goatAnimalNode + potatoMesh = generatePotatoMesh skelly + -- force input values before testing + goatAnimalNode `deepseq` skelly `deepseq` potatoMesh `deepseq` return () + defaultMain [ + bgroup "animalNodeToSkellyNodeWithProps" + [bench "goat" $ nf (animalNodeToSkellyNodeWithProps goatProps) goatAnimalNode] + , bgroup "animalNodeToSkellyNode" + [bench "goat" $ nf animalNodeToSkellyNode goatAnimalNode] + , bgroup "generatePotatoMesh" + [bench "goat" $ nf generatePotatoMesh skelly] + , bgroup "potatoMeshToObj" + [bench "goat" $ nf potatoMeshToObj potatoMesh] + ] diff --git a/package.yaml b/package.yaml index 077ba63..57e8942 100644 --- a/package.yaml +++ b/package.yaml @@ -168,7 +168,6 @@ benchmarks: - -with-rtsopts=-N4 - -with-rtsopts=-C0.01 - dna-benchmarks: source-dirs: benchmark main: dna.hs @@ -183,6 +182,18 @@ benchmarks: - -with-rtsopts=-N + skellygen-benchmarks: + source-dirs: benchmark + main: skellygen.hs + dependencies: + - animalclub + - criterion + - clock + - time + ghc-options: + - -rtsopts + - -threaded + - -with-rtsopts=-N tests: animalclub-tests: @@ -209,7 +220,7 @@ verbatim: | mod-def-file: AnimalClubLib.def other-modules: AnimalClub.ForeignBindings -- copy this part from library default-extensions section of hpack generated cabal file - default-extensions: InstanceSigs LambdaCase OverloadedStrings GADTs DeriveFunctor DeriveFoldable DeriveTraversable FlexibleInstances FlexibleContexts ScopedTypeVariables MultiWayIf TupleSections MultiParamTypeClasses NoImplicitPrelude + default-extensions: InstanceSigs LambdaCase OverloadedStrings GADTs DeriveFunctor DeriveFoldable DeriveTraversable DeriveGeneric FlexibleInstances FlexibleContexts ScopedTypeVariables MultiWayIf TupleSections MultiParamTypeClasses NoImplicitPrelude -- copy this part from library build-depends section of hpack generated cabal file build-depends: MonadRandom diff --git a/src/AnimalClub/Animals/Builder.hs b/src/AnimalClub/Animals/Builder.hs index 327900d..84d1053 100644 --- a/src/AnimalClub/Animals/Builder.hs +++ b/src/AnimalClub/Animals/Builder.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} {-| Module : Builder diff --git a/src/AnimalClub/Skellygen/AnimalNode.hs b/src/AnimalClub/Skellygen/AnimalNode.hs index ec4fdae..09bbbf7 100644 --- a/src/AnimalClub/Skellygen/AnimalNode.hs +++ b/src/AnimalClub/Skellygen/AnimalNode.hs @@ -11,6 +11,7 @@ Stability : experimental {-# OPTIONS_GHC -fno-warn-unused-top-binds #-} --{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE TemplateHaskell #-} -- TOOD split into files @@ -56,7 +57,7 @@ import Linear.V3 -- | indicates whether to treat the contained object as relative or absolute to its parent -data AbsOrRel a = Abs a | Rel a deriving (Functor, Show) +data AbsOrRel a = Abs a | Rel a deriving (Generic, NFData, Functor, Show) unAbsOrRel :: AbsOrRel a -> a unAbsOrRel (Abs a) = a @@ -68,12 +69,12 @@ data BoneFlag = BF_Front | BF_Back | BF_Left | BF_Right | BF_Top | BF_Bottom | BF_CustomS Text | BF_CustomI Int deriving - (Eq, Ord, Show) + (Generic, NFData, Eq, Ord, Show) -- | BoneId is an identifier for a given bone -- the name is a basic non-unique identifier -- BoneFlags help distinguish non-unique named bones -data BoneId = BoneId Text [BoneFlag] deriving (Eq, Ord, Show) +data BoneId = BoneId Text [BoneFlag] deriving (Generic, NFData, Eq, Ord, Show) -- | a function for matching BoneNames type BoneMatcher = BoneId -> Bool @@ -120,7 +121,7 @@ defTransFlag (ArbTrans _) _ = error "don't do this" -- e.g. if you have two legs, you only need to add ReflX at the hips -- BoneTrans is applied to _trs'/_pos of AnimalNode'/AnimalNode respectively -- and by extension it also affects _orientation of AnimalProperty -data BoneTrans a = Same | ReflX | ReflY | ReflZ | ArbTrans (M44 a -> M44 a) +data BoneTrans a = Same | ReflX | ReflY | ReflZ | ArbTrans (M44 a -> M44 a) deriving (Generic, NFData) instance Show (BoneTrans a) where show Same = "Same" @@ -177,7 +178,7 @@ data AnimalNode a = AnimalNode { _isPhantom :: Bool, -- ^ if this is true, this node will be invisible (won't create a mesh) _children :: [AnimalNode a] -- _nodeOrientation :: NodeOrientation -} +} deriving (Generic, NFData) makeLenses ''AnimalNode