added benchmarks

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

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)
+    ]

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
+          ]
+      ]-}

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]
+    ]

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

src/AnimalClub/Animals/Builder.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric  #-}
 
 {-|
 Module      : Builder

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