Performance tweaks

bench/Bench.hs

@@ -3,6 +3,7 @@ import Criterion.Main
 import Dodge.RandomHelp
 
 import Geometry
+import Dodge.Creature.Inanimate
 
 import System.Random
 import Control.Monad (replicateM)
@@ -12,12 +13,20 @@ import Data.List (zip4)
 
 main :: IO ()
 main = do
-    [ps1, ps2, ps3, ps4] <- mapM randomPoints [500,500,500,500]
-    fs <- replicateM 500 (randomRIO (1,20))
+    [ps1, ps2, ps3, ps4] <- mapM randomPoints [5,10,50,500]
+--    fs <- replicateM 500 (randomRIO (1,20))
     defaultMain
-        [ bgroup "circLine tests"
-            [ bench "circLine" $ nf (map $ uncurry4 circOnLine) (zip4 ps1 ps2 ps3 fs)           
-            , bench "circLine'" $ nf (map $ uncurry4 circOnLine') (zip4 ps1 ps2 ps3 fs)           
+        [ bgroup "polyToTris tests"
+            [ bench "polyToTris 5" $ nf polyToTris ps1          
+            , bench "polyToTris 10" $ nf polyToTris ps2          
+            , bench "polyToTris 50" $ nf polyToTris ps3          
+            , bench "polyToTris 500" $ nf polyToTris ps4          
+            ]
+        , bgroup "polyToTriFold tests"
+            [ bench "polyToTriFold 5" $ nf polyToTris'' ps1          
+            , bench "polyToTriFold 10" $ nf polyToTris'' ps2          
+            , bench "polyToTriFold 50" $ nf polyToTris'' ps3          
+            , bench "polyToTriFold 500" $ nf polyToTris'' ps4          
             ]
         ]
 

src/Dodge/Creature/Picture.hs

@@ -8,11 +8,11 @@ module Dodge.Creature.Picture
     , picAtCrPosNoRot
     ) where
 import Dodge.Data
-import Dodge.Data.DamageType
+--import Dodge.Data.DamageType
 --import Dodge.Base
 --import Dodge.Creature.Stance.Data
 import Dodge.Creature.Perception.Data
-import Dodge.Creature.State.Data
+--import Dodge.Creature.State.Data
 import Dodge.Creature.Stance.Data
 --import Dodge.Creature.Memory.Data
 import Dodge.Creature.Test
@@ -27,7 +27,6 @@ import ShapePicture
 --import Geometry.Vector3D
 
 import Control.Lens
-import Data.List
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Vector as V
 basicCrPict 
@@ -35,36 +34,29 @@ basicCrPict
     -> Creature 
     -> World
     -> SPic
-basicCrPict col cr w = SPic (basicCrShape col cr w) $ pictures $
+basicCrPict col cr w = SPic (basicCrShape col cr) $ pictures $
     targetingPic ++
     [ creatureDisplayText w cr
     , tr . rotdir $ _spPicture $ drawEquipment cr
     ]
   where 
-    dm = damageMod cr
     targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
     f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
     tr = uncurryV translate (_crPos cr) 
     rotdir = rotate (_crDir cr)
-    rotmdir = rotate (_crMvDir cr)
-        . setDepth 1 
-        . color (greyN 0.3)
 
 basicCrShape 
     :: Color    -- ^ Creature color
     -> Creature 
-    -> World
     -> Shape
-basicCrShape col cr w = mconcat
-    [ tr . rotdir $ _spShape $ drawEquipment cr
-    , tr . translateSHz 25 . dm . rotdir $ scalp cr
-    , tr . dm . rotmdir $ feet cr
-    , tr . dm . rotdir $ upperBody col cr
+basicCrShape col cr = tr $ mconcat
+    [ rotdir $ _spShape $ drawEquipment cr
+    , translateSHz 25 . dm . rotdir $ scalp cr
+    , dm . rotmdir $ feet cr
+    , dm . rotdir $ upperBody col cr
     ]
   where 
     dm = damageModSH cr
-    targetingPic = IM.elems $ IM.mapMaybeWithKey f $ _crInv cr
-    f invid it = fmap ((\g -> g invid it cr w) . snd) (it ^? itTargeting . _Just)
     tr = uncurryV translateSHf (_crPos cr)
     rotdir = rotateSH (_crDir cr)
     rotmdir = rotateSH (_crMvDir cr)
@@ -110,26 +102,27 @@ crDisplayAwake cr = case _crAwakeLevel (_crPerception cr) of
     Lethargic   -> "L"
     Vigilant    -> "V"
     Overstrung  -> "O"
-damageMod :: Creature -> Picture -> Picture
-damageMod cr pic = piercingMod $ bluntScale pic
-  where
-    cdir = _crDir cr
-    pastDams = _crPastDamage $ _crState cr
-    bluntDam :: Maybe Point2
-    bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
-    bluntScale = case fmap argV bluntDam of
-        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
-        _   -> id
-    isBluntDam Blunt{} = True
-    isBluntDam _ = False
-    piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
-    isPiercingDam Piercing{} = True
-    isPiercingDam _ = False
-    piercingMod = case fmap argV piercingDam of
-        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
-        _   -> id
+
+--damageMod :: Creature -> Picture -> Picture
+--damageMod cr pic = piercingMod $ bluntScale pic
+--  where
+--    cdir = _crDir cr
+--    pastDams = _crPastDamage $ _crState cr
+--    bluntDam :: Maybe Point2
+--    bluntDam = find isBluntDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
+--    bluntScale = case fmap argV bluntDam of
+--        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
+--        _   -> id
+--    isBluntDam Blunt{} = True
+--    isBluntDam _ = False
+--    piercingDam = find isPiercingDam (concat pastDams) >>= (\dm -> (-.-) <$> dm ^? dmFrom <*> dm ^? dmTo)
+--    isPiercingDam Piercing{} = True
+--    isPiercingDam _ = False
+--    piercingMod = case fmap argV piercingDam of
+--        Just a -> rotate (a + cdir) . scale 0.8 1.2 . rotate (negate $ cdir + a)
+--        _   -> id
 damageModSH :: Creature -> Shape -> Shape
-damageModSH cr = id
+damageModSH _ = id
 
 feet :: Creature -> Shape
 feet cr = case cr ^? crStance . carriage of
@@ -147,7 +140,7 @@ feet cr = case cr ^? crStance . carriage of
         ]
   where
     aFoot :: Shape
-    aFoot = prismPoly 10 $ polyCirc 3 4
+    aFoot = upperPrismPoly 10 $ polyCirc 3 4
     off = 5
     sLen = _strideLength $ _crStance cr
     f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen
@@ -165,7 +158,7 @@ arms cr
         _ -> emptySH 
   where
     aHand :: Shape
-    aHand = translateSHz (-4) . prismPoly 4 $ polyCirc 3 4
+    aHand = translateSHz (-4) . upperPrismPoly 4 $ polyCirc 3 4
     crad = _crRad cr
     off = 8
     sLen = _strideLength $ _crStance cr
@@ -176,9 +169,8 @@ scalp cr
     | twists cr = translateSHf 0 (0.5*crad) . rotateSH (-1) $ translateSHf (negate 0.25 * crad) 0.25 fhead
     | oneH   cr = rotateSH 0.5 $ translateSHf (0.25 * crad) 0 fhead
     | otherwise = translateSHf (0.25 * crad) 0 fhead
-    
   where
-    fhead = colorSH (greyN 0.9) . prismPoly 5 . polyCirc 3 $ crad * 0.5
+    fhead = colorSH (greyN 0.9) . upperPrismPoly 5 . polyCirc 3 $ crad * 0.5
     crad = _crRad cr
 
 oneH :: Creature -> Bool
@@ -206,9 +198,15 @@ torso cr
         , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder
         ]
   where
-    aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . prismPoly 10 $ polyCirc 3 crad
+    --aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad
+    aShoulder = scaleSH (V3 crad crad 1) baseShoulder
     crad = _crRad cr
 
+baseShoulder :: Shape
+baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 1
+
+
+
 upperBody :: Color -> Creature -> Shape
 upperBody col cr = colorSH (light4 col) $ mconcat
     [ arms cr
@@ -226,11 +224,6 @@ upperBody col cr = colorSH (light4 col) $ mconcat
 --    pdam = sum $ concatMap (map _dmAmount) pastDams
 --    pastDams = _crPastDamage $ _crState cr
 
-shoulderH :: Picture -> Picture
-shoulderH = setDepth 20
-waistH :: Picture -> Picture
-waistH = setDepth 10
-
 shoulderSH :: Shape -> Shape
 shoulderSH = translateSHz 20
 waistSH :: Shape -> Shape

src/Dodge/Item/Draw.hs

@@ -2,10 +2,10 @@ module Dodge.Item.Draw
     where
 import Dodge.Data
 import Dodge.Item.Data
-import Dodge.Picture.Layer
+--import Dodge.Picture.Layer
 import Dodge.Creature.Stance.Data
-import Picture
-import Shape
+--import Picture
+--import Shape
 import ShapePicture
 
 import qualified Data.IntMap.Strict as IM

src/Dodge/Render.hs

@@ -38,6 +38,7 @@ import Control.Monad
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 import qualified SDL
 import qualified Data.Vector.Unboxed.Mutable as UMV
+import qualified Data.Vector.Fusion.Stream.Monadic as VS
 
 doDrawing :: RenderData -> World -> IO Word32
 doDrawing pdata w = do
@@ -56,12 +57,14 @@ doDrawing pdata w = do
     -- poke wall points and colors
     nWalls <- poke224s (shadVBOptr $ _wallTextureShader pdata) wallPointsCol
     nSils <- pokePoint3s (shadVBOptr $ _lightingLineShadowShader pdata) 
-        $ (_shEdges $ worldShape w)
-        ++ _foregroundEdgeVerx w
+        $  VS.fromList
+        $ (shEList $ worldShape w)
+        ++ (_foregroundEdgeVerx w)
     -- poke foreground geometry for caps
     nCaps <- pokePoint3s (shadVBOptr $ _lightingCapShader pdata)
+        $ VS.fromList
         $ concatMap polyToGeoRender (foregroundPics w)
-            ++ map _svPos (_shVertices $ worldShape w)
+            ++ (fmap _svPos (shVList $ worldShape w))
     -- bind wall points, silhouette data, surface geometry
     uncurry bindShaderBuffers $ unzip
         [ ( _wallTextureShader pdata, nWalls)
@@ -91,7 +94,7 @@ doDrawing pdata w = do
     renderLayer 0 shadV layerCounts
 
     numShapeVs <- pokeShapeVs (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) 
-        $ _shVertices $ worldShape w
+        $ VS.fromList $ shVList $ worldShape w
     bindShaderBuffers [_shapeShader pdata] [numShapeVs]
     drawShader (_shapeShader pdata) numShapeVs
 

src/Dodge/Render/Shape.hs

@@ -3,7 +3,7 @@ module Dodge.Render.Shape
 import Dodge.Data
 import Shape
 import Geometry
-import Color
+--import Color
 import ShapePicture
 import Dodge.Base.Window
 

src/Geometry/Vector.hs

@@ -83,11 +83,11 @@ rotateV r (V2 x y) = V2
 {-# INLINE rotateV #-}
 -- | Convert degrees to radians
 degToRad :: Float -> Float
-degToRad d      = d * pi / 180
+degToRad d = d * pi / 180
 {-# INLINE degToRad #-}
 -- | Convert radians to degrees
 radToDeg :: Float -> Float
-radToDeg r      = r * 180 / pi
+radToDeg r = r * 180 / pi
 {-# INLINE radToDeg #-}
 -- | Normalize an angle to be between 0 and 2*pi radians
 normalizeAngle :: Float -> Float

src/Geometry/Vector3D.hs

@@ -12,23 +12,21 @@ infixl 7 *.*.*
 {- | 3D coordinate-wise addition.  -}
 (+.+.+) :: Point3 -> Point3 -> Point3
 {-# INLINE (+.+.+) #-}
-(+.+.+) = (+)
---(x1, y1, z1) +.+.+ (x2, y2, z2) =
---  let
---    !x = x1 + x2
---    !y = y1 + y2
---    !z = z1 + z2
---  in (x, y, z)
+V3 x1 y1 z1 +.+.+ V3 x2 y2 z2 =
+  let
+    !x = x1 + x2
+    !y = y1 + y2
+    !z = z1 + z2
+  in V3 x y z
 {- | 3D coordinate-wise subtraction.  -}
 (-.-.-) :: Point3 -> Point3 -> Point3
 {-# INLINE (-.-.-) #-}
-(-.-.-) = (-)
---(x1, y1, z1) -.-.- (x2, y2, z2) =
---  let
---    !x = x1 - x2
---    !y = y1 - y2
---    !z = z1 - z2
---  in (x, y, z)
+V3 x1 y1 z1 -.-.- V3 x2 y2 z2 =
+  let
+    !x = x1 - x2
+    !y = y1 - y2
+    !z = z1 - z2
+  in V3 x y z
 {- | 3D scalar multiplication.  -}
 (*.*.*) :: Float -> Point3 -> Point3
 {-# INLINE (*.*.*) #-}

src/Shader/Poke.hs

@@ -4,11 +4,11 @@ module Shader.Poke
     ( pokeVerxs
     , pokeLayVerxs
     , pokeArrayOff
-    , pokePoint3s
     , pokePoint33s
     , poke224s
     , pokeShape
     , pokeShapeVs
+    , pokePoint3s
     ) where
 import Shader.Data
 import Shader.Parameters
@@ -21,6 +21,7 @@ import qualified Data.Vector.Unboxed.Mutable as UMV
 import qualified Data.Vector.Mutable as MV
 import qualified Data.Vector.Fusion.Stream.Monadic as VS
 import Control.Monad.Primitive
+import qualified Data.DList as DL
 
 pokeVerxs 
     :: MV.MVector (PrimState IO) FullShader
@@ -42,37 +43,37 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxExt=ext,_vxShadNum=the
 
 pokeShape :: Ptr Float -> Ptr Float -> Shape -> IO (Int,Int)
 pokeShape vptr eptr sh = do
-    nVs <- pokeShapeVs vptr (_shVertices sh)
-    nEs <- pokeShapeEs eptr (_shEdges sh)
+    nVs <- pokeShapeVs vptr (VS.fromList $ shVList sh)
+    nEs <- pokePoint3s eptr (VS.fromList $ shEList sh)
     return (nVs,nEs)
 
-pokeShapeVs :: Ptr Float -> [ShapeV] -> IO Int
-pokeShapeVs ptr vals0 = go vals0 0
-  where
-    go [] n = return n
-    go ( sh:vals) !n = do
-        pokeElemOff ptr (off 0) a
-        pokeElemOff ptr (off 1) b
-        pokeElemOff ptr (off 2) c
-        pokeElemOff ptr (off 3) d
-        pokeElemOff ptr (off 4) e
-        pokeElemOff ptr (off 5) f
-        pokeElemOff ptr (off 6) g
-        go vals (n+1)
-      where
-        off i = n*7 + i
-        V3 a b c    = _svPos sh
-        V4 d e f g  = _svCol sh
+pokeShapeVs :: Ptr Float -> VS.Stream IO ShapeV -> IO Int
+pokeShapeVs ptr = VS.foldlM' (pokeShapeV ptr) 0
 
-pokeShapeEs :: Ptr Float -> [Point3] -> IO Int
-pokeShapeEs ptr vals0 = go vals0 0
+pokeShapeV :: Ptr Float -> Int -> ShapeV -> IO Int
+pokeShapeV ptr n sh = do
+    pokeElemOff ptr (off 0) a
+    pokeElemOff ptr (off 1) b
+    pokeElemOff ptr (off 2) c
+    pokeElemOff ptr (off 3) d
+    pokeElemOff ptr (off 4) e
+    pokeElemOff ptr (off 5) f
+    pokeElemOff ptr (off 6) g
+    return (n+1)
   where
-    go [] n = return n
-    go ((V3 a b c) :vals) !n = do
-        pokeElemOff ptr (n * 3) a
-        pokeElemOff ptr (n * 3 + 1) b
-        pokeElemOff ptr (n * 3 + 2) c
-        go vals (n+1)
+    off i = n*7 + i
+    V3 a b c    = _svPos sh
+    V4 d e f g  = _svCol sh
+
+pokePoint3s :: Ptr Float -> VS.Stream IO Point3 -> IO Int
+pokePoint3s ptr = VS.foldlM' (pokePoint3 ptr) 0
+
+pokePoint3 :: Ptr Float -> Int -> Point3 -> IO Int
+pokePoint3 ptr n (V3 a b c) = do
+    pokeElemOff ptr (n * 3) a
+    pokeElemOff ptr (n * 3 + 1) b
+    pokeElemOff ptr (n * 3 + 2) c
+    return $ n + 1
 
 pokeLayVerxs 
     :: MV.MVector (PrimState IO) FullShader 
@@ -153,45 +154,33 @@ pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))
 --    pokeElemOff ptr (4*n+3) w
 
 pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
-pokePoint33s ptr vals0 = go vals0 0
-  where
-    go [] n = return n
-    go ( (V3 a b c,V3 d e f):vals) !n = do
-        pokeElemOff ptr (off 0) a
-        pokeElemOff ptr (off 1) b
-        pokeElemOff ptr (off 2) c
-        pokeElemOff ptr (off 3) d
-        pokeElemOff ptr (off 4) e
-        pokeElemOff ptr (off 5) f
-        go vals (n+1)
-      where
-        off i = n*6 + i
+pokePoint33s ptr = VS.foldlM' (pokePoint33 ptr) 0 . VS.fromList
 
-pokePoint3s :: Ptr Float -> [Point3] -> IO Int
-pokePoint3s ptr vals0 = go vals0 0
+pokePoint33 :: Ptr Float -> Int -> (Point3,Point3) -> IO Int
+pokePoint33 ptr n (V3 a b c,V3 d e f) = do
+    pokeElemOff ptr (off 0) a
+    pokeElemOff ptr (off 1) b
+    pokeElemOff ptr (off 2) c
+    pokeElemOff ptr (off 3) d
+    pokeElemOff ptr (off 4) e
+    pokeElemOff ptr (off 5) f
+    return (n+1)
   where
-    go [] n = return n
-    go ( V3 a b c:vals) !n = do
-        pokeElemOff ptr (off 0) a
-        pokeElemOff ptr (off 1) b
-        pokeElemOff ptr (off 2) c
-        go vals (n+1)
-      where
-        off i = n*3 + i
+    off i = n*6 + i
+
+pokePoint224 :: Ptr Float -> Int -> ((Point2,Point2),Point4) -> IO Int
+pokePoint224 ptr n ((V2 a b,V2 c d),V4 e f g h) = do
+    pokeElemOff ptr (off 0) a
+    pokeElemOff ptr (off 1) b
+    pokeElemOff ptr (off 2) c
+    pokeElemOff ptr (off 3) d
+    pokeElemOff ptr (off 4) e
+    pokeElemOff ptr (off 5) f
+    pokeElemOff ptr (off 6) g
+    pokeElemOff ptr (off 7) h
+    return (n + 1)
+  where
+    off i = n*8 + i
 
 poke224s :: Ptr Float -> [((Point2,Point2),Point4)] -> IO Int
-poke224s ptr vals0 = go vals0 0
-  where
-    go [] n = return n
-    go (((V2 a b,V2 c d),V4 e f g h):vals) !n = do
-        pokeElemOff ptr (off 0) a
-        pokeElemOff ptr (off 1) b
-        pokeElemOff ptr (off 2) c
-        pokeElemOff ptr (off 3) d
-        pokeElemOff ptr (off 4) e
-        pokeElemOff ptr (off 5) f
-        pokeElemOff ptr (off 6) g
-        pokeElemOff ptr (off 7) h
-        go vals (n+1)
-      where
-        off i = n*8 + i
+poke224s ptr = VS.foldlM' (pokePoint224 ptr) 0 . VS.fromList

src/Shape.hs

@@ -4,6 +4,7 @@ module Shape
     , translateSH
     , emptySH
     , polyCirc
+    , upperPrismPoly
     , prismPoly
     , flatCirc
     , translateSHz
@@ -19,9 +20,12 @@ import Geometry.ConvexPoly
 import Shape.Data
 import Color
 
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
+--import qualified Data.DList as DL
+
 emptySH :: Shape
 {-# INLINE emptySH #-}
-emptySH = Shape [] []
+emptySH = Shape mempty mempty
 
 flatCirc :: Float -> Shape
 {-# INLINE flatCirc #-}
@@ -31,36 +35,60 @@ polyCirc :: Int -> Float -> [Point2]
 {-# INLINE polyCirc #-}
 polyCirc n x = map (\a -> rotateV a (V2 x 0)) $ take (n*2) [0,pi/(fromIntegral n)..]
 
+upperPrismPoly 
+    :: Float    -- ^ height, expected to be strictly positive
+    -> [Point2] 
+    -> Shape
+{-# INLINE upperPrismPoly #-}
+upperPrismPoly h ps = Shape
+    { _shVertices = topFace <> sideFaces
+    , _shEdges = topEdges <> bottomEdges <> sideEdges
+    }
+  where
+    topFace = shVfromList $ polyToTris $ map f' ps
+    f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black }
+    sideFaces = shVfromList $ map addCol $ concat 
+        $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
+    addCol x = ShapeV {_svPos = x, _svCol = black}
+    extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
+    topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
+    makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
+    V2 xcen ycen = centroid ps
+    bottomEdges = shEfromList $ concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
+    makeBottomEdge (V2 x' y') (V2 x y) = [V3 x y 0,V3 x' y' 0,V3 x y h,V3 xcen ycen 0]
+    sideEdges = shEfromList $ concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
+    makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
+
 prismPoly 
     :: Float    -- ^ height, expected to be strictly positive
     -> [Point2] 
     -> Shape
 {-# INLINE prismPoly #-}
 prismPoly h ps = Shape
-    { _shVertices = topFace ++ bottomFace ++ sideFaces
-    , _shEdges = topEdges ++ bottomEdges ++ sideEdges
+    { _shVertices = topFace <> bottomFace <> sideFaces
+    , _shEdges = topEdges <> bottomEdges <> sideEdges
     }
   where
-    topFace = polyToTris $ map f' ps
+    topFace = shVfromList $ polyToTris $ map f' ps
     f' (V2 x y) = ShapeV {_svPos = V3 x y h, _svCol = black }
     f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
-    bottomFace = polyToTris $ map f $ reverse ps
-    sideFaces = map addCol $ concat 
+    bottomFace = shVfromList $ polyToTris $ map f $ reverse ps
+    sideFaces = shVfromList $ map addCol $ concat 
         $ zipWith (\a b -> polyToTris (extendSide a b)) ps (tail ps ++ [head ps])
     addCol x = ShapeV {_svPos = x, _svCol = black}
     extendSide (V2 x y) (V2 x' y') = [V3 x y 0, V3 x' y' 0, V3 x' y' h, V3 x y h]
-    topEdges = concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
+    topEdges = shEfromList $ concat $ zipWith makeTopEdge ps (tail ps ++ [head ps])
     makeTopEdge (V2 x y) (V2 x' y') = [V3 x y h,V3 x' y' h,V3 x y 0,V3 xcen ycen h]
     V2 xcen ycen = centroid ps
-    bottomEdges = concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
+    bottomEdges = shEfromList $ concat $ zipWith makeBottomEdge ps (tail ps ++ [head ps])
     makeBottomEdge (V2 x' y') (V2 x y) = [V3 x y 0,V3 x' y' 0,V3 x y h,V3 xcen ycen 0]
-    sideEdges = concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
+    sideEdges = shEfromList $ concat $ zipWith3 makeSideEdge ps (tail ps ++ [head ps]) (drop 2 ps ++ take 2 ps)
     makeSideEdge (V2 xl yl) (V2 x y) (V2 xr yr) = [V3 x y 0, V3 x y h, V3 xr yr 0, V3 xl yl h]
 
 flatPoly :: [Point2] -> Shape
 flatPoly ps = Shape
-    { _shVertices = polyToTris $ map f ps
-    , _shEdges = concat $ zipWith g ps (tail ps ++ [head ps])
+    { _shVertices = shVfromList $ polyToTris $ map f ps
+    , _shEdges = shEfromList $ concat $ zipWith g ps (tail ps ++ [head ps])
     }
   where
     f (V2 x y) = ShapeV {_svPos = V3 x y 0, _svCol = black }
@@ -82,15 +110,15 @@ colorSH col = overCol $ const col
 overCol :: (Point4 -> Point4) -> Shape -> Shape
 {-# INLINE overCol #-}
 overCol f Shape{_shVertices=vs,_shEdges=es} = Shape 
-    {_shVertices = map (overColVertex f) vs
+    {_shVertices = fmap (overColVertex f) vs
     ,_shEdges    = es
     }
 
 overPos :: (Point3 -> Point3) -> Shape -> Shape
 {-# INLINE overPos #-}
 overPos f Shape{_shVertices=vs,_shEdges=es} = Shape 
-    {_shVertices = map (overPosVertex f) vs
-    ,_shEdges    = map f es
+    {_shVertices = fmap (overPosVertex f) vs
+    ,_shEdges    = fmap f es
     }
 
 translateSH :: Point3 -> Shape -> Shape
@@ -99,11 +127,11 @@ translateSH !p = overPos (+.+.+ p)
 
 translateSHf :: Float -> Float -> Shape -> Shape
 {-# INLINE translateSHf #-}
-translateSHf x y = translateSH (V3 x y 0)
+translateSHf !x !y = translateSH (V3 x y 0)
 
 translateSHz :: Float -> Shape -> Shape
 {-# INLINE translateSHz #-}
-translateSHz z = translateSH (V3 0 0 z)
+translateSHz !z = translateSH (V3 0 0 z)
 
 rotateSH :: Float -> Shape -> Shape
 {-# INLINE rotateSH #-}

src/Shape/Data.hs

@@ -4,15 +4,29 @@ module Shape.Data
     where
 import Geometry.Data
 import Control.Lens
+--import qualified Data.Vector.Fusion.Stream.Monadic as VS
+import qualified Data.DList as DL
+
 --import Data.Monoid
 data Shape = Shape
-    { _shVertices :: [ShapeV]
-    , _shEdges    :: [Point3]
+    { _shVertices :: DL.DList ShapeV
+    , _shEdges    :: DL.DList Point3
     }
 instance Semigroup Shape where
-    (<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 ++ sv2) (se1 ++ se2)
+    (<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 <> sv2) (se1 <> se2)
+    --(<>) (Shape sv1 se1) (Shape sv2 se2) = Shape (sv1 VS.++ sv2) (se1 VS.++ se2)
 instance Monoid Shape where
-    mempty = Shape [] []
+    mempty = Shape mempty mempty
+
+{-# INLINE shVList #-}
+shVList = DL.toList . _shVertices
+{-# INLINE shEList #-}
+shEList = DL.toList . _shEdges
+
+{-# INLINE shVfromList #-}
+shVfromList = DL.fromList
+{-# INLINE shEfromList #-}
+shEfromList = DL.fromList
 
 -- edges are given by four consecutive points
 data ShapeV = ShapeV