Files
loop/src/Dodge/Rendering.hs
T

452 lines
20 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 $ hudDrawings w
, scaler $ onLayer MenuLayer menuScreen
, 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'
, wlPicts
, smokeShadows
, 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
smokeShadows = map (drawSmokeShadow w) $ _smoke w
wlPicts = map drawWallFloor (wallFloorsToDraw w)
wlPicts' = map (drawWallFace w) (wallShadowsToDraw 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 = [blank]
-- [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
-- $ 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
wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw 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'
drawWallFloor :: Wall -> Picture
drawWallFloor wl = if _wlIsSeeThrough wl
then onLayerL [levLayer WlLayer] $ color c $ polygon [x,x +.+ n2,y+.+n2, y]
else blank
where
(x:y:_) = _wlLine wl
c = _wlColor wl
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
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])
drawWallFace :: World -> Wall -> Picture
drawWallFace w wall
| isRHS sightFrom x y = blank
| otherwise = colorAndLayer $ polygon $ points
where
colorAndLayer | _wlIsSeeThrough wall = setLayer 2
. onLayerL [levLayer ShadowLayer,3]
. color (withAlpha 0.5 $ _wlColor wall)
| otherwise = setLayer 0
. onLayerL [levLayer ShadowLayer,l]
. color (_wlColor wall)
(x:y:_) = _wlLine wall
points = extendConeToScreenEdge w sightFrom (x,y)
sightFrom = _cameraCenter w
l = case wall of
Door {} -> 1
_ -> 2
-- the following assumes that the point a is inside the screen
-- it still works otherwise, but it might intersect two points:
-- it is not obvious which will be returned
intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen w a b = listToMaybe
. mapMaybe (\(x,y) -> intersectSegLineext x y a b)
. makeLoopPairs
$ screenPolygon w
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' x y)
. makeLoopPairs $ screenPolygon w
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 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
[ 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
[ 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 = _itName $ _flIt flIt
zoom = _cameraZoom w
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),Point4)]
wallsForGloom w = map f $ filter (not . _wlIsSeeThrough)
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where linePairs (x:y:_) = (x,y)
f wl = (linePairs $ _wlLine wl, _wlColor wl)
lightsForGloom' :: World -> [(Point4)]
lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
where getLS ls = ( fst $ _lsPos ls, snd $ _lsPos ls, _lsRad ls , _lsIntensity ls)
getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)