Tweak picture layers

2021-07-21 17:52:38 +02:00
parent 0aa437d035
commit 9f37ecb204
13 changed files with 134 additions and 80 deletions
@@ -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]
-                        , b <- [y - n .. y + n]
-                 ]
+zoneOfDoubleScreen w = (,) <$> xs <*> ys
+--    [(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
@@ -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
    ]

@@ -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
@@ -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
@@ -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
    }
@@ -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)]
                             ]
@@ -48,8 +48,7 @@ doDrawing pdata w = do
        camzoom    = _cameraZoom w
        trans = _cameraCenter w
        wins    = (getWindowX w,getWindowY w)
-        wallPointsCol   = wallsPointsAndCols w
-        windowPoints    = wallsWindows w
+        (wallPointsCol,windowPoints) = wallsAndWindows w
        lightPoints     = lightsForGloom w
        viewFroms = _cameraViewFrom w
        pic = worldPictures w
@@ -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]
-
-wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
-wallsPointsAndCols w 
-    = (map f . filter (not . _wlIsSeeThrough) . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w)
-  where 
-    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]
+wallsAndWindows
+    :: World
+    -> ( [((Point2,Point2),Point4)]  ,[((Point2,Point2),Point4)] )
+wallsAndWindows w
+    = (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins)
  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)