added more tests for skellygen

package.yaml

@@ -88,6 +88,7 @@ dependencies:
 - convertible
 - storable-record
 - relude
+- monad-extras
 
 library:
   source-dirs: src
@@ -245,6 +246,7 @@ verbatim: |
       , convertible
       , storable-record
       , relude
+      , monad-extras
     hs-source-dirs:      src
     c-sources:
       csrc/animalclub.cpp

src/AnimalClub/Animals/Animal.hs

@@ -9,6 +9,7 @@ Stability   : experimental
 
 
 module AnimalClub.Animals.Animal (
+  relV3,
   asPhantom,
   mans, manf, manbt,
   AnimalExp(..),
@@ -35,6 +36,10 @@ import           Control.Monad.Writer        (tell)
 --import Control.Exception (assert)
 --import Debug.Trace (trace)
 
+
+relV3 :: (AnimalFloat a) => a -> a -> a -> AbsOrRel (V3 a)
+relV3 x y z = Rel $ V3 x y z
+
 -- | set the AnimalNode as the root node
 asPhantom :: AnimalNode a -> AnimalNode a
 asPhantom an = an { _isPhantom = True }

src/AnimalClub/Animals/Examples/Goat.hs

@@ -17,11 +17,6 @@ import           AnimalClub.Skellygen.Linear
 import           AnimalClub.Skellygen.TRS
 
 
--- | whatever helper
-
-relV3 :: (AnimalFloat a) => a -> a -> a -> AbsOrRel (V3 a)
-relV3 x y z = Rel $ V3 x y z
-
 {- goat
         ↑
         Y
@@ -130,6 +125,6 @@ octopusWorm = asPhantom $ mans "root" (relV3 0 0 0) (Abs 0.2) $
   map (\r -> flipAnimalNode (rotateArbTrans (r*2*pi/8)) (defTransFlag Same) flipWorm) [0..7]
 
 
--- | Animalnode representation of canonical cube
+-- | AnimalNode representation of canonical cube, sorta
 cube :: AnimalNode Float
 cube = asPhantom $ mans "root" (relV3 0 0 0) (Abs 1.0) [mans "end" (relV3 1 0 0) (Rel 1.0) []]

src/AnimalClub/Skellygen/AnimalNode.hs

@@ -162,6 +162,7 @@ applyBoneTrans (ArbTrans f) = f
 -- each Node is a "limb" between the node's position and its parent
 -- if it is the top level node, it's parent assumes origin position
 -- if it is a phantom node, it won't have an associated mesh but otherwise is the same
+-- note that any top level node is effectively a phantom node
 --
 -- orientations are automatically determined based on parent position (see comments in AnimalScript)
 -- positions and thickness can be specified as absolute or relative for convenience I guess
@@ -178,7 +179,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)
+} deriving (Generic, NFData, Show)
 
 makeLenses ''AnimalNode
 

src/AnimalClub/Skellygen/AnimalScript.hs

@@ -19,6 +19,7 @@ import           Lens.Micro.Platform                 (makeLenses, set)
 import           AnimalClub.Skellygen.AnimalNode
 import           AnimalClub.Skellygen.AnimalProperty
 import           AnimalClub.Skellygen.Linear
+import           AnimalClub.Skellygen.Mesh
 import qualified AnimalClub.Skellygen.Skellygen      as SN
 import           AnimalClub.Skellygen.TRS
 
