228 lines
9.0 KiB
Haskell
228 lines
9.0 KiB
Haskell
module Dodge.Rendering where
|
|
-- imports {{{
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
--import Dodge.Inventory
|
|
|
|
import Dodge.Rendering.HUD
|
|
import Dodge.Rendering.MenuScreen
|
|
|
|
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 w
|
|
, setDepth (-1) $ closeObjectTexts w
|
|
]
|
|
where scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w)
|
|
|
|
worldPictures :: World -> Picture
|
|
worldPictures w
|
|
= pictures $ concat [ IM.elems $ _decorations w
|
|
, map _ptPict . IM.elems $ _projectiles w
|
|
, map drawItem . IM.elems $ _floorItems w
|
|
, map crDraw . IM.elems $ _creatures w
|
|
, map clDraw . IM.elems $ _clouds w
|
|
, map btDraw (IM.elems (_buttons w))
|
|
, map _ptPict' $ _particles' w
|
|
, map drawWallFloor (wallFloorsToDraw w)
|
|
-- , map (drawWallFace w) (wallShadowsToDraw w)
|
|
, testPic w
|
|
]
|
|
|
|
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)
|
|
|
|
|
|
crDraw :: Creature -> Picture
|
|
crDraw c = uncurry translate (_crPos c) $ rotate (_crDir c) (_crPict c c)
|
|
ppDraw :: PressPlate -> Picture
|
|
ppDraw c = uncurry translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
|
btDraw :: Button -> Picture
|
|
btDraw c = uncurry translate (_btPos c) $ rotate (_btRot c) (_btPict c)
|
|
|
|
clDraw :: Cloud -> Picture
|
|
clDraw c = uncurry translate (_clPos c) $ (_clPict c c)
|
|
|
|
|
|
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
|
|
|
|
drawWallFloor :: Wall -> Picture
|
|
drawWallFloor wl = if _wlIsSeeThrough wl
|
|
then setDepth 0.9 . 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 = filter (fromMaybe True . (^? blVisible))
|
|
. IM.elems
|
|
$ wallsNearZones (zoneOfSight w) w
|
|
|
|
-- 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 || _wlIsSeeThrough wall = blank
|
|
| otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points
|
|
where
|
|
(x:y:_) = _wlLine wall
|
|
points = extendConeToScreenEdge w sightFrom (x,y)
|
|
sightFrom = _cameraCenter w
|
|
|
|
-- 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) -> intersectSegLineFrom' x y b (b +.+ b -.- a))
|
|
. 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' y ((2*.*y) -.- x))
|
|
. makeLoopPairs $ screenPolygon w
|
|
|
|
rectangleSolid x y = polygon [(x,y),(x,-y),(-x,-y),(-x,y)]
|
|
|
|
drawItem :: FloorItem -> Picture
|
|
drawItem flIt = uncurry translate (_flItPos flIt)
|
|
$ rotate (_flItRot flIt) (_itFloorPict (_flIt flIt))
|
|
|
|
|
|
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]
|
|
|
|
wallsPointsAndCols :: World -> [((Point2,Point2),Point4)]
|
|
wallsPointsAndCols 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)
|
|
|
|
wallsWindows :: World -> [((Point2,Point2),Point4)]
|
|
wallsWindows w = map f . filter (fromMaybe True . (^? blVisible)) .
|
|
filter _wlIsSeeThrough . IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
|
where linePairs (x:y:_) = (x,y)
|
|
f wl = (linePairs $ _wlLine wl, _wlColor wl)
|
|
|
|
wallsForShadows :: World -> [(Point2,Point2)]
|
|
wallsForShadows w = map (linePairs . _wlLine)
|
|
. filter (not . _wlIsSeeThrough)
|
|
. IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
|
where linePairs (x:y:_) = (x,y)
|
|
|
|
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)
|