justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Move towards replacing F.foldM with streaming, using mutable accumulator

Browse Source
This commit is contained in:
jgk
2021-08-09 19:07:58 +02:00
parent 8cda9b4e1b
commit b580666c57
5 changed files with 35 additions and 38 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Picture.hs
+8 -8
View File
@@ -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 #-}
src/Picture/Data.hs
+11
View File
@@ -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
src/Polyhedra.hs
+1 -1
View File
@@ -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
src/Shader.hs
+2
View File
@@ -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
src/Shader/Poke.hs
+13 -29
View File
@@ -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