Add source files, commit before reverting pictures to lists
This commit is contained in:
@@ -0,0 +1,512 @@
|
||||
module Dodge.Rendering where
|
||||
-- imports {{{
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Data.Graph.Inductive.Query.DFS
|
||||
import Data.Graph.Inductive.Graph
|
||||
|
||||
import Control.Monad.State
|
||||
import Data.List
|
||||
import Data.Bifunctor
|
||||
|
||||
|
||||
import Data.Function
|
||||
import Control.Applicative
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Set as S
|
||||
|
||||
-- }}}
|
||||
--
|
||||
drawTest :: World -> Picture
|
||||
drawTest w = screenT $ color red $ circle 200
|
||||
where (x,y) = (_windowX w,_windowY w)
|
||||
screenT = scale (1/x) (1/y)
|
||||
|
||||
|
||||
draw' :: Picture -> World -> ([((Float,Float),(Float,Float))]
|
||||
,[((Float,Float),Float,Float)]
|
||||
,Picture,Picture)
|
||||
draw' p w = (\(x,y) -> (wallsForGloom w,lightsForGloom w,x,y)) (draw'' p w)
|
||||
|
||||
draw :: Picture -> World -> Picture
|
||||
draw p w = (\(x,y) -> f $ pictures [x,y]) $ draw'' p w
|
||||
where f = scale (2/_windowX w) (2/_windowY w)
|
||||
|
||||
draw'' :: Picture -> World -> (Picture , Picture)
|
||||
draw'' b w-- | (Char 'm') `S.member` _keys w
|
||||
-- = let a = (-500,30)
|
||||
-- b = (200,0)
|
||||
-- in pictures [ color white $ polygon screenBox
|
||||
-- , color blue $ circleSolid 40
|
||||
-- , line [a,b]
|
||||
-- , uncurry translate (ssaTriPoint a (0,0) b 40)
|
||||
-- $ color red $ circleSolid 5
|
||||
-- ]
|
||||
= case _mapDisplay w of
|
||||
(True, z) -> (blank
|
||||
,pictures [color white $ circleSolid 3
|
||||
,scale z z $ rotate (radToDeg (_cameraRot w))
|
||||
$ uncurry translate ((0,0) -.- _cameraCenter w)
|
||||
$ pictures $ mapMaybe mapWall $ IM.elems $ _walls w]
|
||||
)
|
||||
_ -> ( blank
|
||||
--,pictures $ map fst pics
|
||||
,collectDrawings w
|
||||
)
|
||||
-- ++ map screenShift (pathsTest ++ map drawNode (labNodes $ _pathGraph w))
|
||||
where yourPos = _crPos $ you w
|
||||
backgroundTile = [screenShift $ translate (5*512*x) (5*512*y) $ scale 5 5 b | x <- [x1..x2] , y <- [y1..y2] ]
|
||||
where (x',y') = yourPos
|
||||
(x'',y'') = (fromIntegral $ round (x'/(512*5)), fromIntegral $ round (y'/(512*5)))
|
||||
x1 = (x''-1)
|
||||
x2 = (x''+1)
|
||||
y1 = (y''-1)
|
||||
y2 = (y''+1)
|
||||
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
|
||||
. uncurry translate ((0,0) -.- _cameraPos w)
|
||||
zoom = _cameraZoom w
|
||||
pathsTest = map drawPair $ _pathGraph' w
|
||||
drawPair (x,y) = color cyan $ pictures [line [x,y]
|
||||
-- , uncurry translate x $ scale 0.05 0.05 $ text $ show x
|
||||
]
|
||||
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
|
||||
-- <> [onLayer GloomLayer $ theLighting w]
|
||||
where
|
||||
screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
|
||||
. uncurry translate ((0,0) -.- _cameraPos w)
|
||||
rotPicts = map (scale zoom zoom . rotate (radToDeg (_cameraRot 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)
|
||||
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))
|
||||
menuScreen :: Picture
|
||||
menuScreen = case _menuState w of
|
||||
InGame -> blank
|
||||
LevelMenu x ->
|
||||
mconcat [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
|
||||
,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
|
||||
,tst (-100) 100 0.4 "GAME OVER"
|
||||
,tst (-100) 50 0.2 "n - new level"
|
||||
,tst (-100) 0 0.2 "r - restart"
|
||||
]
|
||||
<> 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
|
||||
, dShadCol (itCol (yourItem w))
|
||||
$ drawCursor w, translate (-390) 20
|
||||
$ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
|
||||
]
|
||||
where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
|
||||
|
||||
crDraw :: Creature -> Drawing
|
||||
crDraw c = uncurry translateDrawing (_crPos c) $ rotateDrawing (- radToDeg (_crDir c)) (_crPict c c)
|
||||
ppDraw :: PressPlate -> Drawing
|
||||
ppDraw c = uncurry translateDrawing (_ppPos c) $ rotateDrawing (- radToDeg (_ppRot c)) (_ppPict c)
|
||||
btDraw :: Button -> Drawing
|
||||
btDraw c = uncurry translateDrawing (_btPos c) $ rotateDrawing (- radToDeg (_btRot c)) (_btPict c)
|
||||
|
||||
clDraw :: Cloud -> Drawing
|
||||
clDraw c = uncurry translateDrawing (_clPos c) $ (_clPict c c)
|
||||
|
||||
drawCursor :: World -> Picture
|
||||
drawCursor w = translate (105-halfWidth w)
|
||||
(halfHeight w - (25* (fromIntegral iPos)) - 20
|
||||
)
|
||||
-- $ rectangleWire 200 25
|
||||
$ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
|
||||
where iPos = _crInvSel $ _creatures w IM.! _yourID w
|
||||
|
||||
|
||||
controlsList = mconcat [tst (-250) (-130) 0.15 "controls:"
|
||||
,tst (-150) (-130) 0.15 "wasd"
|
||||
,tst 0 (-130) 0.15 "movement"
|
||||
,tst (-150) (-160) 0.15 "[rmb]"
|
||||
,tst 0 (-160) 0.15 "aim"
|
||||
,tst (-150) (-190) 0.15 "[rmb+lmb]"
|
||||
,tst 0 (-190) 0.15 "shoot or use item"
|
||||
,tst (-150) (-220) 0.15 "[wheelscroll]"
|
||||
,tst 0 (-220) 0.15 "select item"
|
||||
,tst (-150) (-250) 0.15 "[space]"
|
||||
,tst 0 (-250) 0.15 "pickup item"
|
||||
,tst (-150) (-280) 0.15 "f"
|
||||
,tst 0 (-280) 0.15 "drop item"
|
||||
,tst (-150) (-310) 0.15 "cp[esc]"
|
||||
,tst 0 (-310) 0.15 "pause"
|
||||
,tst (-150) (-340) 0.15 "qe[lmb]"
|
||||
,tst 0 (-340) 0.15 "rotate camera"
|
||||
]
|
||||
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
||||
|
||||
screenBox w = [ (halfWidth w, halfHeight w)
|
||||
, (-halfWidth w, halfHeight w)
|
||||
, (-halfWidth w,-halfHeight w)
|
||||
, ( halfWidth w,-halfHeight w)
|
||||
]
|
||||
|
||||
mapWall :: Wall -> Maybe Picture
|
||||
mapWall wl =
|
||||
case _wlSeen wl of
|
||||
False -> Nothing
|
||||
True -> Just $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
|
||||
where t = 5 *.* errorNormalizeV 68 (y -.- x)
|
||||
n = vNormal t
|
||||
n2 = 4 *.* n
|
||||
(x:y:_) = _wlLine wl
|
||||
c = _wlColor wl
|
||||
|
||||
wallsToDraw :: World -> [Wall]
|
||||
wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
||||
where onScreen wall = lineOnScreen w (_wlLine wall)
|
||||
isVisible wl | wl ^? blVisible == Just False = False
|
||||
| otherwise = onScreen wl
|
||||
|
||||
wallsOnScreen :: World -> IM.IntMap Wall
|
||||
wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
|
||||
|
||||
drawSmokeShadow :: World -> Smoke -> Drawing
|
||||
drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t})
|
||||
= (
|
||||
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
|
||||
$ concatMap (f . (+.+ p)) p's
|
||||
)
|
||||
where
|
||||
r = r'/2
|
||||
col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red
|
||||
| otherwise = green
|
||||
orth p' = r *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w)
|
||||
pa p' = p' +.+ orth p'
|
||||
pb p' = p' -.- orth p'
|
||||
pao p' = pa p' +.+ l *.* safeNormalizeV (pa p' -.- _cameraCenter w)
|
||||
pbo p' = pb p' +.+ l *.* safeNormalizeV (pb p' -.- _cameraCenter w)
|
||||
semiCirc p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r
|
||||
a p' = pi - argV (orth p')
|
||||
trap p' = polygon [pa p', pb p', pbo p', pao p']
|
||||
f p' = [semiCirc p', trap p']
|
||||
p's = zipWith (\x p -> rotateV (x * fromIntegral t / 60) p) xs ps
|
||||
xs = concat $ repeat [-1,-0.5,0,0.5,1]
|
||||
l = _windowX w + _windowY w + magV (_cameraPos w -.- _cameraCenter w)
|
||||
-- cenpic = color (withAlpha 0.5 c) $ pictures $ f p
|
||||
orth' p' = r' *.* (safeNormalizeV $ vNormal $ p' -.- _cameraCenter w)
|
||||
pa' p' = p' +.+ orth' p'
|
||||
pb' p' = p' -.- orth' p'
|
||||
pao' p' = pa' p' +.+ l *.* safeNormalizeV (pa' p' -.- _cameraCenter w)
|
||||
pbo' p' = pb' p' +.+ l *.* safeNormalizeV (pb' p' -.- _cameraCenter w)
|
||||
trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p']
|
||||
semiCirc' p' = uncurry translate p' $ rotate (radToDeg (a p')) $ arcSolid 0 180 r'
|
||||
|
||||
|
||||
drawWall :: Wall -> Drawing
|
||||
drawWall wl = case _wlDraw wl of
|
||||
Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
|
||||
Just d -> d wl
|
||||
where
|
||||
(x:y:_) = _wlLine wl
|
||||
c = _wlColor wl
|
||||
t = 5 *.* errorNormalizeVDR (y -.- x)
|
||||
n = vNormal t
|
||||
n2 = 3 *.* n
|
||||
layer2 | _wlIsSeeThrough wl = 0
|
||||
| isJust $ wl ^? doorMech = 1
|
||||
| otherwise = 2
|
||||
-- wallOrdering wl = (not $ _wlIsSeeThrough wl, not $ isJust $ wl ^? doorMech)
|
||||
|
||||
errorNormalizeVDR :: Point2 -> Point2
|
||||
errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
|
||||
errorNormalizeVDR p = normalizeV p
|
||||
|
||||
printPoint :: Point2 -> Picture
|
||||
printPoint p = color white $ uncurry translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
|
||||
|
||||
printRotPoint :: Float -> Point2 -> Picture
|
||||
printRotPoint r p = color white $ uncurry translate p $ pictures [circle 3
|
||||
, rotate r $ scale 0.1 0.1 $ text (show p)]
|
||||
|
||||
outsideScreenPolygon :: World -> [Point2]
|
||||
outsideScreenPolygon w = [tr,tl,bl,br]
|
||||
where scRot = rotateV (_cameraRot w)
|
||||
scZoom p | _cameraZoom w /= 0 = (1/_cameraZoom w) *.* p
|
||||
scTran p = p +.+ _cameraPos w
|
||||
tr = scTran $ scRot $ scZoom ( 3*halfWidth w , 3* halfHeight w)
|
||||
tl = scTran $ scRot $ scZoom (- (3*halfWidth w), 3* halfHeight w)
|
||||
br = scTran $ scRot $ scZoom ( 3*halfWidth w ,- (3* halfHeight w))
|
||||
bl = scTran $ scRot $ scZoom (- (3*halfWidth w),- (3* halfHeight w))
|
||||
x = halfWidth w + halfHeight w
|
||||
|
||||
-- wallShadowsToDrawOnScreen :: World -> [Wall]
|
||||
-- wallShadowsToDrawOnScreen w = --IM.elems $ _walls w
|
||||
-- sortBy (compare `on` not . _wlIsSeeThrough) $ filter isVisible $ IM.elems
|
||||
-- $ _walls w
|
||||
-- -- $ wallsOnScreen w
|
||||
-- -- should really sort this out
|
||||
-- where onScreen wall = lineOnScreen w (_wlLine wall)
|
||||
-- isVisible wl | wl ^? blVisible == Just False = False
|
||||
-- | otherwise = onScreen wl
|
||||
|
||||
wallShadowsToDraw :: World -> [Wall]
|
||||
wallShadowsToDraw w = --IM.elems $ _walls w
|
||||
filter isVisible $ IM.elems -- $ _walls w
|
||||
$ wallsNearZones (zoneOfSight w) w
|
||||
-- should really sort this out
|
||||
where onScreen wall = True -- lineOnScreenCone w (_wlLine wall)
|
||||
isVisible wl | wl ^? blVisible == Just False = False
|
||||
| otherwise = onScreen wl
|
||||
|
||||
-- cannot only test if walls are on screen, but also if they are on the cone
|
||||
-- towards the center of sight
|
||||
lineOnScreenCone :: World -> [Point2] -> Bool
|
||||
lineOnScreenCone w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|
||||
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|
||||
where sp' = screenPolygon w
|
||||
vp = _cameraCenter w
|
||||
sp | pointInPolygon vp sp' = sp'
|
||||
| otherwise = orderPolygon $ (_cameraCenter w : sp')
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
|
||||
lineOnScreen :: World -> [Point2] -> Bool
|
||||
lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9 p2 sp
|
||||
|| any (isJust . uncurry (intersectSegSeg' p1 p2)) sps
|
||||
where sp = screenPolygon w
|
||||
sps = zip sp (tail sp ++ [head sp])
|
||||
|
||||
|
||||
drawWallShadow :: World -> Wall -> Drawing
|
||||
drawWallShadow w wall
|
||||
| isRHS sightFrom x y = blank
|
||||
| otherwise = onLayerL l $ color shadCol $ polygon $ points
|
||||
where
|
||||
l | _wlIsSeeThrough wall = [levLayer ShadowLayer]
|
||||
| otherwise = [levLayer ShadowLayer, 0]
|
||||
(x:y:_) = _wlLine wall
|
||||
ps = linePointsBetween x y
|
||||
ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps
|
||||
p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps
|
||||
sightFrom = _cameraCenter w
|
||||
shadCol = if _wlIsSeeThrough wall then withAlpha 0.2 $ _wlColor wall
|
||||
else black
|
||||
corns = screenPolygon w
|
||||
borders = filter g $ zip corns (tail corns ++ [head corns])
|
||||
g (a,b) = isLHS a b sightFrom
|
||||
borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
|
||||
coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
|
||||
shadowedCorners = filter isShadowed coneTop
|
||||
isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
|
||||
f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
|
||||
f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
|
||||
points = orderPolygon (borderps ++ p's)
|
||||
|
||||
linePointsBetween :: Point2 -> Point2 -> [Point2]
|
||||
linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p']
|
||||
| otherwise = [p,p']
|
||||
where d = dist p p'
|
||||
n = ceiling $ d / 50
|
||||
p'' = (1/fromIntegral n) *.* (p' -.- p)
|
||||
|
||||
displayInv :: Int -> World -> Picture
|
||||
displayInv n w = mconcat $ 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
|
||||
|
||||
dItem' NoItem = scale 0.15 0.15 $ dShadCol (greyN 0.5) $ text "----"
|
||||
dItem' i = scale 0.15 0.15 $ pictures [dropShadow t, color (_itInvColor i) t]
|
||||
where t = text $ _itInvDisplay i i
|
||||
|
||||
displayAmount :: Int -> String
|
||||
displayAmount n | n > 1 = "-x" ++show n
|
||||
| otherwise = []
|
||||
|
||||
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
|
||||
|
||||
drawItem :: FloorItem -> Drawing
|
||||
drawItem (FlAm {_flItPos = p}) = uncurry translateDrawing p $ onLayer FlItLayer $ rectangleSolid 5 5
|
||||
drawItem flIt = uncurry translateDrawing (_flItPos flIt)
|
||||
$ rotateDrawing (radToDeg $ _flItRot flIt) (_itFloorPict (_flIt flIt))
|
||||
|
||||
drawButText :: World -> Button -> Picture
|
||||
drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
|
||||
&& hasLOS (_btPos bt) (_crPos (you w)) w
|
||||
&& _btState bt /= BtNoLabel
|
||||
= t $ rotate (radToDeg (-_cameraRot w))
|
||||
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
|
||||
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
|
||||
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
|
||||
$ scale 0.1 0.1 $ text $ _btText bt
|
||||
]
|
||||
| otherwise = blank
|
||||
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
|
||||
zoom = _cameraZoom w
|
||||
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
|
||||
|
||||
drawPPText :: World -> PressPlate -> Picture
|
||||
drawPPText w pp | magV (_crPos (you w) -.- _ppPos pp) < 100
|
||||
&& hasLOS (_ppPos pp) (_crPos (you w)) w
|
||||
= t $ rotate (radToDeg (-_cameraRot w))
|
||||
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
|
||||
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
|
||||
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
|
||||
$ scale 0.1 0.1 $ text $ _ppText pp
|
||||
]
|
||||
| otherwise = blank
|
||||
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_ppPos pp -.- _cameraPos w))
|
||||
zoom = _cameraZoom w
|
||||
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
|
||||
|
||||
drawItemName :: World -> FloorItem -> Picture
|
||||
drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
|
||||
&& hasLOS (_flItPos flIt) (_crPos (you w)) w
|
||||
= t $ rotate (radToDeg (-_cameraRot w))
|
||||
$ pictures $ [ scLine [(-8,10),(-15,10),(-15,-10),(-8,-10)]
|
||||
, scLine [( 8,10),( 15,10),( 15,-10),( 8,-10)]
|
||||
,translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
|
||||
$ scale 0.1 0.1 $ text $ nameOfItem
|
||||
]
|
||||
| otherwise = blank
|
||||
where t = rotate (radToDeg (_cameraRot w)) . uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
|
||||
nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
|
||||
FlAm {_flAm = PistolBullet} -> "Bullets"
|
||||
FlAm {_flAm = LiquidFuel} -> "Liquid Fuel"
|
||||
zoom = _cameraZoom w
|
||||
scLine = dShadCol white . line . fmap (sqrt zoom *.*)
|
||||
|
||||
ringPict :: Drawing
|
||||
ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
|
||||
,line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
|
||||
]
|
||||
|
||||
dShadCol :: Color -> Picture -> Picture
|
||||
dShadCol c p = pictures $
|
||||
map (flip (uncurry translate) p) [(0.2,-0.2)
|
||||
,(0.4,-0.4)
|
||||
,(0.6,-0.6)
|
||||
,(0.8,-0.8)
|
||||
,( 1,- 1)
|
||||
,(1.2,-1.2)
|
||||
] ++ [color c p]
|
||||
|
||||
dropShadow :: Picture -> Picture
|
||||
dropShadow p = pictures [ translate 5 (-5) p
|
||||
, translate 1 (-1) p
|
||||
, translate 2 (-2) p
|
||||
, translate 3 (-3) p
|
||||
, translate 4 (-4) p
|
||||
, translate 6 (-6) p
|
||||
, translate 7 (-7) p
|
||||
, translate 8 (-8) p
|
||||
, translate 9 (-9) p
|
||||
]
|
||||
|
||||
ffToDraw :: World -> [ForceField]
|
||||
ffToDraw w = filter (lineOnScreen w . _ffLine) $
|
||||
IM.elems $ fmap (over ffLine (map (\p->p -.- _cameraPos w))) $
|
||||
_forceFields w
|
||||
|
||||
drawFF :: ForceField -> Picture
|
||||
drawFF (FF {_ffLine = l, _ffColor = col}) = pictures [color white $ line l, color col
|
||||
$ lineOfThickness 6 l ]
|
||||
|
||||
|
||||
drawFFShadow :: World -> ForceField -> [Picture]
|
||||
drawFFShadow w ff
|
||||
| youOnFF = []
|
||||
| otherwise = map (rotate (radToDeg (- _cameraRot w)) . pane)
|
||||
[0,0.05..0.25]
|
||||
where p = rotateV (-_cameraRot w) $ ypShift
|
||||
x = rotateV (-_cameraRot w) x'
|
||||
y = rotateV (-_cameraRot w) y'
|
||||
yp = _crPos $ you w
|
||||
(x1:y1:_) = _ffLine ff
|
||||
(x':y':_) | isRHS x1 y1 yp = (y1:x1:[])
|
||||
| otherwise = (x1:y1:[])
|
||||
fCol = color (_ffColor ff)
|
||||
col = _ffColor ff
|
||||
ypShift = yp -.- _cameraPos w
|
||||
youOnFF = circOnLine' x' y' ypShift (_crRad $ you w)
|
||||
pane j = color (withAlpha 0.1 col)
|
||||
$ polygon
|
||||
$ [ x
|
||||
, x +.+ ((0.1 + j) *.* (x -.- ypShift))
|
||||
, y +.+ ((0.1 + j) *.* (y -.- ypShift))
|
||||
, y]
|
||||
|
||||
displayHP :: Int -> World -> Picture
|
||||
displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $
|
||||
scale 0.2 0.2 $ text $ show
|
||||
$ _crHP $ _creatures w IM.! n
|
||||
|
||||
testPic w = blank
|
||||
|
||||
wallsForGloom :: World -> [(Point2,Point2)]
|
||||
wallsForGloom w = map (\(x:y:_) -> (screenShift x,screenShift y)) $
|
||||
map _wlLine $ filter (not . _wlIsSeeThrough)
|
||||
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
||||
where screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
|
||||
zoom = _cameraZoom w
|
||||
|
||||
|
||||
lightsForGloom :: World -> [(Point2,Float,Float)]
|
||||
lightsForGloom w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
|
||||
where getLS ls = (screenShift $ _lsPos ls, _lsRad ls * zoom, _lsIntensity ls)
|
||||
getTLS ls = (screenShift $ _tlsPos ls, _tlsRad ls * zoom, _tlsIntensity ls)
|
||||
screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
|
||||
zoom = _cameraZoom w
|
||||
Reference in New Issue
Block a user