From 1e198b551e948dfe202bc597af9611a6277ea623 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 1 Mar 2021 13:46:28 +0100 Subject: [PATCH] Do layer checking in picture tree --- app/Main.hs | 2 +- src/Picture.hs | 28 +++++++++++++----------- src/Picture/Data.hs | 12 +++++++++++ src/Picture/Render.hs | 50 +++++++++++++++++++++++-------------------- 4 files changed, 55 insertions(+), 37 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 3b274a2fc..38ce114e1 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -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) diff --git a/src/Picture.hs b/src/Picture.hs index 567d66eea..0f6cca80e 100644 --- a/src/Picture.hs +++ b/src/Picture.hs @@ -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 diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index fa087f85f..e8e9ad98c 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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 diff --git a/src/Picture/Render.hs b/src/Picture/Render.hs index 66e6f6b1a..8cc213cbb 100644 --- a/src/Picture/Render.hs +++ b/src/Picture/Render.hs @@ -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