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

Improve speed of polygon rendering by folding tree type

Browse Source
This commit is contained in:
jgk
2021-02-17 16:54:46 +01:00
parent c7aa5f707e
commit 6f838ed1ef
10 changed files with 378 additions and 200 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+3 -2
View File
@@ -27,7 +27,7 @@ import System.Random
import qualified SDL as SDL
import qualified SDL.Mixer as Mix
import Graphics.Rendering.OpenGL hiding (color,scale)
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
--Mix.openAudio Mix.defaultAudio 256 >>
initWorld = initialWorld
@@ -37,7 +37,7 @@ initWorld = initialWorld
}
pps = [(0,0),(50,0),(0,25)]
ppt = [(0,0),(-50,0),(20,25)]
ppt = [(0,0),(-0.50,0),(0.20,0.25)]
main :: IO ()
main = do
@@ -50,6 +50,7 @@ main = do
(initializeWorld $ generateFromTree lev1 $ initWorld)
(-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade
\preData w -> --do render setparams w egFade
--renderPicture' preData (polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)])
renderPicture' preData (draw blank w)
-- renderPicture' preData
-- (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]
package.yaml
+1
View File
@@ -40,6 +40,7 @@ dependencies:
- vector
- dlist
- deepseq
- transformers
library:
source-dirs: src
src/Dodge/Critters.hs
+3 -3
View File
@@ -261,10 +261,10 @@ explosiveBarrel = basicCreature
equipOnTop :: (Creature -> Picture) -> Creature -> Drawing
--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
equipOnTop f cr = onLayer CrLayer (f cr) <> drawEquipment cr
equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr]
drawEquipment :: Creature -> Drawing
drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
where f (i,it) = case it ^? itEquipPict of
Just g -> g cr i
_ -> blank
@@ -388,7 +388,7 @@ sizeEnemy col cr
sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
basicCrPict :: Color -> Creature -> Drawing
basicCrPict col cr = onLayer CrLayer naked <> drawEquipment cr
basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
where naked | pdam > 200 = color red $ circleSolid $ _crRad cr
| pdam > 100 = color white $ circleSolid $ _crRad cr
| mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
src/Dodge/Rendering.hs
+54 -50
View File
@@ -78,72 +78,78 @@ draw'' b w-- | (Char 'm') `S.member` _keys w
drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
collectDrawings :: World -> Picture
collectDrawings w = screenShift (decPicts <> ppPicts <> itFloorPicts
<> crPicts
<> clPicts
<> buttonPicts <> ptPicts
<> ptPicts'
<> afterPtPicts'
<> wlPicts
<> wallShadows
<> smokeShadows
)
<> onLayer LabelLayer
(itLabels <> ppLabels <> btLabels)
<> hudDrawings w
<> onLayer MenuLayer menuScreen
collectDrawings w = pictures
[screenShift $
pictures $ concat
[ decPicts
, ppPicts
, itFloorPicts
, crPicts
, clPicts
, buttonPicts
, ptPicts
, ptPicts'
, afterPtPicts'
, wlPicts
, wallShadows
, smokeShadows
]
, onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels]
, hudDrawings w
, onLayer MenuLayer menuScreen
]
-- <> [onLayer GloomLayer $ theLighting w]
where
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
. uncurry translate ((0,0) -.- _cameraPos w)
zoom = _cameraZoom w
decPicts :: Picture
decPicts = mconcat $ IM.elems $ _decorations w
ptPicts = mconcat $ map _ptPict (IM.elems (_particles w))
ptPicts' = mconcat $ map _ptPict' $ _particles' w
afterPtPicts' = mconcat $ map _ptPict' $ _afterParticles' w
buttonPicts = mconcat $ map btDraw (IM.elems (_buttons w))
ppPicts = mconcat $ map ppDraw (IM.elems (_pressPlates w))
crPicts :: Picture
crPicts = mconcat $ map crDraw $ IM.elems $ _creatures w
clPicts = mconcat $ map clDraw $ IM.elems $ _clouds w
wallShadows = mconcat $ map (drawWallShadow w) $ wallShadowsToDraw w
smokeShadows = mconcat $ map (drawSmokeShadow w) $ _smoke w
wlPicts = mconcat $ map drawWall (wallsToDraw w)
decPicts = IM.elems $ _decorations w
ptPicts = map _ptPict (IM.elems (_particles w))
ptPicts' = map _ptPict' $ _particles' w
afterPtPicts' = map _ptPict' $ _afterParticles' w
buttonPicts = map btDraw (IM.elems (_buttons w))
ppPicts = map ppDraw (IM.elems (_pressPlates w))
crPicts = map crDraw $ IM.elems $ _creatures w
clPicts = map clDraw $ IM.elems $ _clouds w
wallShadows = map (drawWallShadow w) $ wallShadowsToDraw w
smokeShadows = map (drawSmokeShadow w) $ _smoke w
wlPicts = map drawWall (wallsToDraw w)
itFloorPicts = map (drawItem) (IM.elems (_floorItems w))
yourPos = _crPos $ you w
yourRot = _crDir $ you w
yourRad = _crRad $ you w
-- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
-- (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
itFloorPicts = mconcat $ map (drawItem) (IM.elems (_floorItems w))
itLabels = mconcat $ map (drawItemName w) (IM.elems (_floorItems w))
ppLabels = mconcat $ map (drawPPText w) (IM.elems (_pressPlates w))
btLabels = mconcat $ map (drawButText w) (IM.elems (_buttons w))
itLabels = pictures $ map (drawItemName w) (IM.elems (_floorItems w))
ppLabels = pictures $ map (drawPPText w) (IM.elems (_pressPlates w))
btLabels = pictures $ map (drawButText w) (IM.elems (_buttons w))
menuScreen :: Picture
menuScreen = case _menuState w of
InGame -> blank
LevelMenu x ->
mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 ("LEVEL "++show x)
] <> controlsList
PauseMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
,controlsList
]
PauseMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 "PAUSED"
,tst (-100) 50 0.2 "n - new level"
,tst (-100) 0 0.2 "r - restart"
] <> controlsList
GameOverMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
, controlsList
]
GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
,tst (-100) 100 0.4 "GAME OVER"
,tst (-100) 50 0.2 "n - new level"
,tst (-100) 0 0.2 "r - restart"
]
<> controlsList
,controlsList
]
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
hudDrawings :: World -> Picture
hudDrawings w = (onLayer InvLayer)
$ displayInv 0 w
<> mconcat
[ dShadCol white $ displayHP 0 w
$ pictures
[ displayInv 0 w
, dShadCol white $ displayHP 0 w
, dShadCol (itCol (yourItem w))
$ drawCursor w, translate (-390) 20
$ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
@@ -169,7 +175,7 @@ drawCursor w = translate (105-halfWidth w)
where iPos = _crInvSel $ _creatures w IM.! _yourID w
controlsList = mconcat [tst (-250) (-130) 0.15 "controls:"
controlsList = pictures [tst (-250) (-130) 0.15 "controls:"
,tst (-150) (-130) 0.15 "wasd"
,tst 0 (-130) 0.15 "movement"
,tst (-150) (-160) 0.15 "[rmb]"
@@ -215,20 +221,18 @@ wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
wallsOnScreen :: World -> IM.IntMap Wall
wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
drawSmokeShadow :: World -> Smoke -> Drawing
drawSmokeShadow :: World -> Smoke -> Picture
drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t})
= (
onLayerL [74,0] $ color col $
= pictures
[ onLayerL [74,0] $ color col $
pictures [uncurry translate p $ circle r'
,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm
,line [_cameraPos w, mouseWorldPos w]
,trap' p
]
)
<>
(onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
, onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
$ concatMap (f . (+.+ p)) p's
)
]
where
r = r'/2
col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red
@@ -363,7 +367,7 @@ linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n
p'' = (1/fromIntegral n) *.* (p' -.- p)
displayInv :: Int -> World -> Picture
displayInv n w = mconcat $ zipWith (translate (10-halfWidth w))
displayInv n w = pictures $ zipWith (translate (10-halfWidth w))
(map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
src/Dodge/Weapons.hs
+7 -5
View File
@@ -1018,7 +1018,7 @@ moveFlame rotd w pt =
damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming (div time 10) sp p ep)
hiteff = _btHitEffect' pt pt
thepic p' = pic p' <> piu p' <> pi2 p' <> glow p'
thepic p' = pictures [ pic p' , piu p' , pi2 p' , glow p' ]
pic p' = onLayerL [levLayer UPtLayer,6] $ uncurry translate (prot3 p')
$ rotate (90 + (negate $ radToDeg $ argV rotd))
$ scale scaleChange 1
@@ -2055,10 +2055,12 @@ moveTeslaArc p d i w =
$ set randGen g
$ createSpark 8 nc q2 (argV sv + d1) Nothing
$ foldr damCrs w hitCrs
where pic = (onLayer PtLayer $ color (f2 nc) $ line ps')
<> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps')
<> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps')
<> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps')
where pic = pictures
[ onLayer PtLayer $ color (f2 nc) $ line ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
]
ps' = lightningMids d pers ps
ps = take 15 $ p : map f (crsLightChain p d 0 w)
f (E3x1 cr) = _crPos cr
src/Dodge/WorldActions.hs
+8 -6
View File
@@ -403,7 +403,7 @@ flareRad rad rays col ax ay p
flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
flashRadAt rad col alphax (x,y) =
Particle'
{ _ptPict' = mconcat $
{ _ptPict' = pictures $
map (\i -> onLayerL [levLayer PtLayer]
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
)
@@ -414,7 +414,7 @@ flashRadAt rad col alphax (x,y) =
flashColAt :: Color -> Float -> Point2 -> Particle'
flashColAt col alphax (x,y) =
Particle'
{ _ptPict' = mconcat $
{ _ptPict' = pictures $
map (\i -> onLayerL [levLayer PtLayer]
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
)
@@ -500,7 +500,7 @@ muzFlareAt p = over particles' ((:) (muzzleFlareAt p))
muzzleFlareAt :: Point2 -> Particle'
muzzleFlareAt (x,y) =
Particle'
{ _ptPict' = mconcat
{ _ptPict' = pictures
$ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i
)
[20,25,30,35,40,45,50]
@@ -748,7 +748,7 @@ moveFlamelet levelInt rot w pt =
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
s2 = 0.5 * (sc + s1)
thepicture = pic <> piu <> pi2 <> glow
thepicture = pictures [pic , piu , pi2 , glow]
pi2 = onLayerL [levelInt,2] $ uncurry translate ep
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
orange (dark red)
@@ -839,14 +839,16 @@ moveSmoke'' scal time p vel w pt
pic = onLayerL [levLayer PtLayer - 1]
$ uncurry translate pNew
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
pi1 = (onLayerL [levLayer PtLayer]
pi1 = pictures
[(onLayerL [levLayer PtLayer]
$ uncurry translate pNew
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
$ circleSolid $ 21 * scal)
<> (onLayerL [levLayer BgLayer+1]
, (onLayerL [levLayer BgLayer+1]
$ uncurry translate pNew
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
$ circleSolid $ 21 * scal)
]
makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w
src/Geometry.hs
+1
View File
@@ -13,6 +13,7 @@ import Data.Maybe
import Control.Applicative
zeroZ :: Point2 -> Point3
{-# INLINE zeroZ #-}
zeroZ (x,y) = (x,y,0)
infixl 6 +.+, -.-
src/Picture.hs
+94 -57
View File
@@ -16,7 +16,6 @@ module Picture
, rotate
, rotateRad
, scale
, blank
, color
, withAlpha
, greyN
@@ -51,41 +50,48 @@ import Picture.Data
import Data.Bifunctor
import qualified Data.DList as DL
import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..))
import Graphics.Rendering.OpenGL (lineWidth, ($=))
import Control.Lens
black :: RGBA
black = (0,0,0,1)
polygonD :: Float -> [Point2] -> Picture
{-# INLINE polygonD #-}
polygonD d (a:b:c:ps) = blank
{ _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
, _scColTri = mapVC (const black) tris
}
where twoPs = zip (b:c:ps) (c:ps)
tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
polygonD _ _ = blank
--polygonD :: Float -> [Point2] -> Picture
--{-# INLINE polygonD #-}
--polygonD d (a:b:c:ps) = blank
-- { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
-- , _scColTri = mapVC (const black) tris
-- }
-- where twoPs = zip (b:c:ps) (c:ps)
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
--polygonD _ _ = blank
polygon :: [Point2] -> Picture
{-# INLINE polygon #-}
polygon (a:b:c:ps) = blank
{ _scPosTri = fmap zeroZ tris
, _scColTri = fmap (const black) tris
}
where twoPs = zip (b:c:ps) (c:ps)
tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
polygon _ = blank
polygon = Polygon
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
--polygon :: [Point2] -> Picture
--{-# INLINE polygon #-}
--polygon (a:b:c:ps) = NLeaf $ emptyScene
-- { _scPosTri = fmap zeroZ tris
-- , _scColTri = fmap (const black) tris
-- }
-- where twoPs = zip (b:c:ps) (c:ps)
-- tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
--polygon _ = blank
color' :: RGBA -> Scene -> Scene
{-# INLINE color' #-}
color' c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
pic {_scColTri = mapVC (const c) colTri
,_scColChar = mapVC (const c) colChar
}
color :: RGBA -> Picture -> Picture
{-# INLINE color #-}
color c pic = Color c pic
overPos :: (Point3 -> Point3) -> Picture -> Picture
overPos :: (Point3 -> Point3) -> Scene -> Scene
{-# INLINE overPos #-}
overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
pic {_scPosTri = mapVC f posTri
@@ -96,56 +102,77 @@ translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
translate' :: Float -> Float -> Scene -> Scene
{-# INLINE translate' #-}
--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
translate' x y = overPos $ translate3 x y
translate :: Float -> Float -> Picture -> Picture
{-# INLINE translate #-}
--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
translate x y = overPos $ translate3 x y
translate x y pic = Translate x y pic
setDepth' :: Float -> Scene -> Scene
{-# INLINE setDepth' #-}
setDepth' d = overPos $ \(x,y,z) -> (x,y,d)
setDepth :: Float -> Picture -> Picture
--setDepth d = over scPosTri (mapVC $ (\(x,y,z)->(x,y,d)))
-- . over scPosChar (mapVC $ (\(x,y,z)->(x,y,d)))
setDepth d = overPos $ \(x,y,z) -> (x,y,d)
{-# INLINE setDepth #-}
setDepth d pic = SetDepth d pic
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
scale' :: Float -> Float -> Scene -> Scene
{-# INLINE scale' #-}
--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
scale' x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
scale :: Float -> Float -> Picture -> Picture
{-# INLINE scale #-}
--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
scale x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
scale x y pic = Scale x y pic
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
rotate :: Float -> Picture -> Picture
{-# INLINE rotate #-}
--rotate a = over scPosTri (mapVC $ rotate3 (0 - degToRad a))
-- . over scPosChar (mapVC $ rotate3 (0 - degToRad a))
rotate a = overPos $ rotate3 $ 0 - degToRad a
rotate' :: Float -> Scene -> Scene
{-# INLINE rotate' #-}
rotate' a = overPos $ rotate3 $ 0 - degToRad a
-- -- this rotation uses radians, and is anticlockwise
rotateRad :: Float -> Picture -> Picture
--rotate :: Float -> Picture -> Picture
--{-# INLINE rotate #-}
--rotate a pic = NBranch (rotate' a) pic
--
---- -- this rotation uses radians, and is anticlockwise
--rotateRad' :: Float -> Scene -> Scene
--{-# INLINE rotateRad' #-}
--rotateRad' a = overPos $ rotate3 a
--
--rotateRad :: Float -> Picture -> Picture
--{-# INLINE rotateRad #-}
--rotateRad a pic = NBranch (rotateRad' a) pic
rotate a = rotateRad (0 - degToRad a)
{-# INLINE rotate #-}
rotateRad a = Rotate a
{-# INLINE rotateRad #-}
--rotateRad a = over scPosTri (mapVC $ rotate3 a)
-- . over scPosChar (mapVC $ rotate3 a)
rotateRad a = overPos $ rotate3 a
pictures :: [Picture] -> Picture
{-# INLINE pictures #-}
pictures = mconcat
pictures = Pictures
makeArc :: Float -> (Float,Float) -> [Point2]
{-# INLINE makeArc #-}
makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
where as = [a,a+step.. b]
step = pi * 0.1
step = pi * 0.2
circleSolidD :: Float -> Float -> Picture
circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
--circleSolidD :: Float -> Float -> Picture
--circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
circleSolid :: Float -> Picture
{-# INLINE circleSolid #-}
@@ -162,21 +189,25 @@ circle rad = line $ makeArc rad (0,2*pi)
text :: String -> Picture
{-# INLINE text #-}
text s = mconcat $ zipWith (\x -> translate x (0-dimText))
[0,0.9*dimText..]
(map charToScene s)
text = Text
charToScene :: Char -> Picture
charToScene c = Scene
{_scPosTri = mempty
,_scColTri = mempty
,_scPosChar = toVC [(0.0,0.0,0)]
,_scColChar = toVC [white]
,_scTexChar = toVC [(offset,100)]
}
where x = 1/128
s = offset * x
offset = fromIntegral (fromEnum c) - 32
----text :: String -> Picture
----{-# INLINE text #-}
----text s = pictures $ zipWith (\x -> translate x (0-dimText))
---- [0,0.9*dimText..]
---- (map charToScene s)
----
----charToScene :: Char -> Picture
----charToScene c = NLeaf $ Scene
---- {_scPosTri = mempty
---- ,_scColTri = mempty
---- ,_scPosChar = toVC [(0.0,0.0,0)]
---- ,_scColChar = toVC [white]
---- ,_scTexChar = toVC [(offset,100)]
---- }
---- where x = 1/128
---- s = offset * x
---- offset = fromIntegral (fromEnum c) - 32
--charToScene :: Char -> Picture
--charToScene c = Scene
-- {_scPosTri = mempty
@@ -265,3 +296,9 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
greyN :: Float -> Color
greyN x = (x,x,x,1)
--zeroZ :: Point2 -> Point3
--{-# INLINE zeroZ #-}
--zeroZ (x,y) = (x,y,0)
src/Picture/Data.hs
+68 -41
View File
@@ -15,34 +15,33 @@ type RGBA = (Float,Float,Float,Float)
type Color = (Float,Float,Float,Float)
type VerticesContainer a = Se.Seq a
toVC = Se.fromList
fromVC :: VerticesContainer a -> [a]
fromVC = F.toList
--type VerticesContainer a = Se.Seq a
--toVC = Se.fromList
--fromVC :: VerticesContainer a -> [a]
--fromVC = F.toList
--type VerticesContainer a = DL.DList a
--toVC = DL.fromList
--fromVC = DL.toList
--type VerticesContainer a = [a]
--toVC = id
--fromVC = id
type VerticesContainer a = [a]
toVC = id
fromVC = id
{-# INLINE toVC #-}
{-# INLINE fromVC #-}
{-# INLINE mapVC #-}
mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
mapVC = fmap
data NTree a b
= NBranch a [NTree a b]
| NLeaf b
data FTree a
= FBranch (a -> a) (FTree a)
| FBranches [FTree a]
| FLeaf a
reduceNTree :: NTree (a -> a) a -> NTree () a
reduceNTree = reduceNTree' id
where
reduceNTree' :: (b -> b) -> NTree (b -> b) b -> NTree () b
reduceNTree' f (NBranch g xs) = NBranch () $ map (reduceNTree' (f . g)) xs
reduceNTree' f (NLeaf x) = NLeaf $ f x
concatLeaves :: NTree a b -> DL.DList b
concatLeaves (NLeaf x) = DL.singleton x
concatLeaves (NBranch _ xs) = mconcat (map concatLeaves xs)
instance Foldable FTree where
foldMap g (FBranch f t) = foldMap (g . f) t
foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts
foldMap g (FLeaf x) = g x
{-# INLINE foldMap #-}
--reduceShapeTree :: (Shape -> Shape) -> ShapeTree -> [Shape]
--reduceShapeTree
@@ -50,27 +49,51 @@ concatLeaves (NBranch _ xs) = mconcat (map concatLeaves xs)
--reduceShapeTree
-- (Leaf s) = [s]
data ShapeTree
= TransformShape (Shape -> Shape) [ShapeTree]
| Leaf Shape
data Shape
= Shape
{ _shPos :: VerticesContainer Point3
, _shCol :: VerticesContainer RGBA
}
| TextShape
{ _shPos :: VerticesContainer Point3
, _shCol :: VerticesContainer RGBA
, _shTex :: VerticesContainer Point2
}
-- data ShapeTree
-- = TransformShape (Shape -> Shape) [ShapeTree]
-- | Leaf Shape
--
-- data Shape
-- = Shape
-- { _shPos :: VerticesContainer Point3
-- , _shCol :: VerticesContainer RGBA
-- }
-- | TextShape
-- { _shPos :: VerticesContainer Point3
-- , _shCol :: VerticesContainer RGBA
-- , _shTex :: VerticesContainer Point2
-- }
--
--combineShapes :: Shape -> Shape -> Shape
--combineShapes sa sb = Shape
-- { _shPos = _shPos sa <> _shPos sb
-- , _shCol = _shCol sa <> _shCol sb
-- }
data Picture = Scene
flat2 (x,y) = [x,y]
flat3 (x,y,z) = [x,y,z]
flat4 (x,y,z,w) = [x,y,z,w]
{-# INLINE flat2 #-}
{-# INLINE flat3 #-}
{-# INLINE flat4 #-}
data RenderType
= RenderPoly [(Point3,Point4)]
| RenderText [(Point3,Point4,Point2)]
| RenderBlank
data Picture
= Blank
| Text String
| Polygon [Point2]
| Scale Float Float Picture
| Translate Float Float Picture
| Rotate Float Picture
| SetDepth Float Picture
| Color RGBA Picture
| Pictures [Picture]
data Scene = Scene
{ _scPosTri :: VerticesContainer Point3
, _scColTri :: VerticesContainer RGBA
, _scPosChar :: VerticesContainer Point3
@@ -78,11 +101,15 @@ data Picture = Scene
, _scTexChar :: VerticesContainer Point2
}
emptyScene :: Scene
{-# INLINE emptyScene #-}
emptyScene = Scene mempty mempty mempty mempty mempty
blank :: Picture
{-# INLINE blank #-}
blank = Scene mempty mempty mempty mempty mempty
blank = Blank
combineScenes :: Picture -> Picture -> Picture
combineScenes :: Scene -> Scene -> Scene
{-# INLINE combineScenes #-}
combineScenes sa sb = Scene
{ _scPosTri = _scPosTri sa <> _scPosTri sb
@@ -92,10 +119,10 @@ combineScenes sa sb = Scene
, _scTexChar = _scTexChar sa <> _scTexChar sb
}
instance Semigroup Picture where
instance Semigroup Scene where
(<>) = combineScenes
instance Monoid Picture where
mempty = blank
instance Monoid Scene where
mempty = emptyScene
--mappend = combineScenes
makeLenses ''Picture
makeLenses ''Scene
src/Picture/Render.hs
+139 -36
View File
@@ -1,7 +1,13 @@
--{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
where
import Control.Lens
import Control.Monad
import Control.Monad.Trans.State
import Data.Bifunctor
import Picture
import Geometry
@@ -12,10 +18,11 @@ import Foreign
import Codec.Picture
import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth)
import Graphics.Rendering.OpenGL hiding (get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
import qualified Graphics.Rendering.OpenGL as GL
import Data.Foldable
import Data.List
import qualified Data.Vector.Storable as V
import qualified Data.DList as DL
@@ -29,61 +36,157 @@ toVec2 (x,y) = Vector2 x y
toVec3 (x,y,z) = Vector3 x y z
toVec4 (x,y,z,w) = Vector4 x y z w
flat2 (x,y) = toVC [x,y]
flat3 (x,y,z) = toVC [x,y,z]
flat4 (x,y,z,w) = toVC [x,y,z,w]
mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
mapFlat f = fromVC . foldMap f
--marshallVs = V.unsafeWith . V.fromList
--marshallVs = withArray
polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-}
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
polyToTris _ = []
data Tx a = Tx [Tx a] | Lx a
deriving instance Foldable Tx
stateBump :: [Int] -> () -> State Int [Int]
stateBump xs _ = do
s <- get
modify (+1)
return (s:xs)
redT :: Foldable t => t () -> [Int]
redT x = evalState (foldM stateBump [] x) 0
picToFTree :: Picture -> FTree [(Point3,Point4)]
{-# INLINE picToFTree #-}
picToFTree (Polygon ps) = FLeaf $ zip (map zeroZ $ polyToTris ps) $ repeat black
picToFTree Blank = FLeaf $ []
picToFTree (Text _) = FLeaf $ []
picToFTree (Scale x y pic) = FBranch (map $ first $ scale3 x y) $ picToFTree pic
picToFTree (Translate x y pic) = FBranch (map $ first $ translate3 x y) $ picToFTree pic
picToFTree (Rotate a pic) = FBranch (map $ first $ rotate3 a) $ picToFTree pic
picToFTree (SetDepth a pic) = FBranch (map $ first $ (\(x,y,_) -> (x,y,a))) $ picToFTree pic
picToFTree (Color c pic) = FBranch (map $ second $ const c) $ picToFTree pic
picToFTree (Pictures pics) = FBranches $ map picToFTree pics
pokePic :: Ptr Float -> Ptr Float -> FTree [(Point3,Point4)] -> IO Int
pokePic = go 0
where go n pa pb t = foldM (pokePoly pa pb) n t
pokePoly :: Ptr Float -> Ptr Float -> Int -> [(Point3,Point4)] -> IO Int
pokePoly pa pb n vs = foldM (pokeVert pa pb) n vs
pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
pokeVert pa pb n ((x,y,z),(r,g,b,a))
| n > 20000 * 2 = return n
| otherwise = do
pokeElemOff pa (3*n+0) x
pokeElemOff pa (3*n+1) y
pokeElemOff pa (3*n+2) z
pokeElemOff pb (4*n+0) r
pokeElemOff pb (4*n+1) g
pokeElemOff pb (4*n+2) b
pokeElemOff pb (4*n+3) a
return (n+1)
reducePicture :: Picture -> (DL.DList Float,DL.DList Float)
{-# INLINE reducePicture #-}
reducePicture = reducePicture' black id
where
reducePicture' :: RGBA -> (Point3 -> Point3) -> Picture -> (DL.DList Float,DL.DList Float)
reducePicture' col tran Blank = (DL.empty,DL.empty)
reducePicture' col tran (Text _) = (DL.empty,DL.empty)
reducePicture' col tran (Polygon ps)
= ( DL.fromList $ concatMap (flat3 . tran . zeroZ) (polyToTris ps)
, DL.fromList $ concatMap (flat4 . const col) (polyToTris ps)
)
reducePicture' col tran (Scale x y pic)
= reducePicture' col (tran . scale3 x y) pic
reducePicture' col tran (Translate x y pic)
= reducePicture' col (tran . translate3 x y) pic
reducePicture' col tran (Rotate a pic)
= reducePicture' col (tran . rotate3 a) pic
reducePicture' col tran (SetDepth a pic)
= reducePicture' col (tran . \(x,y,z) -> (x,y,a)) pic
reducePicture' col tran (Color c pic)
= reducePicture' c tran pic
reducePicture' col tran (Pictures pics)
= foldr com (DL.empty,DL.empty) $ map (reducePicture' col tran) pics
where com (xs,ys) (xs',ys') = (xs <> xs', ys <> ys')
translate3 :: Float -> Float -> Point3 -> Point3
{-# INLINE translate3 #-}
translate3 a b (x,y,z) = (x+a,y+b,z)
scale3 :: Float -> Float -> Point3 -> Point3
{-# INLINE scale3 #-}
scale3 a b (x,y,z) = (x*a,y*b,z)
rotate3 :: Float -> Point3 -> Point3
{-# INLINE rotate3 #-}
rotate3 a (x,y,z) = (x',y',z)
where (x',y') = rotateV a (x,y)
renderPicture' :: PreloadData -> Picture -> IO ()
renderPicture' pdata (Scene posTri colTri posChar colChar texChar) = do
renderPicture' pdata pic = do
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_basicVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
let firstIndex = 0
let vertices :: [Float]
vertices = mapFlat flat3 posTri
numVertices = length posTri
vertexSize = sizeOf (head vertices)
pokeArray (_ptrPosVBO pdata) vertices
bufferData ArrayBuffer $= (fromIntegral (3 * numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
fSize = sizeOf (0::Float)
numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 3, _ptrPosVBO pdata, StreamDraw)
-- marshallVs vertices $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
let colVs = mapFlat flat4 colTri
colVsize = sizeOf $ head colVs
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw)
-- marshallVs colVs $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVert)
renderPicture :: PreloadData -> Picture -> IO ()
renderPicture pdata pic = do
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_basicVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
let firstIndex = 0
let (vs,cs) = reducePicture pic
vertices :: [Float]
vertices = DL.toList vs
numVertices = length vertices
vertexSize = sizeOf (head vertices)
pokeArray (_ptrPosVBO pdata) vertices
bufferData ArrayBuffer $= (fromIntegral (length vertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
-- marshallVs vertices $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
let colVs = DL.toList cs
pokeArray (_ptrColVBO pdata) colVs
bufferData ArrayBuffer $= (fromIntegral (4 * numVertices * colVsize), _ptrColVBO pdata, StreamDraw)
bufferData ArrayBuffer $= (fromIntegral (length colVs * vertexSize), _ptrColVBO pdata, StreamDraw)
-- marshallVs colVs $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
currentProgram $= Just (_textShader pdata)
bindVertexArrayObject $= Just (_textVAO pdata)
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
let vertices' = mapFlat flat3 posChar
numVertices' = length posChar
vertexSize' = sizeOf $ head vertices'
pokeArray (_ptrPosVBO pdata) vertices'
bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
--withArray vertices' $ \ptr -> do
-- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
pokeArray (_ptrColVBO pdata) $ mapFlat flat4 colChar
bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
pokeArray (_ptrTexVBO pdata) $ mapFlat flat2 texChar
bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
---- currentProgram $= Just (_textShader pdata)
---- bindVertexArrayObject $= Just (_textVAO pdata)
---- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
---- let vertices' = concatMap flat3 posChar
---- numVertices' = length posChar
---- vertexSize' = sizeOf $ head vertices'
---- pokeArray (_ptrPosVBO pdata) vertices'
---- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
---- --withArray vertices' $ \ptr -> do
---- -- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
---- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
---- pokeArray (_ptrColVBO pdata) $ concatMap flat4 colChar
---- bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
---- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
---- pokeArray (_ptrTexVBO pdata) $ concatMap flat2 texChar
---- bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
---- drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
zeroZ :: Point2 -> Point3
zeroZ (x,y) = (x,y,0)