Reorganise rendering in Dodge
This commit is contained in:
@@ -0,0 +1,174 @@
|
||||
module Dodge.Render.HUD
|
||||
where
|
||||
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
import Dodge.Inventory
|
||||
|
||||
import Picture
|
||||
import Geometry
|
||||
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap as IM
|
||||
|
||||
import Control.Lens
|
||||
|
||||
hudDrawings :: World -> Picture
|
||||
hudDrawings w = setLayer 1 . setDepth (-0.5) . pictures $
|
||||
[ scaler . dShadCol white $ displayHP 0 w
|
||||
, scaler . translate (-390) 20 . scale 0.05 0.05 . dShadCol white $ text (_testString w)
|
||||
]
|
||||
++ selectionText
|
||||
where
|
||||
selectionText = if _carteDisplay w
|
||||
then drawLocations w
|
||||
else drawInventory w
|
||||
scaler = scale (2 / _windowX w) (2 / _windowY w)
|
||||
|
||||
drawInventory :: World -> [Picture]
|
||||
drawInventory w =
|
||||
[ closeObjectTexts w
|
||||
, drawListCursor (itCol (yourItem w)) iPos w
|
||||
]
|
||||
++ displayInv 0 w
|
||||
where
|
||||
itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
|
||||
iPos = _crInvSel $ _creatures w IM.! _yourID w
|
||||
|
||||
displayListTopLeft :: [(String,Color)] -> World -> [Picture]
|
||||
displayListTopLeft scols w =
|
||||
map scaler $ zipWith
|
||||
(translate (15-halfWidth w))
|
||||
( map (\x -> halfHeight w - (20 * (fromIntegral x+1))) [0..] )
|
||||
( map (\(s,col) -> scale 0.1 0.1 . dShadCol col $ text s) scols )
|
||||
where
|
||||
scaler = scale (2 / _windowX w) (2 / _windowY w)
|
||||
|
||||
displayInv :: Int -> World -> [Picture]
|
||||
displayInv n w = displayListTopLeft scols w
|
||||
where
|
||||
scols = map itemStringCol . IM.elems . _crInv $ _creatures w IM.! n
|
||||
|
||||
itemStringCol :: Item -> (String,Color)
|
||||
itemStringCol NoItem = ("----", greyN 0.5)
|
||||
itemStringCol itm = (_itInvDisplay itm itm, _itInvColor itm)
|
||||
|
||||
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
|
||||
|
||||
drawLocations :: World -> [Picture]
|
||||
drawLocations w = displayListTopLeft locs w
|
||||
++ zipWith bFunc (displayListEndCoords w locTexts) locPoss
|
||||
++ mapOverlay w
|
||||
++ [drawListCursor white iPos w]
|
||||
where
|
||||
iPos = _selLocation w
|
||||
locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ w
|
||||
locPoss = map (cartePosToScreen w . ($ w) . fst) . IM.elems . _seenLocations $ w
|
||||
zoom = _carteZoom w
|
||||
locTexts = fst . unzip $ locs
|
||||
bFunc (x,y) (z,w) = pictures
|
||||
[ bezierQuad (withAlpha 0.0 white) (withAlpha 0.2 white) 0.050 0.010 (x,y) (0,y) (z,w)
|
||||
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.045 0.005 (x,y) (0,y) (z,w)
|
||||
, bezierQuad (withAlpha 0.0 white) (withAlpha 0.5 white) 0.035 0.002 (x,y) (0,y) (z,w)
|
||||
] --cheapo antialiasing
|
||||
|
||||
displayListCoords :: World -> [Point2]
|
||||
displayListCoords w = map (g . f) [1..]
|
||||
where
|
||||
f i = ( 15 - halfWidth w , halfHeight w - (20 * fromIntegral i) )
|
||||
g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
|
||||
|
||||
displayListEndCoords :: World -> [String] -> [Point2]
|
||||
displayListEndCoords w ss = map g $ zipWith h ss $ map f [1..]
|
||||
where
|
||||
f :: Int -> Point2
|
||||
f i = ( 15 - halfWidth w , 2.5 + halfHeight w - (20 * fromIntegral i) )
|
||||
g (x,y) = (2*x / _windowX w, 2*y / _windowY w)
|
||||
h :: String -> Point2 -> Point2
|
||||
h s (x,y) = (x + 9 * fromIntegral (length s), y)
|
||||
|
||||
--bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
||||
|
||||
mapOverlay :: World -> [Picture]
|
||||
mapOverlay w = (color (withAlpha 0.5 black) . polygon $ rectNSEW 1 (-1) (-1) 1) :
|
||||
(mapMaybe (mapWall w) . IM.elems $ _walls w)
|
||||
|
||||
mapWall :: World -> Wall -> Maybe Picture
|
||||
mapWall w wl =
|
||||
if _wlSeen wl
|
||||
then Just . color c . polygon $ map (cartePosToScreen w) [x,x +.+ n2,y +.+ n2, y]
|
||||
else Nothing
|
||||
where
|
||||
t = normalizeV (y -.- x)
|
||||
-- n2 = 2 *.* vNormal t
|
||||
n2 = 20 *.* vNormal t
|
||||
(x:y:_) = (_wlLine wl)
|
||||
c = _wlColor wl
|
||||
|
||||
|
||||
closeObjectTexts :: World -> Picture
|
||||
closeObjectTexts w = pictures $ (zipWith renderList [0..] $ map colAndText $ _closeActiveObjects w)
|
||||
++ maybeToList maybeLine
|
||||
where colAndText (Left x) = (_itInvColor $ _flIt x, _itName $ _flIt x)
|
||||
colAndText (Right x) = (white, _btText x)
|
||||
renderList i (c,t) = scale (2/_windowX w) (2/_windowY w)
|
||||
. tran
|
||||
. translate (xtran i) (0 - 20 * fromIntegral i)
|
||||
. scale 0.1 0.1
|
||||
. color c
|
||||
$ text t
|
||||
tran = translate (pushout - halfWidth w) (halfHeight w - 20* (fromIntegral invPos +1))
|
||||
youSel = _crInvSel $ you w
|
||||
freeSlot = mayIt >>= \it -> checkInvSlotsYou (_flIt it) w
|
||||
invPos = fromMaybe youSel freeSlot
|
||||
mayObj = listToMaybe $ _closeActiveObjects w
|
||||
mayIt = mayObj >>= maybeLeft
|
||||
maybeLeft (Left x) = Just x
|
||||
maybeLeft _ = Nothing
|
||||
pushout = 140
|
||||
xtran 0 = case mayIt of Nothing -> 25
|
||||
_ -> -25
|
||||
xtran _ = 0
|
||||
objPos obj = case obj of Left flit -> _flItPos flit
|
||||
Right bt -> _btPos bt
|
||||
mayScreenPos = mayObj >>= (\theObj -> Just (worldPosToScreen w $ objPos theObj))
|
||||
sc (x, y) = (x*2/_windowX w, y*2/_windowY w)
|
||||
maybeLine = do
|
||||
itScreenPos <- mayScreenPos
|
||||
theText <- fmap (snd . colAndText) mayObj
|
||||
let textWidth = 9 * fromIntegral (length theText)
|
||||
let col = fromMaybe white $ fmap (_itInvColor . _flIt) mayIt
|
||||
let p = (textWidth + xtran 0 + pushout - halfWidth w
|
||||
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
|
||||
)
|
||||
let p' = ( pushout - halfWidth w + 130
|
||||
, halfHeight w - 20* (fromIntegral invPos +1) + 2.5
|
||||
)
|
||||
return $ lineCol
|
||||
[(itScreenPos, withAlpha 0 col)
|
||||
,(sc p' , col)
|
||||
,(sc p , col)
|
||||
]
|
||||
|
||||
dShadCol :: Color -> Picture -> Picture
|
||||
dShadCol c p = pictures $
|
||||
[ color black $ uncurry translate (1.2,-1.2) p
|
||||
, color c p
|
||||
]
|
||||
|
||||
drawListCursor :: Color -> Int -> World -> Picture
|
||||
drawListCursor c iPos w = scale (2 / _windowX w) (2 / _windowY w)
|
||||
. 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)
|
||||
]
|
||||
|
||||
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
|
||||
|
||||
@@ -0,0 +1,58 @@
|
||||
module Dodge.Render.MenuScreen
|
||||
( menuScreen
|
||||
)
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base (halfWidth,halfHeight)
|
||||
|
||||
import Picture
|
||||
|
||||
menuScreen :: World -> Picture
|
||||
menuScreen w = 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
|
||||
|
||||
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)
|
||||
]
|
||||
|
||||
@@ -0,0 +1,50 @@
|
||||
module Dodge.Render.PerspectiveMatrix
|
||||
where
|
||||
import Dodge.Data
|
||||
|
||||
import Geometry
|
||||
|
||||
import Linear.Matrix
|
||||
import Linear.V4
|
||||
import Graphics.Rendering.OpenGL (GLfloat)
|
||||
|
||||
perspectiveMatrix :: World -> [GLfloat]
|
||||
perspectiveMatrix w =
|
||||
let rot = _cameraRot w
|
||||
zoom = _cameraZoom w
|
||||
(tranx,trany) = _cameraCenter w
|
||||
(winx,winy) = (_windowX w,_windowY w)
|
||||
(viewFromx,viewFromy) = _cameraViewFrom w
|
||||
scalMat = Linear.Matrix.transpose $ V4
|
||||
(V4 (2*zoom/winx) 0 0 (0::GLfloat))
|
||||
(V4 0 (2*zoom/winy) 0 0)
|
||||
(V4 0 0 0.5 0) --scaled to make walls shorter
|
||||
(V4 0 0 0 1)
|
||||
rotMat = Linear.Matrix.transpose $
|
||||
V4 (V4 (cos rot) (sin (-rot)) 0 0)
|
||||
(V4 (sin rot) (cos rot) 0 0)
|
||||
(V4 0 0 1 0)
|
||||
(V4 0 0 0 1)
|
||||
tranMat3 = Linear.Matrix.transpose $
|
||||
V4 (V4 1 0 0 0)
|
||||
(V4 0 1 0 0)
|
||||
(V4 0 0 1 0)
|
||||
(V4 (-tranx) (-trany) 0 1)
|
||||
tranMat2 = Linear.Matrix.transpose $
|
||||
V4 (V4 1 0 0 0)
|
||||
(V4 0 1 0 0)
|
||||
(V4 0 0 1 0)
|
||||
(V4 (viewFromx-tranx) (viewFromy-trany) 0 1)
|
||||
perMat = Linear.Matrix.transpose $
|
||||
V4 (V4 1 0 0 0)
|
||||
(V4 0 1 0 0)
|
||||
(V4 0 0 1 1)
|
||||
(V4 0 0 0 1)
|
||||
tranMat1 = Linear.Matrix.transpose $
|
||||
V4 (V4 1 0 0 0)
|
||||
(V4 0 1 0 0)
|
||||
(V4 0 0 1 0)
|
||||
(V4 (-viewFromx) (-viewFromy) 0 1)
|
||||
wmat = scalMat !*! rotMat !*! tranMat2 !*! perMat !*! tranMat1
|
||||
vToL (V4 a b c d) = [a,b,c,d]
|
||||
in concatMap vToL $ vToL wmat
|
||||
@@ -0,0 +1,207 @@
|
||||
module Dodge.Render.Picture
|
||||
where
|
||||
import Dodge.Data
|
||||
import Dodge.Base
|
||||
|
||||
import Dodge.Render.HUD
|
||||
import Dodge.Render.MenuScreen
|
||||
|
||||
import Geometry
|
||||
import Picture
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
|
||||
worldPictures :: World -> Picture
|
||||
worldPictures w = pictures $ concat
|
||||
[ IM.elems $ _decorations w
|
||||
, map _pjPict . 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 (\pt -> _ptDraw pt pt) $ _particles' w
|
||||
, map drawWallFloor (wallFloorsToDraw w)
|
||||
, testPic w
|
||||
]
|
||||
|
||||
fixedCoordPictures :: World -> Picture
|
||||
fixedCoordPictures w = pictures
|
||||
[ hudDrawings w
|
||||
, scaler . onLayer MenuLayer $ menuScreen w
|
||||
, customMouseCursor w
|
||||
]
|
||||
where
|
||||
scaler = setDepth (-1) . scale (2 / _windowX w) (2 / _windowY w)
|
||||
|
||||
customMouseCursor :: World -> Picture
|
||||
customMouseCursor w =
|
||||
setDepth (-1)
|
||||
. scale (2 /_windowX w) (2/ _windowY w)
|
||||
. uncurry translate (_mousePos w)
|
||||
$ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
|
||||
|
||||
testPic :: World -> [Picture]
|
||||
testPic w = [blank]
|
||||
|
||||
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)
|
||||
|
||||
|
||||
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 +.+ _cameraCenter 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 = _cameraViewFrom w
|
||||
sp | pointInPolygon vp sp' = sp'
|
||||
| otherwise = orderPolygon $ (_cameraViewFrom 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 = _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 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 -.- _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 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 -.- _cameraCenter 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)
|
||||
Reference in New Issue
Block a user