From 80aa67015c5073fba067a57b1845e00e38c071e7 Mon Sep 17 00:00:00 2001 From: justin Date: Sat, 18 Sep 2021 15:38:46 +0100 Subject: [PATCH] Performance tweaks --- bench/Bench.hs | 19 ++++-- src/Dodge/Creature/Picture.hs | 83 +++++++++++------------ src/Dodge/Item/Draw.hs | 6 +- src/Dodge/Render.hs | 11 ++-- src/Dodge/Render/Shape.hs | 2 +- src/Geometry/Vector.hs | 4 +- src/Geometry/Vector3D.hs | 26 ++++---- src/Shader/Poke.hs | 121 ++++++++++++++++------------------ src/Shape.hs | 60 ++++++++++++----- src/Shape/Data.hs | 22 +++++-- 10 files changed, 194 insertions(+), 160 deletions(-) diff --git a/bench/Bench.hs b/bench/Bench.hs index 63103383c..fcf0709d7 100644 --- a/bench/Bench.hs +++ b/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 ] ] diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index de956f3b2..75089e95e 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/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 diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index 6c46dd257..9d34201f2 100644 --- a/src/Dodge/Item/Draw.hs +++ b/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 diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 1c0ae7c57..f05c97986 100644 --- a/src/Dodge/Render.hs +++ b/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 diff --git a/src/Dodge/Render/Shape.hs b/src/Dodge/Render/Shape.hs index 1fcd920b0..7f0bc2a2b 100644 --- a/src/Dodge/Render/Shape.hs +++ b/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 diff --git a/src/Geometry/Vector.hs b/src/Geometry/Vector.hs index 7578d2d27..0dfb4c58d 100644 --- a/src/Geometry/Vector.hs +++ b/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 diff --git a/src/Geometry/Vector3D.hs b/src/Geometry/Vector3D.hs index a646b97b1..be5e0cc70 100644 --- a/src/Geometry/Vector3D.hs +++ b/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 (*.*.*) #-} diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index b8f6ebc7c..0026fd3f4 100644 --- a/src/Shader/Poke.hs +++ b/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 diff --git a/src/Shape.hs b/src/Shape.hs index 8c506bf36..04b27e4a7 100644 --- a/src/Shape.hs +++ b/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 #-} diff --git a/src/Shape/Data.hs b/src/Shape/Data.hs index 394165e8b..e729a0a38 100644 --- a/src/Shape/Data.hs +++ b/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