233 lines
8.2 KiB
Haskell
233 lines
8.2 KiB
Haskell
module Dodge.Render.Picture
|
|
where
|
|
import Dodge.Data
|
|
import Dodge.Base
|
|
import Dodge.Base.Window
|
|
import Dodge.Base.Zone
|
|
import Dodge.Picture
|
|
import Dodge.Picture.Layer
|
|
import Dodge.Render.HUD
|
|
import Dodge.Render.MenuScreen
|
|
--import Dodge.Debug
|
|
import Geometry
|
|
--import Geometry.Zone
|
|
--import Geometry.Data
|
|
import Picture
|
|
import Polyhedra.Data
|
|
|
|
--import Dodge.Creature.YourControl
|
|
|
|
import Control.Lens
|
|
import Data.Maybe
|
|
import Data.List (partition)
|
|
import qualified Data.IntMap.Lazy as IM
|
|
--import qualified Data.Vector.Fusion.Stream.Monadic as VS
|
|
|
|
worldPictures :: World -> Picture
|
|
worldPictures w = pictures
|
|
[pictures (_decorations w)
|
|
,concatMapPic (dbArg _pjDraw) $ _projectiles w
|
|
,concatMapPic (crDraw w) $ _creatures w
|
|
,concatMapPic (dbArg _ptDraw) $ _particles w
|
|
,testPic w
|
|
,concatMapPic drawItem $ _floorItems w
|
|
,concatMapPic (crDraw w) $ _creatures w
|
|
,concatMapPic clDraw $ _clouds w
|
|
,concatMapPic ppDraw $ _pressPlates w
|
|
,concatMapPic btDraw $ _buttons w
|
|
,concatMapPic drawWallFloor $ wallFloorsToDraw w
|
|
]
|
|
|
|
foregroundPics :: World -> [Polyhedra]
|
|
foregroundPics = _foregroundDecorations
|
|
|
|
fixedCoordPictures :: World -> Picture
|
|
fixedCoordPictures w = case _menuLayers w of
|
|
[] -> pictures
|
|
[ hudDrawings w
|
|
, customMouseCursor w
|
|
]
|
|
lays -> scaler . onLayer MenuDepth $ menuScreen (_config w) (halfWidth w) (halfHeight w) lays
|
|
where
|
|
scaler = setDepth (-1) . scale (2 / getWindowX w) (2 / getWindowY w)
|
|
|
|
customMouseCursor :: World -> Picture
|
|
customMouseCursor w =
|
|
scale (2 /getWindowX w) (2/ getWindowY w)
|
|
. uncurryV translate (_mousePos w)
|
|
. color white
|
|
$ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ]
|
|
|
|
testPic :: World -> Picture
|
|
testPic _ = blank
|
|
|
|
-- [ setDepth (-1) . translate 0 0.8
|
|
-- . scale 0.001 0.001 . text . show $ _crMvDir $ you w
|
|
-- ]
|
|
|
|
crDraw :: World -> Creature -> Picture
|
|
crDraw w c = _crPict c c w
|
|
ppDraw :: PressPlate -> Picture
|
|
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
|
btDraw :: Button -> Picture
|
|
btDraw c = uncurryV translate (_btPos c) $ rotate (_btRot c) (_btPict c)
|
|
|
|
clDraw :: Cloud -> Picture
|
|
clDraw c = translate3 (_clPos c) (_clPict c c)
|
|
|
|
wallFloorsToDraw :: World -> [Wall]
|
|
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
|
where
|
|
onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
|
|
isVisible wl
|
|
| wl ^? blVisible == Just False = False
|
|
| otherwise = onScreen wl
|
|
|
|
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 (V2 0 0) = error "problem with function: errorNormalizeVDR in DodgeRendering"
|
|
errorNormalizeVDR p = normalizeV p
|
|
|
|
printPoint :: Point2 -> Picture
|
|
printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)]
|
|
|
|
printRotPoint :: Float -> Point2 -> Picture
|
|
printRotPoint r p = color white
|
|
. uncurryV translate p
|
|
$ pictures [circle 3 , rotate (negate 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
|
|
| otherwise = error "Trying to set screen zoom to zero"
|
|
scTran p = p +.+ _cameraCenter w
|
|
tr = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) ( 3* halfHeight w)
|
|
tl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) ( 3* halfHeight w)
|
|
br = scTran $ scRot $ scZoom $ V2 ( 3*halfWidth w ) (- (3* halfHeight w))
|
|
bl = scTran $ scRot $ scZoom $ V2 (- (3*halfWidth w)) (- (3* 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 -> 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 = _cameraViewFrom w
|
|
sp | pointInPolygon vp sp' = sp'
|
|
| otherwise = orderPolygon (_cameraViewFrom w : sp')
|
|
sps = zip sp (tail sp ++ [head sp])
|
|
|
|
|
|
lineOnScreen :: World -> Point2 -> 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 = _cameraViewFrom 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 :: Float -> Float -> Picture
|
|
rectangleSolid x y = polygon $ map toV2 [(x,y),(x,-y),(-x,-y),(-x,y)]
|
|
|
|
drawItem :: FloorItem -> Picture
|
|
drawItem flit = uncurryV translate (_flItPos flit)
|
|
$ rotate (_flItRot flit) (_itFloorPict (_flIt flit))
|
|
|
|
|
|
ffToDraw :: World -> [ForceField]
|
|
ffToDraw _ = []
|
|
-- filter (lineOnScreen w . _ffLine) $
|
|
-- IM.elems $ over ffLine (map ( -.- _cameraCenter 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
|
|
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]
|
|
col = _ffColor ff
|
|
ypShift = yp -.- _cameraCenter w
|
|
youOnFF = circOnSeg 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]
|
|
wallsAndWindows
|
|
:: World
|
|
-> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)] )
|
|
wallsAndWindows w
|
|
= (map f wls, map f $ filter (fromMaybe True . (^? blVisible)) wins)
|
|
where
|
|
f wl = (_wlLine wl, _wlColor wl)
|
|
(wins,wls) = partition _wlIsSeeThrough . IM.elems $ wallsDoubleScreen w
|
|
|
|
wallsToList :: [((Point2,Point2),Point4)] -> [Float]
|
|
wallsToList = concatMap (\((V2 a b,V2 c d),V4 e f g h) -> [a,b,c,d,e,f,g,h])
|
|
|
|
lightsForGloom :: World -> [(Point3,Float,Point3)]
|
|
lightsForGloom w = mapMaybe getLS (IM.elems $ _lightSources w) ++ mapMaybe getTLS (_tempLightSources w)
|
|
where
|
|
getLS ls
|
|
| dist campos (fst2 $ _lsPos ls) > 1000 = Nothing
|
|
| otherwise = Just ( _lsPos ls, (_lsRad ls)^2 , _lsIntensity ls)
|
|
getTLS ls
|
|
| dist campos (fst2 $ _tlsPos ls) > 1000 = Nothing
|
|
| otherwise = Just ( _tlsPos ls, (_tlsRad ls)^2, _tlsIntensity ls)
|
|
campos = _cameraCenter w
|
|
fst2 (V3 a b _) = V2 a b
|