From 6f838ed1ef8f185570f277f7896811a5e27e23d4 Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 17 Feb 2021 16:54:46 +0100 Subject: [PATCH] Improve speed of polygon rendering by folding tree type --- app/Main.hs | 5 +- package.yaml | 1 + src/Dodge/Critters.hs | 6 +- src/Dodge/Rendering.hs | 104 +++++++++++----------- src/Dodge/Weapons.hs | 12 +-- src/Dodge/WorldActions.hs | 14 +-- src/Geometry.hs | 1 + src/Picture.hs | 151 +++++++++++++++++++------------- src/Picture/Data.hs | 109 +++++++++++++++--------- src/Picture/Render.hs | 175 ++++++++++++++++++++++++++++++-------- 10 files changed, 378 insertions(+), 200 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 68fc8f429..61c8d3a85 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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)] diff --git a/package.yaml b/package.yaml index ba1ad85e9..fda169021 100644 --- a/package.yaml +++ b/package.yaml @@ -40,6 +40,7 @@ dependencies: - vector - dlist - deepseq +- transformers library: source-dirs: src diff --git a/src/Dodge/Critters.hs b/src/Dodge/Critters.hs index f5565edb5..614c83a5c 100644 --- a/src/Dodge/Critters.hs +++ b/src/Dodge/Critters.hs @@ -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 diff --git a/src/Dodge/Rendering.hs b/src/Dodge/Rendering.hs index 785be9ede..c5bd6d1cd 100644 --- a/src/Dodge/Rendering.hs +++ b/src/Dodge/Rendering.hs @@ -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 diff --git a/src/Dodge/Weapons.hs b/src/Dodge/Weapons.hs index 746f037a6..faead2d37 100644 --- a/src/Dodge/Weapons.hs +++ b/src/Dodge/Weapons.hs @@ -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 diff --git a/src/Dodge/WorldActions.hs b/src/Dodge/WorldActions.hs index 17907fe8d..7ad2145f1 100644 --- a/src/Dodge/WorldActions.hs +++ b/src/Dodge/WorldActions.hs @@ -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 diff --git a/src/Geometry.hs b/src/Geometry.hs index 7bbfa5120..127e9e8ea 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -13,6 +13,7 @@ import Data.Maybe import Control.Applicative zeroZ :: Point2 -> Point3 +{-# INLINE zeroZ #-} zeroZ (x,y) = (x,y,0) infixl 6 +.+, -.- diff --git a/src/Picture.hs b/src/Picture.hs index df297666c..d320661c2 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -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) + diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 60bdd1f90..b010f253b 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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 diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index e710166a1..62f83633e 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -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)