Use rounded shapes instead of TopPrism

src/Dodge/Creature/HandPos.hs

@@ -45,7 +45,7 @@ translatePointToRightHand' cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 translateToRightHand :: Creature -> SPic -> SPic
-translateToRightHand cr = translateToRightHand' cr . mirrorSPxz
+translateToRightHand cr = translateToRightHand' cr -- . mirrorSPxz
 
 translateToRightHand' :: Creature -> SPic -> SPic
 translateToRightHand' cr
@@ -61,7 +61,7 @@ translateToRightHand' cr
     f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen
 
 translateToRightWrist :: Creature -> SPic -> SPic
-translateToRightWrist cr = translateToRightWrist' cr . mirrorSPxz
+translateToRightWrist cr = translateToRightWrist' cr -- . mirrorSPxz
 
 translateToRightWrist' :: Creature -> SPic -> SPic
 translateToRightWrist' cr

src/Dodge/Creature/Picture.hs

@@ -126,7 +126,7 @@ scalp cr
     | oneH cr = rotateSH 0.5 $ translateSHxy 2.5 0 fhead
     | otherwise = translateSHxy 2.5 0 fhead
   where
-    fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5
+    fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 3 5
 
 torso :: Creature -> Shape
 {-# INLINE torso #-}

src/Dodge/Item/Draw.hs

@@ -29,7 +29,7 @@ equipPosition epos cr p sh = case epos of
     OnRightWrist -> translateToRightWrist cr sh
     OnLegs ->
         translateToLeftLeg cr sh
-            <> translateToRightLeg cr (mirrorSPxz sh)
+            <> translateToRightLeg cr sh-- (mirrorSPxz sh)
     OnHead -> translateToHead cr sh
     OnChest -> translateToChest cr sh
     OnBack -> translateToBack cr p sh

src/Shader/Poke.hs

@@ -96,15 +96,16 @@ pokeShapeObj ::
     Surface ->
     IO (Int, Int, Int)
 {-# INLINE pokeShapeObj #-}
-pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
+pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col shadfid) = case shtype of
-    TopPrism size -> pokeTopPrism midp col size ptr iptr ieptr counts (VFSM.fromList shVerts)
+    TopPrism size -> pokeTopPrism shadfid midp col size ptr iptr ieptr counts (VFSM.fromList shVerts)
-    FlatFaces size -> pokeBox col size ptr iptr ieptr counts shVerts
+    FlatFaces size -> pokeBox shadfid col size ptr iptr ieptr counts shVerts
-    RoundedFaces size -> pokeRoundedFaces col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces shadfid col size ptr iptr ieptr counts shVerts
-    Cylinder size -> pokeCylinder col size ptr iptr ieptr counts shVerts
+    Cylinder size -> pokeCylinder shadfid col size ptr iptr ieptr counts shVerts
   where
     midp = centroidNum shVerts
 
 pokeRoundedFaces ::
+    ShadowFidelity ->
     Point4 ->
     Int ->
     Ptr Float ->
@@ -113,20 +114,23 @@ pokeRoundedFaces ::
     (Int, Int, Int) ->
     [Point3] ->
     IO (Int, Int, Int)
-pokeRoundedFaces col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do
+{-# INLINE pokeRoundedFaces #-}
+pokeRoundedFaces sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do
     nv' <- pokeRoundedCurve col ptr tc bc svs nv
     nsi' <-
         UV.foldM'
             (pokeIndex nv iptr)
             nsi
             (memoTopPrismIndices V.! (size - 3))
-    nei' <-
+    nei' <- case sfid of 
-        UV.foldM' (pokeIndex nv ieptr) nei $
+        NoShadowFidelity -> return nei
+        FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $
             memoTopPrismEdgeIndices V.! (size - 3)
     return (nv', nsi', nei')
-pokeRoundedFaces _ _ _ _ _ _ _ = undefined
+pokeRoundedFaces _ _ _ _ _ _ _ _ = undefined
 
 pokeCylinder ::
+    ShadowFidelity ->
     Point4 ->
     Int ->
     Ptr Float ->
@@ -135,24 +139,27 @@ pokeCylinder ::
     (Int, Int, Int) ->
     [Point3] ->
     IO (Int, Int, Int)
-pokeCylinder col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do
+{-# INLINE pokeCylinder #-}
+pokeCylinder sfid col size ptr iptr ieptr (nv, nsi, nei) (tc : bc : svs) = do
     nv' <- pokeRoundedCurve col ptr tc bc svs nv >>= pokeCylinderCaps col ptr tc bc svs
     nsi' <-
         UV.foldM'
             (pokeIndex nv iptr)
             nsi
             (memoCylinderIndices V.! (size - 3))
-    nei' <-
+    nei' <- case sfid of 
-        UV.foldM' (pokeIndex nv ieptr) nei $
+        NoShadowFidelity -> return nei
+        FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $
             memoTopPrismEdgeIndices V.! (size - 3)
     return (nv', nsi', nei')
-pokeCylinder _ _ _ _ _ _ _ = undefined
+pokeCylinder _ _ _ _ _ _ _ _ = undefined
 
 pokeRoundedCurve :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int
+{-# INLINE pokeRoundedCurve #-}
 pokeRoundedCurve col ptr tc bc = go True
   where
-    go True (x : xs) n = pokeJustV tc col ptr n x >>= go False xs
+    go True  (x : xs) n = pokeJustV tc col ptr n x >>= go False xs
-    go False (x : xs) n = pokeJustV bc col ptr n x >>= go True xs
+    go False (x : xs) n = pokeJustV bc col ptr n x >>= go True  xs
     go _ [] n = return n
 
 pokeCylinderCaps :: Point4 -> Ptr Float -> Point3 -> Point3 -> [Point3] -> Int -> IO Int
@@ -163,6 +170,7 @@ pokeCylinderCaps col ptr tc bc = go True
     go _ [] n = return n
 
 pokeBox ::
+    ShadowFidelity ->
     Point4 ->
     Int ->
     Ptr Float ->
@@ -172,15 +180,16 @@ pokeBox ::
     [Point3] ->
     IO (Int, Int, Int)
 {-# INLINE pokeBox #-}
-pokeBox col size ptr iptr ieptr (nv, nsi, nei) svs = do
+pokeBox sfid col size ptr iptr ieptr (nv, nsi, nei) svs = do
     nv' <- VFSM.foldM' (pokeBoxSurface col ptr svsv) nv $ VFSM.fromList $ boxSurfaces size
     nsi' <-
         UV.foldM'
             (pokeIndex nv iptr)
             nsi
             (memoFlatIndices V.! (size -3))
-    nei' <-
+    nei' <- case sfid of 
-        UV.foldM' (pokeIndex nv ieptr) nei $
+        NoShadowFidelity -> return nei
+        FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $
             memoBoxEdgeIndices V.! (size - 3)
     return (nv', nsi', nei')
   where
@@ -216,6 +225,7 @@ boxSurfaces' n =
     [ map ((2 * n) +) [4 * i, 4 * i + 1, 4 * i + 2, 4 * i + 3] | i <- [0 .. n -1]]
 
 pokeTopPrism ::
+    ShadowFidelity ->
     Point3 ->
     Point4 ->
     Int ->
@@ -226,18 +236,17 @@ pokeTopPrism ::
     VFSM.Stream IO Point3 ->
     IO (Int, Int, Int)
 {-# INLINE pokeTopPrism #-}
-pokeTopPrism cp col size ptr iptr ieptr (nv, nsi, nei) svs = do
+pokeTopPrism sfid cp col size ptr iptr ieptr (nv, nsi, nei) svs = do
     nv' <- VFSM.foldlM' (pokeJustV cp col ptr) nv svs
     nsi' <-
         UV.foldM'
             (pokeIndex nv iptr)
             nsi
             (memoTopPrismIndices V.! (size - 3))
-    nei' <-
+    nei' <- case sfid of
-        UV.foldM'
+        NoShadowFidelity -> return nei
-            (pokeIndex nv ieptr)
+        FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $
-            nei
+            memoTopPrismEdgeIndices V.! (size - 3)
-            (memoTopPrismEdgeIndices V.! (size - 3))
     return (nv', nsi', nei')
 
 pokeIndex ::

src/Shape.hs

@@ -41,8 +41,10 @@ prismPoly
     -> [Point3] 
     -> Shape
 {-# INLINE prismPoly #-}
-prismPoly upps downps = [Surface (TopPrism n) (f upps downps) white]
+--prismPoly upps downps = [Surface (TopPrism n) (f upps downps) white FullShadowFidelity]
+prismPoly upps downps = [Surface (RoundedFaces n) (cp:cp:f upps downps) white FullShadowFidelity]
   where
+    cp = centroidNum $ upps ++ downps
     n = length upps
     f (a:as) (b:bs) = a:b:f as bs
     f _ _ = []
@@ -52,19 +54,14 @@ upperPrismPoly
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPoly #-}
-upperPrismPoly h ps = [Surface (TopPrism n) (f ps) white]
+upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)
-  where
-    n = length ps
-    g h' (V2 x y) = V3 x y h'
-    f (x:xs) = g h x : g 0 x : f xs
-    f _ = []
 
 upperBox 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
     -> Shape
 {-# INLINE upperBox #-}
-upperBox h ps = [Surface (FlatFaces n) (f ps) white]
+upperBox h ps = [Surface (FlatFaces n) (f ps) white FullShadowFidelity]
   where
     n = length ps
     g h' (V2 x y) = V3 x y h'
@@ -76,7 +73,7 @@ upperCylinder
     -> [Point2] 
     -> Shape
 {-# INLINE upperCylinder #-}
-upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white]
+upperCylinder h ps = [Surface (Cylinder n) (addZ (h-0.5) cc:addZ 0.5 cc:f ps) white FullShadowFidelity]
   where
     cc = centroid ps
     n = length ps
@@ -89,7 +86,7 @@ upperRounded
     -> [Point2] 
     -> Shape
 {-# INLINE upperRounded #-}
-upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white]
+upperRounded h ps = [Surface (RoundedFaces n) (addZ h cc:addZ 0 cc:f ps) white FullShadowFidelity]
   where
     cc = centroid ps
     n = length ps
@@ -102,15 +99,12 @@ upperPrismPolyHalf
     -> [Point2] 
     -> Shape
 {-# INLINE upperPrismPolyHalf #-}
-upperPrismPolyHalf h ps = [Surface (TopPrism n) (f upps downps) white]
+upperPrismPolyHalf h ps = prismPoly upps downps
   where
-    n = length ps
+    upps = map f ps
-    upps = map f' ps
+    downps = map g ps
-    downps = map f'' ps
+    f (V2 x y) = V3 (0.5 * x) (0.5 * y) h
-    f (a:as) (b:bs) = a:b:f as bs
+    g (V2 x y) = V3 x y 0
-    f _ _ = []
-    f' (V2 x y) = V3 (0.5 * x) (0.5 * y) h
-    f'' (V2 x y) = V3 x y 0
 
 colorSH :: Color -> Shape -> Shape
 {-# INLINE colorSH #-}
@@ -150,8 +144,8 @@ scaleSH (V3 a b c) = overPosSH (\(V3 x y z) -> V3 (x*a) (y*b) (z*c))
 
 overColObj :: (Point4 -> Point4) -> Surface -> Surface
 {-# INLINE overColObj #-}
-overColObj f (Surface st vs col) = Surface st vs (f col)
+overColObj f (Surface st vs col sfid) = Surface st vs (f col) sfid
 
 overPosObj :: (Point3 -> Point3) -> Surface -> Surface
 {-# INLINE overPosObj #-}
-overPosObj f (Surface st vs col) = Surface st (map f vs) col
+overPosObj f (Surface st vs col sfid) = Surface st (map f vs) col sfid

src/Shape/Data.hs

@@ -22,10 +22,15 @@ data ShapeType
 -- for RoundedFaces, the first vertex in _sfVs should be the center of the top
 -- plane, the second should be the center of the bottom plane.
 
+data ShadowFidelity = FullShadowFidelity
+    | NoShadowFidelity
+    deriving (Eq, Ord, Show, Read) --Generic, Flat)
+
 data Surface = Surface
     { _sfType :: ShapeType
     , _sfVs :: [Point3]
     , _sfColor :: Point4
+    , _sfShadowFidelity :: ShadowFidelity
     }
     deriving (Eq, Ord, Show, Read) --Generic, Flat)
 
@@ -40,5 +45,6 @@ nShapeVerxComp = sum shapeVerxSizes
 shapeVerxSizes :: [Int]
 shapeVerxSizes = [4,4,4]
 
+deriveJSON defaultOptions ''ShadowFidelity
 deriveJSON defaultOptions ''ShapeType
 deriveJSON defaultOptions ''Surface

src/ShapePicture.hs

@@ -9,8 +9,8 @@ module ShapePicture
     , noShape
 --    , _spShape
 --    , _spPicture
-    , mirrorSPyz
+--    , mirrorSPyz
-    , mirrorSPxz
+--    , mirrorSPxz
     , overPosSP
     ) where
 import ShapePicture.Data
@@ -19,10 +19,7 @@ import Picture
 import Geometry
 
 import Data.Bifunctor
-import Control.Lens
+--import Control.Lens
-
-shMap :: (Surface -> Surface) -> Shape -> Shape
-shMap = map
 
 -- should all this be inlined/inlinable?
 noPic :: Shape -> SPic
@@ -61,14 +58,16 @@ rotateSP :: Float -> SPic -> SPic
 {-# INLINE rotateSP #-}
 rotateSP a = bimap (rotateSH a) (rotate a)
 
-mirrorSPxz :: SPic -> SPic
+-- Be careful when mirroring: remember the first vertices may indicate the
-{-# INLINE mirrorSPxz #-}
+-- center of the object or other guides
-mirrorSPxz = bimap (shMap (over sfVs reverse) . overPosSH flipy) mirrorxz
+--mirrorSPxz :: SPic -> SPic
-  where
+--{-# INLINE mirrorSPxz #-}
-    flipy (V3 x y z) = V3 x (negate y) z
+--mirrorSPxz = bimap (map (over sfVs reverse) . overPosSH flipy) mirrorxz
-
+--  where
-mirrorSPyz :: SPic -> SPic
+--    flipy (V3 x y z) = V3 x (negate y) z
-{-# INLINE mirrorSPyz #-}
+--
-mirrorSPyz = bimap (shMap (over sfVs reverse) . overPosSH flipx) mirroryz
+--mirrorSPyz :: SPic -> SPic
-  where
+--{-# INLINE mirrorSPyz #-}
-    flipx (V3 x y z) = V3 (negate x) y z
+--mirrorSPyz = bimap (map (over sfVs reverse) . overPosSH flipx) mirroryz
+--  where
+--    flipx (V3 x y z) = V3 (negate x) y z