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

Do layer checking in picture tree

Browse Source
This commit is contained in:
jgk
2021-03-01 13:46:28 +01:00
parent f68b8be9ce
commit 1e198b551e
4 changed files with 55 additions and 37 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+1 -1
View File
@@ -65,7 +65,7 @@ main = do
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
(_windowX w,_windowY w)
(picToLTree 1 $ fixedCoordPictures w)
(picToLTree (Just 1) $ fixedCoordPictures w)
endRenderTicks <- SDL.ticks
playSoundQueue (_soundData preData) (_soundQueue w)
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
src/Picture.hs
+15 -13
View File
@@ -103,19 +103,21 @@ setDepth :: Float -> Picture -> Picture
setDepth d pic = OverPic (\(x,y,_) -> (x,y,-d)) id id pic
setLayer :: Int -> Picture -> Picture
setLayer _ Blank = Blank
setLayer i (Polygon _ ps) = Polygon i ps
setLayer i (PolygonCol _ ps) = PolygonCol i ps
setLayer i (Circle _ x) = Circle i x
setLayer i (ThickArc _ a b r w) = ThickArc i a b r w
setLayer i (Line _ x) = Line i x
setLayer i (Scale x y p) = Scale x y $ setLayer i p
setLayer i (Translate x y p) = Translate x y $ setLayer i p
setLayer i (Rotate x p) = Rotate x $ setLayer i p
setLayer i (SetDepth x p) = SetDepth x $ setLayer i p
setLayer i (Color x p) = Color x $ setLayer i p
setLayer i (Pictures p) = Pictures $ map (setLayer i) p
setLayer i (OverPic f f' f'' pic) = OverPic f f' f'' (setLayer i pic)
{-# INLINE setLayer #-}
setLayer i pic = OnLayer i pic
--setLayer _ Blank = Blank
--setLayer i (Polygon _ ps) = Polygon i ps
--setLayer i (PolygonCol _ ps) = PolygonCol i ps
--setLayer i (Circle _ x) = Circle i x
--setLayer i (ThickArc _ a b r w) = ThickArc i a b r w
--setLayer i (Line _ x) = Line i x
--setLayer i (Scale x y p) = Scale x y $ setLayer i p
--setLayer i (Translate x y p) = Translate x y $ setLayer i p
--setLayer i (Rotate x p) = Rotate x $ setLayer i p
--setLayer i (SetDepth x p) = SetDepth x $ setLayer i p
--setLayer i (Color x p) = Color x $ setLayer i p
--setLayer i (Pictures p) = Pictures $ map (setLayer i) p
--setLayer i (OverPic f f' f'' pic) = OverPic f f' f'' (setLayer i pic)
scale3 :: Float -> Float -> Point3 -> Point3
src/Picture/Data.hs
+12
View File
@@ -36,6 +36,17 @@ instance Functor LTree where
fmap f (LBranches ts) = LBranches $ (fmap (fmap f)) ts
fmap f (LLeaf x) = LLeaf (f x)
data RTree a b
= RBranches a [RTree a b]
| RLeaf b
instance Foldable (RTree a) where
foldMap g (RBranches _ ts) = mconcat $ map (foldMap g) ts
foldMap g (RLeaf x) = g x
{-# INLINE foldMap #-}
instance Functor (RTree a) where
fmap f (RBranches i ts) = RBranches i $ (fmap (fmap f)) ts
fmap f (RLeaf x) = RLeaf (f x)
flat2 (x,y) = [x,y]
flat3 (x,y,z) = [x,y,z]
@@ -67,6 +78,7 @@ data Picture
| Color RGBA Picture
| Pictures [Picture]
| OverPic (Point3 -> Point3) (Float -> Float) (Point4 -> Point4) Picture
| OnLayer Int Picture
blank :: Picture
src/Picture/Render.hs
+27 -23
View File
@@ -207,29 +207,30 @@ collapseBranch f (FBranch g t) = FBranch (f . g) t
collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
collapseBranch f (FLeaf x) = FLeaf (f x)
picToLTree :: Int -> Picture -> LTree RenderType
picToLTree :: Maybe Int -> Picture -> LTree RenderType
{-# INLINE picToLTree #-}
picToLTree x (Polygon i ps)
| i == x = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| otherwise = LLeaf RenderBlank
picToLTree x (PolygonCol i vs)
| i /= x = LLeaf RenderBlank
| otherwise =
picToLTree mx (Polygon i ps)
| Just i == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| Nothing == mx = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
| otherwise = LBranches []
picToLTree mx (PolygonCol i vs)
| Just i == mx || Nothing == mx =
let (ps,cs) = unzip vs
in LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
picToLTree x (Circle i r)
| i == x = LLeaf $ RenderCirc $ ((0,0,0),black,r)
| otherwise = LLeaf RenderBlank
picToLTree x (ThickArc i startA endA rad wdth)
| i == x = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
| otherwise = LLeaf RenderBlank
picToLTree x (Line i ps)
| i == x = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
| otherwise = LLeaf RenderBlank
picToLTree x (Text i s)
| i == x = LLeaf $ RenderText $ stringToList s
| otherwise = LLeaf RenderBlank
picToLTree j Blank = LLeaf RenderBlank
| otherwise = LBranches []
picToLTree mx (Circle i r)
| Just i == mx || Nothing == mx = LLeaf $ RenderCirc $ ((0,0,0),black,r)
| otherwise = LBranches []
picToLTree mx (ThickArc i startA endA rad wdth)
| Just i == mx || Nothing == mx = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
| otherwise = LBranches []
picToLTree mx (Line i ps)
| Just i == mx || Nothing == mx = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
| otherwise = LBranches []
picToLTree mx (Text i s)
| Just i == mx || Nothing == mx = LLeaf $ RenderText $ stringToList s
| otherwise = LBranches []
picToLTree j Blank = LBranches []
picToLTree j (Scale x y pic) = fmap (scaleRen x y) $ picToLTree j pic
picToLTree j (Translate x y pic) = fmap (translateRen x y) $ picToLTree j pic
picToLTree j (Rotate a pic) = fmap (rotateRen a) $ picToLTree j pic
@@ -239,6 +240,9 @@ picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
picToLTree j (OverPic f f' f'' (OverPic g g' g'' pic)) = picToLTree j $ OverPic (f . g) (f' . g') (f'' . g'') pic
picToLTree j (OverPic f f' f'' (Pictures ps)) = LBranches (map (picToLTree j . OverPic f f' f'') ps)
picToLTree j (OverPic f f' f'' pic) = fmap (overPos f . overSca f' . overCol f'') $ picToLTree j pic
picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
| otherwise = LBranches []
picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic
doubleLine :: [Point2] -> [Point2]
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
@@ -464,15 +468,15 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
clear [DepthBuffer]
-- draw layer 0
ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 0 pic
ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 0) pic
--((picToAlt 0 pic) :: [RenderType])
-- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 1 pic
ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 1) pic
-- set drawing for on top
aticks <- SDL.ticks
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 2 pic
ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
bticks <- SDL.ticks
-- reset uniforms (hacky for now)
idmat <- (newMatrix RowMajor [1,0,0,0