Tweak picture layers

src/Dodge/Base/Zone.hs

@@ -110,13 +110,16 @@ zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
     wh = max (getWindowX w) (getWindowY w)
 
 zoneOfDoubleScreen :: World -> [(Int,Int)]
-zoneOfDoubleScreen w = [(a,b) | a <- [x - n .. x + n]
+zoneOfDoubleScreen w = (,) <$> xs <*> ys
-                        , b <- [y - n .. y + n]
+--    [(a,b) | a <- xs
-                 ]
+--           , b <- ys
+--    ]
   where 
     (x,y) = zoneOfPoint $ _cameraCenter w
     n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
     wh = max (getWindowX w) (getWindowY w)
+    xs = [x - n .. x + n]
+    ys = [y - n .. y + n]
 
 zoneOfSight :: World -> [(Int,Int)]
 zoneOfSight w = 
@@ -127,8 +130,24 @@ zoneOfSight w =
   where 
     (xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
 
+wallsDoubleScreen :: World -> IM.IntMap Wall
+wallsDoubleScreen w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
+    = foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs
+  where 
+    innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
+
+    f i m = case IM.lookup i m of 
+        Just val -> val
+        _        -> IM.empty
+    (x,y) = zoneOfPoint $ _cameraCenter w
+    n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
+    wh = max (getWindowX w) (getWindowY w)
+    xs = [x - n .. x + n]
+    ys = [y - n .. y + n]
+
 wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
-wallsNearZones is w = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
+wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
+    = foldl' (flip $ IM.union . \(a,b) -> f b (f a (_wallsZone w))) IM.empty is
   where 
     f i m = case IM.lookup i m of 
         Just val -> val

src/Dodge/Creature/Inanimate.hs

@@ -36,7 +36,7 @@ lamp h = defaultInanimate
     }
 lampPic :: Float -> Picture
 lampPic h = pictures
