542 lines
25 KiB
Haskell
542 lines
25 KiB
Haskell
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 (0 - (_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 (0 - (_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 = 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 (0 - (_cameraRot w) )
|
|
. uncurry translate ((0,0) -.- _cameraPos w)
|
|
zoom = _cameraZoom 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)))
|
|
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 ->
|
|
pictures [--color (withAlpha 0.5 black) $ polygon $ screenBox w
|
|
tst (-100) 100 0.4 ("LEVEL "++show x)
|
|
,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 -> 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
|
|
]
|
|
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
|
|
|
|
hudDrawings :: World -> Picture
|
|
hudDrawings w = (onLayer InvLayer)
|
|
$ pictures
|
|
[ displayInv 0 w
|
|
, dShadCol white $ displayHP 0 w
|
|
, --color (itCol (yourItem w))
|
|
color white
|
|
$ 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 translate (_crPos c) $ rotate (_crDir c) (_crPict c c)
|
|
ppDraw :: PressPlate -> Drawing
|
|
ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
|
btDraw :: Button -> Drawing
|
|
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
|
|
|
|
clDraw :: Cloud -> Drawing
|
|
clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
|
|
|
|
drawCursor :: World -> Picture
|
|
drawCursor w = translate (105-halfWidth w)
|
|
(halfHeight w - (25* (fromIntegral iPos)) - 20
|
|
)
|
|
$ setLayer 2
|
|
$ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
|
|
where iPos = _crInvSel $ _creatures w IM.! _yourID w
|
|
|
|
|
|
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]"
|
|
,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 -> Picture
|
|
drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t})
|
|
= 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
|
|
$ 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 (0 - (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 (0 - (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 (0 - 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 = 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
|
|
|
|
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 (_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 (0 - (_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 (_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 (0 - (_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 (_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 (0 - (_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 ( _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
|
|
|
|
wallsForGloom' :: World -> [(Point2,Point2,Point2,Point2)]
|
|
wallsForGloom' w = map (wallPairToFour . _wlLine) $ filter (not . _wlIsSeeThrough)
|
|
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
|
|
|
where wallPairToFour (x:y:_) = (ss x,ss y,ss $ x +.+ n,ss $ y+.+ n)
|
|
where n = 15 *.* (normalizeV $ vNormal $ y -.- x)
|
|
ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w)
|
|
ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w)
|
|
ss = ss'' . ss'
|
|
-- the ss transformation would possibly be better done using a matrix in the
|
|
-- shader
|
|
zoom = _cameraZoom w
|
|
|
|
lightsForGloom' :: World -> [(Point4)]
|
|
lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
|
|
where getLS ls = ( fst $ ssls ls, snd $ ssls ls, _lsRad ls , _lsIntensity ls)
|
|
getTLS ls = ( fst $ sstls ls,snd $ sstls ls, _tlsRad ls, _tlsIntensity ls)
|
|
ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w)
|
|
ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w)
|
|
ss = ss'' . ss'
|
|
ssls = ss . _lsPos
|
|
sstls = ss . _tlsPos
|
|
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
|