diff --git a/data/texture/grayscaleDirt.png b/data/texture/grayscaleDirt.png index 729f30e6b..d74e0eb8e 100644 Binary files a/data/texture/grayscaleDirt.png and b/data/texture/grayscaleDirt.png differ diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index d10c9ecc3..f4d74419a 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -78,7 +78,7 @@ doDrawing pdata w = do if w ^. config . wall_textured then renderTextureWalls pdata nWalls else renderBlankWalls pdata nWalls - _ <- renderFoldable pdata $ picToLTree (Just 0) (polysToPic $ foregroundPics w) + _ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType]) _ <- renderFoldable pdata $ picToLTree (Just 0) pic _ <- renderShader (_textureArrayShader pdata) (_floorTiles w) diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index eb0dce546..340876347 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -4,8 +4,8 @@ module Picture.Data where import Geometry.Data ---import Data.Foldable - +import Data.Foldable +--import qualified Data.List as L --import Data.Monoid --import Data.Traversable --import qualified Data.Foldable as F @@ -54,6 +54,14 @@ instance Foldable LTree where foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts foldMap g (LLeaf a) = g a {-# INLINE foldMap #-} + foldr _ x (LBranches []) = x + foldr g x (LBranches (t:ts)) = foldr g (foldr g x (LBranches ts)) t + foldr g x (LLeaf y) = g y x + {-# INLINE foldr #-} + foldl' _ x (LBranches []) = x + foldl' g x (LBranches (t:ts)) = foldl' g x t `seq` foldl' g (foldl' g x t) (LBranches ts) + foldl' g x (LLeaf y) = g x y + {-# INLINE foldl' #-} instance Functor LTree where fmap f (LBranches ts) = LBranches $ fmap (fmap f) ts fmap f (LLeaf x) = LLeaf (f x) diff --git a/src/Picture/Tree.hs b/src/Picture/Tree.hs index 3699bc996..1a2d6ad30 100644 --- a/src/Picture/Tree.hs +++ b/src/Picture/Tree.hs @@ -1,6 +1,8 @@ {- Transform a picture into renderable objects. -} module Picture.Tree ( picToLTree + , picToRenderList + , picToAlt ) where import Picture.Data @@ -9,7 +11,7 @@ import Geometry.Data import Data.Bifunctor import Data.List ---import Control.Applicative +import Control.Applicative --import Data.Maybe (isNothing) -- todo: refactor out the layer check somehow @@ -65,47 +67,81 @@ picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic | otherwise = LBranches [] picToLTree Nothing (OnLayer _ pic) = picToLTree Nothing pic ---picToRenderType --- :: Picture --- -> RenderType ---{-# INLINE picToRenderType #-} ---picToRenderType (Polygon ps) --- = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black ---picToRenderType (PolygonZ ps z) --- = RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z) ---picToRenderType (PolygonCol vs) --- = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs --- where --- (ps,cs) = unzip vs ---picToRenderType (Poly3D vs) = RenderPoly $ polyToTris vs ---picToRenderType (BezierQuad vs) = RenderBezQ $ zip3 (map zeroZ ps) cols rs --- where --- (ps,cols,offps,rads) = unzip4 vs --- rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads ---picToRenderType (Circle colC colE r) = RenderEllipse --- [( (-r, r,0), colC) --- ,( (-r,-r,0), colE) --- ,( ( r,-r,0), black) --- ] ---picToRenderType (ThickArc startA endA rad wdth) = RenderArc --- [( (0,0,0),black,(0,0,wdth)) --- ,((xa,ya,0),black,(1,0,wdth)) --- ,((xb,yb,0),black,(1,1,wdth)) --- ,( (0,0,0),black,(0,0,wdth)) --- ,((xb,yb,0),black,(1,1,wdth)) --- ,((xc,yc,0),black,(0,1,wdth)) --- ] --- where --- (xa,ya) = rotateV startA (rad,0) --- (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0) --- (xc,yc) = rotateV endA (rad,0) ---picToRenderType (Line ps) --- = RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white ---picToRenderType (LineCol vs) --- = RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs --- where (ps,cs) = unzip vs ---picToRenderType _ = error "Tried to make a render type from a tree picture" ---picToRenderType (Text s) = RenderText $ stringToList s +-- might want to use the Alt newType +picToAlt + :: (Alternative t, Monoid (t RenderType)) + => Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf. + -> Picture + -> t RenderType +{-# INLINE picToAlt #-} +picToAlt _ Blank = empty +picToAlt j (Pictures pics) = foldMap (picToAlt j) pics +picToAlt j (OverPic f f' (OverPic g g' pic)) = picToAlt j $ OverPic (f . g) (f' . g') pic +--picToAlt j (OverPic f f' (Pictures ps)) = concat $ fmap (picToAlt j . OverPic f f') ps +picToAlt j (OverPic f f' pic) = overPos f . overCol f' <$> picToAlt j pic +picToAlt (Just j) (OnLayer i pic) + | j == i = picToAlt Nothing pic + | otherwise = empty +picToAlt Nothing (OnLayer _ pic) = picToAlt Nothing pic +picToAlt _ pic = pure $ picToRenderType pic + +picToRenderList + :: Maybe Int -- ^ Layer filter. Draw 'Nothing' when value is the same as at the leaf. + -> Picture + -> [RenderType] +{-# INLINE picToRenderList #-} +picToRenderList _ Blank = [] +picToRenderList j (Pictures pics) = concatMap (picToRenderList j) pics +picToRenderList j (OverPic f f' (OverPic g g' pic)) = picToRenderList j $ OverPic (f . g) (f' . g') pic +picToRenderList j (OverPic f f' (Pictures ps)) = concatMap (picToRenderList j . OverPic f f') ps +picToRenderList j (OverPic f f' pic) = overPos f . overCol f' <$> picToRenderList j pic +picToRenderList (Just j) (OnLayer i pic) + | j == i = picToRenderList Nothing pic + | otherwise = [] +picToRenderList Nothing (OnLayer _ pic) = picToRenderList Nothing pic +picToRenderList _ pic = [picToRenderType pic] + +picToRenderType + :: Picture + -> RenderType +{-# INLINE picToRenderType #-} +picToRenderType (Polygon ps) + = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black +picToRenderType (PolygonZ ps z) + = RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z) +picToRenderType (PolygonCol vs) + = RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs + where + (ps,cs) = unzip vs +picToRenderType (Poly3D vs) = RenderPoly $ polyToTris vs +picToRenderType (BezierQuad vs) = RenderBezQ $ zip3 (map zeroZ ps) cols rs + where + (ps,cols,offps,rads) = unzip4 vs + rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads +picToRenderType (Circle colC colE r) = RenderEllipse + [( (-r, r,0), colC) + ,( (-r,-r,0), colE) + ,( ( r,-r,0), black) + ] +picToRenderType (ThickArc startA endA rad wdth) = RenderArc + [( (0,0,0),black,(0,0,wdth)) + ,((xa,ya,0),black,(1,0,wdth)) + ,((xb,yb,0),black,(1,1,wdth)) + ,( (0,0,0),black,(0,0,wdth)) + ,((xb,yb,0),black,(1,1,wdth)) + ,((xc,yc,0),black,(0,1,wdth)) + ] + where + (xa,ya) = rotateV startA (rad,0) + (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0) + (xc,yc) = rotateV endA (rad,0) +picToRenderType (Line ps) + = RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white +picToRenderType (LineCol vs) + = RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs + where (ps,cs) = unzip vs +picToRenderType (Text s) = RenderText $ stringToList s +picToRenderType _ = error "Tried to make a render type from a tree picture" -- --picToAlternative -- :: Alternative t