527 lines
24 KiB
Haskell
527 lines
24 KiB
Haskell
module Dodge.Rendering where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
--import Dodge.Inventory
|
|
|
|
import Dodge.Rendering.HUD
|
|
|
|
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
|
|
|
|
-- }}}
|
|
fixedCoordPictures :: World -> Picture
|
|
fixedCoordPictures w = pictures
|
|
-- [ scaler $ onLayer LabelLayer $ pictures [ppLabels, btLabels]
|
|
[ scaler $ hudDrawings w
|
|
, scaler $ onLayer MenuLayer menuScreen
|
|
--, onLayer InvLayer $ activeObjectText w
|
|
, onLayer InvLayer $ closeObjectTexts w
|
|
]
|
|
where scaler = scale (2 / _windowX w) (2 / _windowY 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
|
|
|
|
|
|
worldPictures :: World -> Picture
|
|
worldPictures w
|
|
= pictures $ concat [ decPicts
|
|
, ppPicts
|
|
, itFloorPicts
|
|
, crPicts
|
|
, clPicts
|
|
, buttonPicts
|
|
, ptPicts
|
|
, ptPicts'
|
|
, afterPtPicts'
|
|
, wlPicts
|
|
, wallShadows
|
|
, smokeShadows
|
|
-- , itLabels
|
|
, ppLabels
|
|
, btLabels
|
|
, testPic w
|
|
]
|
|
where
|
|
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
|
|
scaler = onLayer LabelLayer . setLayer 1
|
|
itLabels = map (scaler . drawItemName w) (IM.elems (_floorItems w))
|
|
ppLabels = map (scaler . drawPPText w) (IM.elems (_pressPlates w))
|
|
btLabels = map (scaler . 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
|
|
|
|
testPic :: World -> [Picture]
|
|
testPic w = [setLayer 1 $ onLayerL [99] $ color red $ bezierQuad (-200,200) (-200,-200) (200,200) ]
|
|
-- $ uncurry translate (mouseWorldPos w)
|
|
|
|
|
|
hudDrawings :: World -> Picture
|
|
hudDrawings w = setLayer 1 $ (onLayer InvLayer)
|
|
$ pictures
|
|
[ displayInv 0 w
|
|
, dShadCol white $ displayHP 0 w
|
|
, drawCursor (itCol (yourItem w)) 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 :: Color -> World -> Picture
|
|
drawCursor c w = setLayer 1
|
|
$ translate (105-halfWidth w)
|
|
(halfHeight w - (20* (fromIntegral iPos)) - 20
|
|
)
|
|
$ lineCol [(( 100,12.5) ,withAlpha 0 c)
|
|
,((-100,12.5) ,c)
|
|
,((-100,-7.5) ,c)
|
|
,(( 100,-7.5) ,withAlpha 0 c)
|
|
]
|
|
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 (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c})
|
|
= onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
|
|
drawWall wl = case _wlDraw wl of
|
|
-- Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon $ _wlLine wl
|
|
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
|
|
|
|
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 = colorAndLayer $ polygon $ points
|
|
where
|
|
colorAndLayer | _wlIsSeeThrough wall = setLayer 2
|
|
. onLayerL [levLayer ShadowLayer]
|
|
. color (withAlpha 0.2 $ _wlColor wall)
|
|
| otherwise = setLayer 1
|
|
. onLayerL [levLayer ShadowLayer,2]
|
|
. color black
|
|
(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
|
|
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 (15-halfWidth w))
|
|
(map (\x-> halfHeight w-(20*(fromIntegral x+1))) ns) $ map dItem' is
|
|
where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
|
|
|
|
dItem' NoItem = scale 0.1 0.1 $ dShadCol (greyN 0.5) $ text "----"
|
|
dItem' i = scale 0.1 0.1 $ dShadCol (_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 translate p $ onLayer FlItLayer $ rectangleSolid 5 5
|
|
drawItem flIt = uncurry translate (_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
|
|
= pictures
|
|
--[ scale (2/_windowX w) (2/_windowY w)
|
|
-- . t
|
|
-- . translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
|
|
-- $ scale 0.1 0.1 $ text $ _btText bt
|
|
[ tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
|
|
, tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
|
|
]
|
|
| otherwise = blank
|
|
where tranItPos' = uncurry translate (_btPos bt) . rotate (_cameraRot w)
|
|
t = rotate (0 - (_cameraRot w))
|
|
. uncurry translate (zoom *.* (_btPos bt -.- _cameraPos w))
|
|
. rotate (_cameraRot w)
|
|
zoom = _cameraZoom w
|
|
|
|
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
|
|
= pictures
|
|
--[ scale (2/_windowX w) (2/_windowY w)
|
|
-- . t
|
|
-- . translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
|
|
-- $ scale 0.1 0.1 $ text $ nameOfItem
|
|
[ tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
|
|
, tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
|
|
]
|
|
| otherwise = blank
|
|
where tranItPos' = uncurry translate (_flItPos flIt) . rotate (_cameraRot w)
|
|
t = rotate (0 - (_cameraRot w))
|
|
. uncurry translate (zoom *.* (_flItPos flIt -.- _cameraPos w))
|
|
. rotate (_cameraRot w)
|
|
nameOfItem = case flIt of FlIt {} -> _itName $ _flIt flIt
|
|
FlAm {_flAm = PistolBullet} -> "Bullets"
|
|
FlAm {_flAm = LiquidFuel} -> "Liquid Fuel"
|
|
zoom = _cameraZoom w
|
|
|
|
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 $
|
|
[ color black $ uncurry translate (1.2,-1.2) p
|
|
, color c 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-80) (halfHeight w-20) $
|
|
scale 0.2 0.2 $ text $ reverse $ take 5 $ (++ repeat ' ') $ reverse $ show
|
|
$ _crHP $ _creatures w IM.! n
|
|
|
|
wallsForGloom :: World -> [(Point2,Point2,Point2,Point2)]
|
|
wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
|
|
$ filter wallCastsShadow
|
|
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
|
where linePairs (x:y:z:w:_) = (x,y,z,w)
|
|
linePairs (x:y:_) = (x,y,x,y)
|
|
wallCastsShadow wl = case wl ^? wlCastShadow of
|
|
Just b -> b
|
|
Nothing -> True
|
|
--(AutoDoor {_wlCastShadow = b}) = b
|
|
-- wallCastsShadow _ = True
|
|
|
|
wallsForGloom' :: World -> [(Point2,Point2)]
|
|
wallsForGloom' w = map (wallPairBack . _wlLine) $ filter (not . _wlIsSeeThrough)
|
|
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
|
|
|
-- where wallPairBack (x:y:_) = (ss $ x +.+ n,ss $ y+.+ n)
|
|
where wallPairBack (x:y:_) = (x +.+ n,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
|
|
--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
|