Improve speed of polygon rendering by folding tree type
This commit is contained in:
@@ -261,10 +261,10 @@ explosiveBarrel = basicCreature
|
||||
|
||||
equipOnTop :: (Creature -> Picture) -> Creature -> Drawing
|
||||
--equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
|
||||
equipOnTop f cr = onLayer CrLayer (f cr) <> drawEquipment cr
|
||||
equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr]
|
||||
|
||||
drawEquipment :: Creature -> Drawing
|
||||
drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
|
||||
drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
|
||||
where f (i,it) = case it ^? itEquipPict of
|
||||
Just g -> g cr i
|
||||
_ -> blank
|
||||
@@ -388,7 +388,7 @@ sizeEnemy col cr
|
||||
sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
|
||||
|
||||
basicCrPict :: Color -> Creature -> Drawing
|
||||
basicCrPict col cr = onLayer CrLayer naked <> drawEquipment cr
|
||||
basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
|
||||
where naked | pdam > 200 = color red $ circleSolid $ _crRad cr
|
||||
| pdam > 100 = color white $ circleSolid $ _crRad cr
|
||||
| mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr
|
||||
|
||||
+54
-50
@@ -78,72 +78,78 @@ draw'' b w-- | (Char 'm') `S.member` _keys w
|
||||
drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
|
||||
|
||||
collectDrawings :: World -> Picture
|
||||
collectDrawings w = screenShift (decPicts <> ppPicts <> itFloorPicts
|
||||
<> crPicts
|
||||
<> clPicts
|
||||
<> buttonPicts <> ptPicts
|
||||
<> ptPicts'
|
||||
<> afterPtPicts'
|
||||
<> wlPicts
|
||||
<> wallShadows
|
||||
<> smokeShadows
|
||||
)
|
||||
<> onLayer LabelLayer
|
||||
(itLabels <> ppLabels <> btLabels)
|
||||
<> hudDrawings w
|
||||
<> onLayer MenuLayer menuScreen
|
||||
collectDrawings w = pictures
|
||||
[screenShift $
|
||||
pictures $ concat
|
||||
[ decPicts
|
||||
, ppPicts
|
||||
, itFloorPicts
|
||||
, crPicts
|
||||
, clPicts
|
||||
, buttonPicts
|
||||
, ptPicts
|
||||
, ptPicts'
|
||||
, afterPtPicts'
|
||||
, wlPicts
|
||||
, wallShadows
|
||||
, smokeShadows
|
||||
]
|
||||
, onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels]
|
||||
, hudDrawings w
|
||||
, onLayer MenuLayer menuScreen
|
||||
]
|
||||
-- <> [onLayer GloomLayer $ theLighting w]
|
||||
where
|
||||
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
|
||||
. uncurry translate ((0,0) -.- _cameraPos w)
|
||||
zoom = _cameraZoom w
|
||||
decPicts :: Picture
|
||||
decPicts = mconcat $ IM.elems $ _decorations w
|
||||
ptPicts = mconcat $ map _ptPict (IM.elems (_particles w))
|
||||
ptPicts' = mconcat $ map _ptPict' $ _particles' w
|
||||
afterPtPicts' = mconcat $ map _ptPict' $ _afterParticles' w
|
||||
buttonPicts = mconcat $ map btDraw (IM.elems (_buttons w))
|
||||
ppPicts = mconcat $ map ppDraw (IM.elems (_pressPlates w))
|
||||
crPicts :: Picture
|
||||
crPicts = mconcat $ map crDraw $ IM.elems $ _creatures w
|
||||
clPicts = mconcat $ map clDraw $ IM.elems $ _clouds w
|
||||
wallShadows = mconcat $ map (drawWallShadow w) $ wallShadowsToDraw w
|
||||
smokeShadows = mconcat $ map (drawSmokeShadow w) $ _smoke w
|
||||
wlPicts = mconcat $ map drawWall (wallsToDraw w)
|
||||
decPicts = IM.elems $ _decorations w
|
||||
ptPicts = map _ptPict (IM.elems (_particles w))
|
||||
ptPicts' = map _ptPict' $ _particles' w
|
||||
afterPtPicts' = map _ptPict' $ _afterParticles' w
|
||||
buttonPicts = map btDraw (IM.elems (_buttons w))
|
||||
ppPicts = map ppDraw (IM.elems (_pressPlates w))
|
||||
crPicts = map crDraw $ IM.elems $ _creatures w
|
||||
clPicts = map clDraw $ IM.elems $ _clouds w
|
||||
wallShadows = map (drawWallShadow w) $ wallShadowsToDraw w
|
||||
smokeShadows = map (drawSmokeShadow w) $ _smoke w
|
||||
wlPicts = map drawWall (wallsToDraw w)
|
||||
itFloorPicts = map (drawItem) (IM.elems (_floorItems w))
|
||||
yourPos = _crPos $ you w
|
||||
yourRot = _crDir $ you w
|
||||
yourRad = _crRad $ you w
|
||||
-- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
|
||||
-- (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
|
||||
itFloorPicts = mconcat $ map (drawItem) (IM.elems (_floorItems w))
|
||||
itLabels = mconcat $ map (drawItemName w) (IM.elems (_floorItems w))
|
||||
ppLabels = mconcat $ map (drawPPText w) (IM.elems (_pressPlates w))
|
||||
btLabels = mconcat $ map (drawButText w) (IM.elems (_buttons w))
|
||||
itLabels = pictures $ map (drawItemName w) (IM.elems (_floorItems w))
|
||||
ppLabels = pictures $ map (drawPPText w) (IM.elems (_pressPlates w))
|
||||
btLabels = pictures $ map (drawButText w) (IM.elems (_buttons w))
|
||||
menuScreen :: Picture
|
||||
menuScreen = case _menuState w of
|
||||
InGame -> blank
|
||||
LevelMenu x ->
|
||||
mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 ("LEVEL "++show x)
|
||||
] <> controlsList
|
||||
PauseMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,controlsList
|
||||
]
|
||||
PauseMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "PAUSED"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
] <> controlsList
|
||||
GameOverMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
, controlsList
|
||||
]
|
||||
GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
|
||||
,tst (-100) 100 0.4 "GAME OVER"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
]
|
||||
<> controlsList
|
||||
,controlsList
|
||||
]
|
||||
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
|
||||
hudDrawings :: World -> Picture
|
||||
hudDrawings w = (onLayer InvLayer)
|
||||
$ displayInv 0 w
|
||||
<> mconcat
|
||||
[ dShadCol white $ displayHP 0 w
|
||||
$ pictures
|
||||
[ displayInv 0 w
|
||||
, dShadCol white $ displayHP 0 w
|
||||
, dShadCol (itCol (yourItem w))
|
||||
$ drawCursor w, translate (-390) 20
|
||||
$ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
|
||||
@@ -169,7 +175,7 @@ drawCursor w = translate (105-halfWidth w)
|
||||
where iPos = _crInvSel $ _creatures w IM.! _yourID w
|
||||
|
||||
|
||||
controlsList = mconcat [tst (-250) (-130) 0.15 "controls:"
|
||||
controlsList = pictures [tst (-250) (-130) 0.15 "controls:"
|
||||
,tst (-150) (-130) 0.15 "wasd"
|
||||
,tst 0 (-130) 0.15 "movement"
|
||||
,tst (-150) (-160) 0.15 "[rmb]"
|
||||
@@ -215,20 +221,18 @@ wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
||||
wallsOnScreen :: World -> IM.IntMap Wall
|
||||
wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
|
||||
|
||||
drawSmokeShadow :: World -> Smoke -> Drawing
|
||||
drawSmokeShadow :: World -> Smoke -> Picture
|
||||
drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t})
|
||||
= (
|
||||
onLayerL [74,0] $ color col $
|
||||
= pictures
|
||||
[ onLayerL [74,0] $ color col $
|
||||
pictures [uncurry translate p $ circle r'
|
||||
,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm
|
||||
,line [_cameraPos w, mouseWorldPos w]
|
||||
,trap' p
|
||||
]
|
||||
)
|
||||
<>
|
||||
(onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
|
||||
, onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
|
||||
$ concatMap (f . (+.+ p)) p's
|
||||
)
|
||||
]
|
||||
where
|
||||
r = r'/2
|
||||
col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red
|
||||
@@ -363,7 +367,7 @@ linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n
|
||||
p'' = (1/fromIntegral n) *.* (p' -.- p)
|
||||
|
||||
displayInv :: Int -> World -> Picture
|
||||
displayInv n w = mconcat $ zipWith (translate (10-halfWidth w))
|
||||
displayInv n w = pictures $ zipWith (translate (10-halfWidth w))
|
||||
(map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
|
||||
where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
|
||||
|
||||
|
||||
@@ -1018,7 +1018,7 @@ moveFlame rotd w pt =
|
||||
damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage)
|
||||
((:) $ Flaming (div time 10) sp p ep)
|
||||
hiteff = _btHitEffect' pt pt
|
||||
thepic p' = pic p' <> piu p' <> pi2 p' <> glow p'
|
||||
thepic p' = pictures [ pic p' , piu p' , pi2 p' , glow p' ]
|
||||
pic p' = onLayerL [levLayer UPtLayer,6] $ uncurry translate (prot3 p')
|
||||
$ rotate (90 + (negate $ radToDeg $ argV rotd))
|
||||
$ scale scaleChange 1
|
||||
@@ -2055,10 +2055,12 @@ moveTeslaArc p d i w =
|
||||
$ set randGen g
|
||||
$ createSpark 8 nc q2 (argV sv + d1) Nothing
|
||||
$ foldr damCrs w hitCrs
|
||||
where pic = (onLayer PtLayer $ color (f2 nc) $ line ps')
|
||||
<> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps')
|
||||
<> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps')
|
||||
<> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps')
|
||||
where pic = pictures
|
||||
[ onLayer PtLayer $ color (f2 nc) $ line ps'
|
||||
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
|
||||
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
|
||||
, onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
|
||||
]
|
||||
ps' = lightningMids d pers ps
|
||||
ps = take 15 $ p : map f (crsLightChain p d 0 w)
|
||||
f (E3x1 cr) = _crPos cr
|
||||
|
||||
@@ -403,7 +403,7 @@ flareRad rad rays col ax ay p
|
||||
flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
|
||||
flashRadAt rad col alphax (x,y) =
|
||||
Particle'
|
||||
{ _ptPict' = mconcat $
|
||||
{ _ptPict' = pictures $
|
||||
map (\i -> onLayerL [levLayer PtLayer]
|
||||
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
|
||||
)
|
||||
@@ -414,7 +414,7 @@ flashRadAt rad col alphax (x,y) =
|
||||
flashColAt :: Color -> Float -> Point2 -> Particle'
|
||||
flashColAt col alphax (x,y) =
|
||||
Particle'
|
||||
{ _ptPict' = mconcat $
|
||||
{ _ptPict' = pictures $
|
||||
map (\i -> onLayerL [levLayer PtLayer]
|
||||
$ color (withAlpha alphax col) $ translate x y $ circleSolid i
|
||||
)
|
||||
@@ -500,7 +500,7 @@ muzFlareAt p = over particles' ((:) (muzzleFlareAt p))
|
||||
muzzleFlareAt :: Point2 -> Particle'
|
||||
muzzleFlareAt (x,y) =
|
||||
Particle'
|
||||
{ _ptPict' = mconcat
|
||||
{ _ptPict' = pictures
|
||||
$ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i
|
||||
)
|
||||
[20,25,30,35,40,45,50]
|
||||
@@ -748,7 +748,7 @@ moveFlamelet levelInt rot w pt =
|
||||
sc = (*) 2 $ log $ 1 + fromIntegral time / 20
|
||||
s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
|
||||
s2 = 0.5 * (sc + s1)
|
||||
thepicture = pic <> piu <> pi2 <> glow
|
||||
thepicture = pictures [pic , piu , pi2 , glow]
|
||||
pi2 = onLayerL [levelInt,2] $ uncurry translate ep
|
||||
$ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time)
|
||||
orange (dark red)
|
||||
@@ -839,14 +839,16 @@ moveSmoke'' scal time p vel w pt
|
||||
pic = onLayerL [levLayer PtLayer - 1]
|
||||
$ uncurry translate pNew
|
||||
$ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
|
||||
pi1 = (onLayerL [levLayer PtLayer]
|
||||
pi1 = pictures
|
||||
[(onLayerL [levLayer PtLayer]
|
||||
$ uncurry translate pNew
|
||||
$ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5))
|
||||
$ circleSolid $ 21 * scal)
|
||||
<> (onLayerL [levLayer BgLayer+1]
|
||||
, (onLayerL [levLayer BgLayer+1]
|
||||
$ uncurry translate pNew
|
||||
$ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5))
|
||||
$ circleSolid $ 21 * scal)
|
||||
]
|
||||
|
||||
makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
|
||||
makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w
|
||||
|
||||
Reference in New Issue
Block a user