From b580666c57e9b423807a61bc84caf6a3cb6a2a5b Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 9 Aug 2021 19:07:58 +0200 Subject: [PATCH] Move towards replacing F.foldM with streaming, using mutable accumulator --- src/Picture.hs | 16 ++++++++-------- src/Picture/Data.hs | 11 +++++++++++ src/Polyhedra.hs | 2 +- src/Shader.hs | 2 ++ src/Shader/Poke.hs | 42 +++++++++++++----------------------------- 5 files changed, 35 insertions(+), 38 deletions(-) diff --git a/src/Picture.hs b/src/Picture.hs index 80df03838..6856ab58e 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -73,19 +73,19 @@ polygon :: [Point2] -> Picture {-# INLINE polygon #-} polygon ps = map (f . zeroZ) $ polyToTris ps where - f pos = Verx pos black PolyV 0 + f pos = Verx pos black PolyV 0 polyNum polygonZ :: [Point2] -> Float -> Picture {-# INLINE polygonZ #-} polygonZ ps z = map (f . zeroZ) $ polyToTris ps where - f pos = Verx pos black (PolyzV z) 0 + f pos = Verx pos black (PolyzV z) 0 polyzNum polygonCol :: [(Point2,RGBA)] -> Picture {-# INLINE polygonCol #-} polygonCol vs = polyToTris $ map f vs where - f (V2 x y,col) = Verx (V3 x y 0) col PolyV 0 + f (V2 x y,col) = Verx (V3 x y 0) col PolyV 0 polyNum poly3 :: [Point3] -> Picture {-# INLINE poly3 #-} @@ -95,7 +95,7 @@ poly3Col :: [(Point3,RGBA)] -> Picture {-# INLINE poly3Col #-} poly3Col vs = map f $ polyToTris vs where - f (pos,col) = Verx pos col PolyV 0 + f (pos,col) = Verx pos col PolyV 0 polyNum -- note that much of work computing the width of the bezier curve is done here bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture @@ -134,7 +134,7 @@ bezierQuad cola colc ra rc a b c bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture bzhelp = map f where - f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0 + f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0 bezNum -- given a one and two zeros of a linear function over x and y, -- determine the function @@ -215,7 +215,7 @@ circleSolidCol colC colE r = map f ,( (V3 ( r) (-r) (0)), black) ] where - f (pos,col) = Verx pos col EllV 0 + f (pos,col) = Verx pos col EllV 0 ellNum circle :: Float -> Picture {-# INLINE circle #-} @@ -225,7 +225,7 @@ text :: String -> Picture {-# INLINE text #-} text s = map f $ stringToList s where - f (pos,col,val) = Verx pos col (TextV val) 0 + f (pos,col,val) = Verx pos col (TextV val) 0 textNum line :: [Point2] -> Picture {-# INLINE line #-} @@ -306,7 +306,7 @@ thickArcHelp startA endA rad wdth = map f (V2 xa ya) = rotateV startA (V2 rad 0) (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) (0)) (V2 xc yc) = rotateV endA (V2 rad 0) - f (pos,col,val) = Verx pos col (ArcV val) 0 + f (pos,col,val) = Verx pos col (ArcV val) 0 arcNum withAlpha :: Float -> RGBA -> RGBA {-# INLINE withAlpha #-} diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index ca0a469b0..457150ebd 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -22,6 +22,7 @@ data Verx = Verx , _vxCol :: !Point4 , _vxType :: !VertexType , _vxLayer :: !Int + , _vxShadNum :: !ShadNum } data VertexType = PolyV @@ -31,6 +32,16 @@ data VertexType | ArcV !Point3 | EllV +newtype ShadNum = ShadNum { _unShadNum :: Int } + +polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum +polyNum = ShadNum 0 +polyzNum = ShadNum 1 +bezNum = ShadNum 2 +textNum = ShadNum 3 +arcNum = ShadNum 4 +ellNum = ShadNum 5 + type RGBA = Point4 type Color = Point4 diff --git a/src/Polyhedra.hs b/src/Polyhedra.hs index 5b38d3ff4..a567889c5 100644 --- a/src/Polyhedra.hs +++ b/src/Polyhedra.hs @@ -88,7 +88,7 @@ polyToPics = map helpPoly3D . _pyFaces helpPoly3D :: [(Point3, Point4)] -> [Verx] helpPoly3D vs = map f $ polyToTris vs where - f (pos,col) = Verx pos col PolyV 0 + f (pos,col) = Verx pos col PolyV 0 polyNum polysToPic :: [Polyhedra] -> Picture polysToPic = pictures . concatMap polyToPics diff --git a/src/Shader.hs b/src/Shader.hs index 9013039c7..5ba477f86 100644 --- a/src/Shader.hs +++ b/src/Shader.hs @@ -23,6 +23,8 @@ import qualified Data.IntMap.Strict as IM --import Text.RawString.QQ --import Linear.Matrix --import Linear.V4 +--import qualified Data.Vector.Unboxed.Mutable as MV +--import Control.Monad.Primitive bindArrayBuffers :: Int -> VBO -> IO () bindArrayBuffers numVs theVBO = do diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs index 0a91f9068..ae5ebe0e9 100644 --- a/src/Shader/Poke.hs +++ b/src/Shader/Poke.hs @@ -27,7 +27,17 @@ import qualified Data.Vector.Unboxed.Mutable as MV import Control.Monad.Primitive pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int) -pokeVerxs vbos = F.foldM $ F.FoldM +pokeVerxs vbos vxs = do + count <- (MV.replicate 6 0 :: IO (MV.MVector (PrimState IO) Int)) + F.foldM (F.FoldM + (\_ vx -> pokeVerx vbos count vx >> addCountVerx count vx) + (return ()) + (const (vToPicShad count)) + ) + vxs + +pokeVerxs' :: PicShads VBO -> [Verx] -> IO (PicShads Int) +pokeVerxs' vbos = F.foldM $ F.FoldM (\count vx -> pokeVerx vbos count vx >> addCountVerx count vx >> return count) (MV.replicate 6 0) vToPicShad @@ -84,17 +94,10 @@ poke34 ptr (V3 a b c) (V4 d e f g) = do addCountVerx :: MV.MVector (PrimState IO) Int -> Verx -> IO () {-# INLINE addCountVerx #-} -addCountVerx v !Verx{_vxType=theType} = case theType of - PolyV -> MV.unsafeModify v (+ 1) 0 - PolyzV _ -> MV.unsafeModify v (+ 1) 1 - BezV _ -> MV.unsafeModify v (+ 1) 2 - TextV _ -> MV.unsafeModify v (+ 1) 3 - ArcV _ -> MV.unsafeModify v (+ 1) 4 - EllV -> MV.unsafeModify v (+ 1) 5 +addCountVerx vec vx = MV.unsafeModify vec (+1) (_unShadNum $ _vxShadNum vx) pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO () --{-# INLINE pokeArrayOff #-} ---pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..] pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i)) pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int @@ -134,7 +137,7 @@ comLayVerx vbos counts vx = do MV.unsafeModify counts (+ 1) vecPos return counts where - vecPos = theLayer * 6 + typeInt theType + vecPos = theLayer * 6 + _unShadNum (_vxShadNum vx) theLayer = _vxLayer vx theType = _vxType vx thePos = _vxPos vx @@ -154,25 +157,6 @@ pokeVerxType thePtr vt = case vt of >> pokeElemOff thePtr 9 z _ -> return () -typeInt :: VertexType -> Int -typeInt vt = case vt of - PolyV -> 0 - PolyzV{} -> 1 - BezV{} -> 2 - TextV{} -> 3 - ArcV{} -> 4 - EllV -> 5 - ---intFromType :: PicShads Int -> VertexType -> Int ---{-# INLINE intFromType #-} ---intFromType ps vt = case vt of --- PolyV -> _psPoly ps --- PolyzV{} -> _psPolyz ps --- BezV{} -> _psBez ps --- TextV{} -> _psText ps --- ArcV{} -> _psArc ps --- EllV -> _psEll ps - vboFromType :: PicShads VBO -> VertexType -> VBO {-# INLINE vboFromType #-} vboFromType ps vt = case vt of