@@ -215,11 +216,12 @@ toSkellyNode props cn =  outsn where
   prop = getAnimalProperty (_name' cn) props
   skellyChildren = map (toSkellyNode props) (_children' cn)
   outsn = SN.SkellyNode {
-    SN._snDebugName = show (_name' cn),
-    SN._snIsPhantom = _isPhantom' cn,
-    SN._snChildren = skellyChildren,
-    SN._snM44Rel = _m44RelFinal' cn,
-    SN._snThickness = _skinParams prop * _thickness' cn -- combine with base thickness multiplicatively
+    SN._snDebugName = show (_name' cn)
+    , SN._snIsPhantom = _isPhantom' cn
+    , SN._snChildren = skellyChildren
+    , SN._snM44Rel = _m44RelFinal' cn
+    , SN._snThickness = _skinParams prop * _thickness' cn -- combine with base thickness multiplicatively
+    , SN._snDebugMesh = emptyPotatoMesh
   }
 
 -- | convert Animal Node to Skellygen

src/AnimalClub/Skellygen/Mesh.hs

@@ -49,12 +49,11 @@ data PotatoMesh a = PotatoMesh {
   , normals   :: V.Vector (V3 a)
   , texCoords :: V.Vector (V2 a)
   , indices   :: V.Vector Face
-} deriving (Generic, NFData)
+} deriving (Generic, NFData, Show)
 
 emptyPotatoMesh :: (AnimalFloat a) => PotatoMesh a
 emptyPotatoMesh = PotatoMesh V.empty V.empty V.empty V.empty
 
-
 -- this can probably be improved even more to take advantage of stream fusion
 concatPotatoMesh :: (AnimalFloat a) => [PotatoMesh a] -> PotatoMesh a
 concatPotatoMesh pms = r where

src/AnimalClub/Skellygen/Skellygen.hs

@@ -5,11 +5,13 @@
 {-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module AnimalClub.Skellygen.Skellygen
-  ( SkellyNode(..)
-  , generateLocalMesh
+module AnimalClub.Skellygen.Skellygen(
+  SkellyNode(..)
   , generatePotatoMesh
-  ) where
+  , generatePotatoMeshWithDebugging
+
+  , generateLocalMesh
+) where
 
 import           Relude                       hiding (identity)
 import           Relude.Unsafe                ((!!))
@@ -71,6 +73,7 @@ data SkellyNode a = SkellyNode
   , _snChildren  :: [SkellyNode a]
   , _snM44Rel    :: M44 a -- ^ relative to parent
   , _snThickness :: a -- ^ base physical size of joint.
+  , _snDebugMesh :: PotatoMesh a -- ^ for debugging and testing purposes only
   } deriving (Show, Generic, NFData)
 
 --dummyParent :: SkellyNode
@@ -151,8 +154,6 @@ generateSinglePotatoMesh pos ct pt =
       , indices = G.fromList $ i
     }
 
--- TODO parallelize
--- go through all children and accumulate [PotatoMesh a] then use G.concat
 _generatePotatoMesh ::
   (AnimalFloat a)
   => M44 a -- ^ parent ABS transform
@@ -168,17 +169,44 @@ _generatePotatoMesh p_snM44 p_thick skn = selfLocalMesh :| (mconcat cmeshes) whe
   absM44 = p_snM44 !*! relm44
   cmeshes = parMap rdeepseq (toList . _generatePotatoMesh absM44 thick) (_snChildren skn)
 
--- TODO switch to G.concat
+-- | same as _generatePotatoMesh except populates snDebugMesh
+_generatePotatoMeshWithDebugging ::
+  (AnimalFloat a)
+  => M44 a -- ^ parent ABS transform
+  -> a -- ^ parent thickness
+  -> SkellyNode a -- ^ node to generate
+  -> (SkellyNode a, NonEmpty (PotatoMesh a)) -- ^ output mesh and SkellyNode with debug mesh populated
+_generatePotatoMeshWithDebugging p_snM44 p_thick skn = (rSN, rMesh) where
+  thick = _snThickness skn
+  relm44 = _snM44Rel skn
+  selfLocalMesh = if _snIsPhantom skn
+    then emptyPotatoMesh
+    else transformPotatoMeshM44 p_snM44 $ generateSinglePotatoMesh relm44 thick p_thick
+  absM44 = p_snM44 !*! relm44
+  (children, cmeshes) = unzip $ parMap rdeepseq (over _2 toList . _generatePotatoMeshWithDebugging absM44 thick) (_snChildren skn)
+  rMesh = selfLocalMesh :| (mconcat cmeshes)
+  rSN = skn { _snChildren = children, _snDebugMesh = selfLocalMesh }
+
 generatePotatoMesh ::
   (AnimalFloat a)
   => SkellyNode a -- ^ input top level parent node
   -> PotatoMesh a -- ^ output mesh
 generatePotatoMesh skn = concatPotatoMesh . toList $ _generatePotatoMesh identity 1.0 skn
 
+-- | same as generatePotatoMesh except returns SkellyNode with populated _snDebugMesh
+generatePotatoMeshWithDebugging ::
+  (AnimalFloat a)
+  => SkellyNode a -- ^ input top level parent node
+  -> (SkellyNode a, PotatoMesh a) -- ^ output top level parent and mesh
+generatePotatoMeshWithDebugging skn = (sn, concatPotatoMesh . toList $ pm)  where
+  (sn, pm) = _generatePotatoMeshWithDebugging identity 1.0 skn
+
+
+
 
 
 
--- old local mesh stuff
+-- old local mesh stuff CAN DELETE
 generateSingleLocalMesh ::
   (AnimalFloat a)
   => M44 a -- ^ input node transform

test/AnimalClub/SkellygenSpec.hs

@@ -9,45 +9,96 @@ import           Relude
 import           Test.Hspec
 import           Test.HUnit
 import           Test.QuickCheck
+import           Linear.Arbitrary
 
+import           Control.Monad.Extra
+import qualified Data.Vector.Generic         as V
 import qualified Text.Show
+import System.Random
+import Lens.Micro.Platform
 
+import           AnimalClub.Animals
 import           AnimalClub.Skellygen
 import           AnimalClub.Skellygen.Linear hiding (trace)
+import           AnimalClub.Skellygen.Mesh
 import           AnimalClub.Skellygen.TRS
 
-import           Linear.Arbitrary
-
 --import           Debug.Trace
 
--- TODO finish
-{-
-instance (Arbitrary a) => Arbitrary (AnimalNode a) where
+splitSize :: Int -> Gen [Int]
+splitSize = unfoldM f where
+  f s = do
+    if s == 0
+      then return Nothing
+      else do
+        x <- choose (1,s)
+        return $ Just (x, s-x)
+
+instance (Arbitrary a, Random a, AnimalFloat a) => Arbitrary (AnimalNode a) where
   arbitrary = sized arb where
-    arb 0 = do
+    arb n = do
       pos <- arbitrary
+      csize <- if n <= 1
+        then return []
+        else splitSize n
+      children <- mapM (\s -> resize s arbitrary) csize
+      th <- choose (0.1,10)
       return AnimalNode {
-          _name = undefined
-          , _pos = Abs pos
-          , _thickness = undefined
-          , _isPhantom = True
-          , _children = []
+          _name = BoneId "blank" []
+          , _boneTrans = Same
+          , _pos = Rel pos
+          , _thickness = Abs th
+          , _isPhantom = False
+          , _children = children
         }
--}
 
--- TODO flips an animal node using ReflX
--- and checks that all X coordinates cancel out
---prop_flipAnimalNode_ReflX :: Bool
+-- notably, default instance does not cover ArbTrans case
+instance (Arbitrary a) => Arbitrary (BoneTrans a) where
+  arbitrary = elements [ReflX, ReflY, ReflZ]
+
+-- | adds up all coordinates in PotatoMesh
+-- only for testing
+sumPositionsAndNormalsForTesting :: (AnimalFloat a) => PotatoMesh a -> (V3 a, V3 a)
+sumPositionsAndNormalsForTesting (PotatoMesh p n _ _) = (V.sum p, V.sum n)
+
+
+-- | tests the property that coordinates of any mesh generated by flipping an animal node add up to 0
+-- N.B. this test does not work for Float as machine roundoff starts compounding and growing ¯\_(ツ)_/¯
+prop_flipAnimalNode_Refl :: (AnimalFloat a) => BoneTrans a -> AnimalNode a -> Bool
+prop_flipAnimalNode_Refl bt an = r where
+  withFlip = asPhantom $ mans "test_root" (relV3 0 0 0) (Abs 1.0)
+    [an, flipAnimalNode bt (defTransFlag bt) an]
+  pm = generatePotatoMesh . animalNodeToSkellyNode $ withFlip
+  (ps,ns) = sumPositionsAndNormalsForTesting pm
+  l = case bt of
+    ReflX -> _x
+    ReflY -> _y
+    ReflZ -> _z
+    _ -> undefined
+  eps = 0.00001
+  r = (view l ps < eps) && (view l ns < eps)
+
+
 
 -- TODO spins an animal node around several times (total 360 degrees)
 -- and checks that all coordinates around spun axis add to 0
 --prop_flipAnimalNode_Spin :: Bool
 
--- TODO creates an animalNode using flipAnimalNode twice and checks that the nodes that got flipped twice match their unflipped values
---spec_flipAnimalNode_Twice :: Bool
-
+-- | checks that the nodes that got flipped twice match their unflipped values
+prop_flipAnimalNode_Twice :: (AnimalFloat a, Epsilon a) => BoneTrans a -> AnimalNode a -> Bool
+prop_flipAnimalNode_Twice bt an = r where
+  flipOnce = flipAnimalNode bt (defTransFlag bt) an
+  flipTwice = flipAnimalNode bt (defTransFlag bt) flipOnce
+  pm_orig = generatePotatoMesh . animalNodeToSkellyNode $ an
+  pm_flipTwice = generatePotatoMesh . animalNodeToSkellyNode $ flipTwice
+  -- cheap way to test if the two meshes are the same
+  -- we could prob do better here and test that the two meshes are identical but whatever
+  (ps,ns) = sumPositionsAndNormalsForTesting pm_orig
+  (ps',ns') = sumPositionsAndNormalsForTesting pm_flipTwice
+  r = nearZero (ps - ps') && nearZero (ns - ns')
 
 -- math stuff
+-- TODO move to a new file
 
 -- | this only generates "nice" TRS (nothing weird going on in scale component)
 instance (Arbitrary a, AnimalFloat a) => Arbitrary (TRS a) where
@@ -82,6 +133,11 @@ spec_fromEulerXYZ = do
 
 spec :: Spec
 spec = do
+  describe "Skellygen" $ do
+    it "satisfies property that reflected node coordinates all add up to 0 in reflected coordinate" $
+      property (prop_flipAnimalNode_Refl @Double)
+    it "satisfies property that reflecting twice gives the same thing" $
+      property (prop_flipAnimalNode_Twice @Double)
   describe "TRS" $ do
     it "mul_TRS_V3 works as expected" $ property $
       prop_mul_TRS_V3