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)
@@ -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
@@ -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
-    | Polygon Int [Point2]
-    | PolygonZ Int [Point2] Float
-    | BezierQuad Int [(Point2,RGBA,Point2,Point2)]
-    | PolygonCol Int [(Point2,RGBA)]
-    | Poly3D Int [(Point3,RGBA)]
-    | Circle Int RGBA RGBA Float
-    | ThickArc Int Float Float Float Float
-    | Line Int [Point2]
-    | LineCol Int [(Point2,RGBA)]
+    | Text String
+    | Polygon [Point2]
+    | PolygonZ [Point2] Float
+    | BezierQuad [(Point2,RGBA,Point2,Point2)]
+    | PolygonCol [(Point2,RGBA)]
+    | Poly3D [(Point3,RGBA)]
+    | Circle RGBA RGBA Float
+    | ThickArc Float Float Float Float
+    | Line [Point2]
+    | LineCol [(Point2,RGBA)]
    | Pictures [Picture]
    | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
    | OnLayer Int Picture
@@ -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 _ = []
@@ -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)
-    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-picToLTree mx (PolygonZ i ps z)
-    = filtB mx i $ LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
-picToLTree mx (PolygonCol i vs)
-    = filtB mx i $ LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+picToLTree _ (Polygon ps)
+    = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+picToLTree _ (PolygonZ ps z)
+    = LLeaf $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
+picToLTree _ (PolygonCol vs)
+    = 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 mx (BezierQuad i vs) = filtB mx i $ LLeaf $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
+picToLTree _ (Poly3D vs) = LLeaf $ RenderPoly $ polyToTris vs
+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) 
-    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-picToLTree mx (LineCol i vs) 
-    = filtB mx i $ LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ doubleLine cs
+picToLTree _ (Line ps) 
+    = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+picToLTree _ (LineCol vs) 
+    = 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
-{-# INLINE filtB #-}
-filtB mx i t 
-    | Just i == mx || isNothing mx = t
-    | otherwise                    = LBranches []
+--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
+--
+--picToAlternative
+--    :: Alternative t
+--    => Maybe Int
+--    -> Picture
+--    -> t RenderType
+--picToAlternative _ Blank = empty
+--picToAlternative j (Pictures pics) = undefined
+    

 doubleLine :: [a] -> [a]
 {-# INLINE doubleLine #-}
@@ -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