Use rounded shapes instead of TopPrism

2023-03-17 01:05:41 +00:00
parent 539cbe8b18
commit 6425ef3f0a
7 changed files with 73 additions and 65 deletions
@@ -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
@@ -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 #-}
@@ -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
@@ -96,15 +96,16 @@ pokeShapeObj ::
    Surface ->
    IO (Int, Int, Int)
 {-# INLINE pokeShapeObj #-}
-pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col) = case shtype of
-    TopPrism size -> pokeTopPrism midp col size ptr iptr ieptr counts (VFSM.fromList shVerts)
-    FlatFaces size -> pokeBox col size ptr iptr ieptr counts shVerts
-    RoundedFaces size -> pokeRoundedFaces col size ptr iptr ieptr counts shVerts
-    Cylinder size -> pokeCylinder col size ptr iptr ieptr counts shVerts
+pokeShapeObj ptr iptr ieptr counts (Surface shtype shVerts col shadfid) = case shtype of
+    TopPrism size -> pokeTopPrism shadfid midp col size ptr iptr ieptr counts (VFSM.fromList shVerts)
+    FlatFaces size -> pokeBox shadfid col size ptr iptr ieptr counts shVerts
+    RoundedFaces size -> pokeRoundedFaces shadfid 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' <-
-        UV.foldM' (pokeIndex nv ieptr) nei $
+    nei' <- case sfid of 
+        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' <-
-        UV.foldM' (pokeIndex nv ieptr) nei $
+    nei' <- case sfid of 
+        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 False (x : xs) n = pokeJustV bc col ptr n x >>= go True 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 _ [] 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' <-
-        UV.foldM' (pokeIndex nv ieptr) nei $
+    nei' <- case sfid of 
+        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' <-
-        UV.foldM'
-            (pokeIndex nv ieptr)
-            nei
-            (memoTopPrismEdgeIndices V.! (size - 3))
+    nei' <- case sfid of
+        NoShadowFidelity -> return nei
+        FullShadowFidelity -> UV.foldM' (pokeIndex nv ieptr) nei $
+            memoTopPrismEdgeIndices V.! (size - 3)
    return (nv', nsi', nei')

 pokeIndex ::
@@ -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]
-  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 _ = []
+upperPrismPoly h ps = prismPoly (map (addZ h) ps) (map (addZ 0) ps)

 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
-    downps = map f'' ps
-    f (a:as) (b:bs) = a:b:f as bs
-    f _ _ = []
-    f' (V2 x y) = V3 (0.5 * x) (0.5 * y) h
-    f'' (V2 x y) = V3 x y 0
+    upps = map f ps
+    downps = map g ps
+    f (V2 x y) = V3 (0.5 * x) (0.5 * y) h
+    g (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
@@ -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
@@ -9,8 +9,8 @@ module ShapePicture
    , noShape
 --    , _spShape
 --    , _spPicture
-    , mirrorSPyz
-    , mirrorSPxz
+--    , mirrorSPyz
+--    , mirrorSPxz
    , overPosSP
    ) where
 import ShapePicture.Data
@@ -19,10 +19,7 @@ import Picture
 import Geometry

 import Data.Bifunctor
-import Control.Lens
-
-shMap :: (Surface -> Surface) -> Shape -> Shape
-shMap = map
+--import Control.Lens

 -- 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
-{-# INLINE mirrorSPxz #-}
-mirrorSPxz = bimap (shMap (over sfVs reverse) . overPosSH flipy) mirrorxz
-  where
-    flipy (V3 x y z) = V3 x (negate y) z
-
-mirrorSPyz :: SPic -> SPic
-{-# INLINE mirrorSPyz #-}
-mirrorSPyz = bimap (shMap (over sfVs reverse) . overPosSH flipx) mirroryz
-  where
-    flipx (V3 x y z) = V3 (negate x) y z
+-- Be careful when mirroring: remember the first vertices may indicate the
+-- center of the object or other guides
+--mirrorSPxz :: SPic -> SPic
+--{-# INLINE mirrorSPxz #-}
+--mirrorSPxz = bimap (map (over sfVs reverse) . overPosSH flipy) mirrorxz
+--  where
+--    flipy (V3 x y z) = V3 x (negate y) z
+--
+--mirrorSPyz :: SPic -> SPic
+--{-# INLINE mirrorSPyz #-}
+--mirrorSPyz = bimap (map (over sfVs reverse) . overPosSH flipx) mirroryz
+--  where
+--    flipx (V3 x y z) = V3 (negate x) y z