-    [ pictures . map (Poly3D 0 . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
+    [ setLayer 0 $ pictures . map (Poly3D . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
     , setLayer 1 $ setDepth h $ color white $ circleSolid 3
     ]
 

src/Dodge/Creature/Picture.hs

@@ -29,7 +29,7 @@ basicCrPict
     -> Picture
 basicCrPict col cr w
     | dist (_crPos cr) (_cameraCenter w) > 1.5 * max (getWindowX w) (getWindowY w) = blank 
-    | otherwise = pictures $
+    | otherwise = setLayer 0 $ pictures $
         targetingPic ++
         [ tr . setDepth 0 $ color yellow $ circleSolid 10
         , tr . piercingMod $ bluntScale $ naked col cr
@@ -174,4 +174,5 @@ circLine :: Float -> Picture
 circLine x = line [(0,0),(x,0)]
 
 picAtCrPos :: Picture -> Creature -> World -> Picture
+{-# INLINE picAtCrPos #-}
 picAtCrPos thePic cr _ = uncurry translate (_crPos cr) $ rotate (_crDir cr) thePic

src/Dodge/Default.hs

@@ -28,7 +28,7 @@ defaultCreature = Creature
     , _crDir    = 0
     , _crMvDir  = 0
     , _crID     = 1
-    , _crPict   = \_ _ -> onLayer CrLayer $ circleSolid 10
+    , _crPict   = \_ _ -> setLayer 0 $ onLayer CrLayer $ circleSolid 10
     , _crUpdate = \ _ f cr -> (f , Just cr)
     , _crRad    = 10
     , _crMass   = 10
@@ -38,7 +38,7 @@ defaultCreature = Creature
     , _crInvSel = 0
     , _crLeftInvSel = Nothing
     , _crState  = defaultState
-    , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
+    , _crCorpse = setLayer 0 $ onLayer CorpseLayer $ color (greyN 0.5) $ circleSolid 10
     , _crApplyDamage = defaultApplyDamage
     , _crStance = Stance 
         {_carriage=Walking 0 WasLeftForward
@@ -67,7 +67,7 @@ defaultEquipment = Equipment
     , _itName = "genericEquipment"
     , _itMaxStack = 1
     , _itAmount = 1
-    , _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
+    , _itFloorPict = setLayer 0 $ onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
     , _itEquipPict = \_ _ -> blank
     , _itEffect = NoItEffect
     , _itHammer = HammerUp

src/Dodge/Item/Consumable.hs

@@ -22,7 +22,7 @@ medkit i = defaultConsumable
     , _itMaxStack = 9
     , _itAmount = 1
     , _cnEffect = heal i
-    , _itFloorPict = onLayer FlItLayer $ color blue $ circleSolid 3
+    , _itFloorPict = setLayer 0 . onLayer FlItLayer . color blue $ circleSolid 3
     , _itEquipPict = pictureItem $ color blue $ circleSolid 3
     , _itID = Nothing
     }

src/Dodge/LevelGen/Switch.hs

@@ -13,7 +13,7 @@ makeButton
     -> (World -> World) -- ^ Effect when pressed
     -> Button
 makeButton c eff = Button
-    { _btPict = onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
+    { _btPict = setLayer 0 . onLayer WlLayer $ color c $ polygon $ rectNSEW 5 (-5) 10 (-10)
     , _btPos = (0,0)
     , _btRot = 0
     , _btEvent = \b w -> eff . over buttons (IM.adjust turnOn (_btID b))
@@ -29,7 +29,7 @@ makeButton c eff = Button
     }
   where
     turnOn bt = bt {_btState = BtNoLabel, _btPict = onPict, _btEvent = const id}
-    onPict = onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
+    onPict = setLayer 0 $ onLayer WlLayer (color c $ polygon $ rectNSEW (-3) (-5) 10 (-10))
 
 makeSwitch 
     :: Color 
@@ -51,11 +51,11 @@ makeSwitch c effOn effOff = Button
         BtOff -> effOn  . over buttons (IM.adjust turnOn  (_btID b))
         BtOn  -> effOff . over buttons (IM.adjust turnOff (_btID b))
         _ -> error "Trying to switch a button with no label"
-    offPict = onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
+    offPict = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (-8) 4 $ circleSolid 5
                               polygon $ rectNSEW (-2) (-5) (-10) 10
                               ,polygon [(-2,-5),(-10,4),(-6,4),(2,-5)]
                              ]
-    onPict  = onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
+    onPict  = setLayer 0 . onLayer WlLayer $ color c $ pictures [--translate (8) 4 $ circleSolid 5
                               polygon $ rectNSEW (-2) (-5) (-10) 10
                               ,polygon [(-2,-5), (6,4),( 10,4),(2,-5)]
                              ]

src/Dodge/Render.hs

@@ -48,8 +48,7 @@ doDrawing pdata w = do
         camzoom    = _cameraZoom w
         trans = _cameraCenter w
         wins    = (getWindowX w,getWindowY w)
-        wallPointsCol   = wallsPointsAndCols w
+        (wallPointsCol,windowPoints) = wallsAndWindows w
-        windowPoints    = wallsWindows w
         lightPoints     = lightsForGloom w
         viewFroms = _cameraViewFrom w
         pic = worldPictures w

src/Dodge/Render/Picture.hs

@@ -15,6 +15,7 @@ import Polyhedra.Data
 
 import Control.Lens
 import Data.Maybe
+import Data.List (partition)
 import qualified Data.IntMap.Strict as IM
 
 worldPictures :: World -> Picture
@@ -198,26 +199,14 @@ drawFFShadow w ff
                 , x +.+ ((0.1 + j) *.* (x -.- ypShift))
                 , y +.+ ((0.1 + j) *.* (y -.- ypShift))
                 , y]
-
+wallsAndWindows
-wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
+    :: World
-wallsPointsAndCols w 
+    -> ( [((Point2,Point2),Point4)]  ,[((Point2,Point2),Point4)] )
-    = (map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w)
+wallsAndWindows w
-  where 
+    = (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins)
-    f wl = (_wlLine wl, _wlColor wl)
-
-staticWallsOnScreen :: World -> [((Point2,Point2),Point4)]
-staticWallsOnScreen w 
-    = map f 
-    . concat 
-    $ catMaybes [IM.lookup x (_staticWalls w) >>= IM.lookup y | (x,y) <- zoneOfDoubleScreen w]
-  where
-    f wl = (_wlLine' wl, _wlColor' wl)
-
-wallsWindows :: World -> [((Point2,Point2),Point4)]
-wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
-                     filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
   where
     f wl = (_wlLine wl, _wlColor wl)
+    (wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
 
 lightsForGloom :: World -> [(Point3,Float,Float)]
 lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)

src/Picture.hs

@@ -64,15 +64,15 @@ black = (0,0,0,1)
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon = Polygon 0
+polygon = Polygon
 
 polygonZ :: [Point2] -> Float -> Picture
 {-# INLINE polygonZ #-}
-polygonZ = PolygonZ 0
+polygonZ = PolygonZ
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol = PolygonCol 0
+polygonCol = PolygonCol
 
 poly3 :: [Point3] -> Picture
 {-# INLINE poly3 #-}
@@ -80,14 +80,14 @@ poly3 = poly3Col . map (, black)
 
 poly3Col :: [(Point3,RGBA)] -> Picture
 {-# INLINE poly3Col #-}
-poly3Col = Poly3D 0
+poly3Col = Poly3D
 
 -- note that much of work computing the width of the bezier curve is done here
 bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
 bezierQuad cola colc ra rc a b c 
     | a == b && b == c = blank
     | a == b || b == c = bezierQuad cola colc ra rc a (0.5 *.* (a +.+ c)) c
-    | otherwise = BezierQuad 0 
+    | otherwise = BezierQuad
         [-- ( (0,0) , cola, (0,0), (0,0) )
          (aIn, cola, (fa aIn,fc aIn) , (1,0) )
         ,(aIn, cola, (fa aIn,fc aIn) , (1,0) )
@@ -177,11 +177,11 @@ makeArc rad (a,b) = map (`rotateV` (0,rad)) angles
 
 circleSolid :: Float -> Picture
 {-# INLINE circleSolid #-}
-circleSolid = Circle 0 white white
+circleSolid = Circle white white
 
 circleSolidCol :: Color -> Color -> Float -> Picture
 {-# INLINE circleSolidCol #-}
-circleSolidCol = Circle 0
+circleSolidCol = Circle
 
 circle :: Float -> Picture
 {-# INLINE circle #-}
@@ -189,15 +189,15 @@ circle rad = thickArc 0 (2*pi) rad 1
 
 text :: String -> Picture
 {-# INLINE text #-}
-text = Text 1
+text = Text
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
-line = Line 0
+line = Line
 
 lineCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE lineCol #-}
-lineCol = LineCol 0
+lineCol = LineCol
 
 thickLine :: [Point2] -> Float -> Picture
 {-# INLINE thickLine #-}
@@ -234,9 +234,9 @@ thickArc :: Float -> Float -> Float -> Float -> Picture
 thickArc startA endA rad wdth
     | endA - startA > pi = pictures 
         [ thickArc (startA + pi) endA rad wdth
-        , ThickArc 0 startA (startA + pi) r w
+        , ThickArc startA (startA + pi) r w
         ]
-    | otherwise = ThickArc 0 startA endA r w
+    | otherwise = ThickArc startA endA r w
   where
     r = rad + 0.5 * wdth
     w = 1 - wdth / r

src/Picture/Data.hs

@@ -4,7 +4,7 @@ module Picture.Data
     where
 import Geometry.Data
 
-import Data.Foldable
+--import Data.Foldable
 
 --import Data.Monoid
 --import Data.Traversable
@@ -82,16 +82,16 @@ flat4 (x,y,z,w) = [x,y,z,w]
 
 data Picture
     = Blank
-    | Text Int String
+    | Text String
-    | Polygon Int [Point2]
+    | Polygon [Point2]
-    | PolygonZ Int [Point2] Float
+    | PolygonZ [Point2] Float
-    | BezierQuad Int [(Point2,RGBA,Point2,Point2)]
+    | BezierQuad [(Point2,RGBA,Point2,Point2)]
-    | PolygonCol Int [(Point2,RGBA)]
+    | PolygonCol [(Point2,RGBA)]
-    | Poly3D Int [(Point3,RGBA)]
+    | Poly3D [(Point3,RGBA)]
-    | Circle Int RGBA RGBA Float
+    | Circle RGBA RGBA Float
-    | ThickArc Int Float Float Float Float
+    | ThickArc Float Float Float Float
-    | Line Int [Point2]
+    | Line [Point2]
-    | LineCol Int [(Point2,RGBA)]
+    | LineCol [(Point2,RGBA)]
     | Pictures [Picture]
     | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
     | OnLayer Int Picture

src/Picture/ToPolyhedra.hs

@@ -7,5 +7,5 @@ toPolyhedra :: Picture -> [[Point3]]
 toPolyhedra (OnLayer _ pic) = toPolyhedra pic
 toPolyhedra (Pictures pics) = concatMap toPolyhedra pics
 toPolyhedra (OverPic f _ pic) = map (map f) $ toPolyhedra pic
-toPolyhedra (Poly3D _ vs) = [map fst vs]
+toPolyhedra (Poly3D vs) = [map fst vs]
 toPolyhedra _ = []

src/Picture/Tree.hs

@@ -9,7 +9,8 @@ import Geometry.Data
 
 import Data.Bifunctor
 import Data.List
-import Data.Maybe (isNothing)
+--import Control.Applicative
+--import Data.Maybe (isNothing)
 
 -- todo: refactor out the layer check somehow
 -- consider generalising to alternative rather than using LTree
@@ -19,25 +20,25 @@ picToLTree
     -> Picture
     -> LTree RenderType
 {-# INLINE picToLTree #-}
-picToLTree mx (Polygon i ps)
+picToLTree _ (Polygon ps)
-    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToLTree mx (PolygonZ i ps z)
+picToLTree _ (PolygonZ ps z)
-    = filtB mx i $ LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+    = LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
-picToLTree mx (PolygonCol i vs)
+picToLTree _ (PolygonCol vs)
-    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
   where 
     (ps,cs) = unzip vs
-picToLTree mx (Poly3D i vs) = filtB mx i $ LLeaf $ RenderPoly $ polyToTris vs
+picToLTree _ (Poly3D vs) = LLeaf $ RenderPoly $ polyToTris vs
-picToLTree mx (BezierQuad i vs) = filtB mx i $ LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+picToLTree _ (BezierQuad vs) = LLeaf $ 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
-picToLTree mx (Circle i colC colE r) = filtB mx i $ LLeaf $ RenderEllipse 
+picToLTree _ (Circle colC colE r) = LLeaf $ RenderEllipse 
     [( (-r, r,0), colC)
     ,( (-r,-r,0), colE)
     ,( ( r,-r,0), black)
     ]
-picToLTree mx (ThickArc i startA endA rad wdth) = filtB mx i $ LLeaf $ RenderArc 
+picToLTree _ (ThickArc startA endA rad wdth) = LLeaf $ RenderArc 
     [(  (0,0,0),black,(0,0,wdth))
     ,((xa,ya,0),black,(1,0,wdth))
     ,((xb,yb,0),black,(1,1,wdth))
@@ -49,12 +50,12 @@ picToLTree mx (ThickArc i startA endA rad wdth) = filtB mx i $ LLeaf $ RenderArc
     (xa,ya) = rotateV startA (rad,0)
     (xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
     (xc,yc) = rotateV endA (rad,0)
-picToLTree mx (Line i ps) 
+picToLTree _ (Line ps) 
-    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+    = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-picToLTree mx (LineCol i vs) 
+picToLTree _ (LineCol vs) 
-    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+    = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
   where (ps,cs) = unzip vs
-picToLTree mx (Text i s) = filtB mx i $ LLeaf $ RenderText $ stringToList s
+picToLTree _ (Text s) = LLeaf $ RenderText $ stringToList s
 picToLTree _ Blank = LBranches []
 picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
 picToLTree j (OverPic f f' (OverPic g g' pic)) = picToLTree j $ OverPic (f . g) (f' . g') pic
@@ -64,11 +65,56 @@ picToLTree (Just j) (OnLayer i pic) | j == i = picToLTree Nothing pic
                                     | otherwise = LBranches []
 picToLTree Nothing  (OnLayer _ pic) = picToLTree Nothing pic
 
-filtB :: Maybe Int -> Int -> LTree RenderType -> LTree RenderType
+--picToRenderType 
-{-# INLINE filtB #-}
+--    :: Picture
-filtB mx i t 
+--    -> RenderType
-    | Just i == mx || isNothing mx = t
+--{-# INLINE picToRenderType #-}
-    | otherwise                    = LBranches []
+--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
+--
+--picToAlternative
+--    :: Alternative t
+--    => Maybe Int
+--    -> Picture
+--    -> t RenderType
+--picToAlternative _ Blank = empty
+--picToAlternative j (Pictures pics) = undefined
+    
 
 doubleLine :: [a] -> [a]
 {-# INLINE doubleLine #-}

src/Polyhedra.hs

@@ -83,7 +83,7 @@ boxABC a b c =
     faceNA = rhombus c b
 
 polyToPics :: Polyhedra -> [Picture]
-polyToPics = map (Poly3D 0) . _pyFaces
+polyToPics = map (Poly3D) . _pyFaces
 
 polysToPic :: [Polyhedra] -> Picture
 polysToPic = pictures . concatMap polyToPics