503 lines
17 KiB
Haskell
503 lines
17 KiB
Haskell
module Dodge.Render.ShapePicture (
|
|
worldSPic,
|
|
) where
|
|
|
|
import Dodge.Render.Label
|
|
import Dodge.WorldEvent.ThingsHit
|
|
import Control.Lens
|
|
import Data.Foldable
|
|
import qualified Data.Graph.Inductive as FGL
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import qualified Data.Set as Set
|
|
import Dodge.Base
|
|
import Dodge.Creature.Picture
|
|
import Dodge.Creature.Picture.Awareness
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.World
|
|
import Dodge.Debug.Picture
|
|
import Dodge.Draw
|
|
import Dodge.Flare
|
|
import Dodge.GameRoom
|
|
import Dodge.Graph
|
|
import Dodge.Path
|
|
import Dodge.Picture.SizeInvariant
|
|
import Dodge.RadarBlip
|
|
import Dodge.Render.InfoBox
|
|
import Dodge.Render.List
|
|
import Dodge.ShortShow
|
|
import Dodge.SoundLogic.LoadSound
|
|
import Dodge.Update.Camera
|
|
import Dodge.Zoning
|
|
import Dodge.Zoning.Base
|
|
import Geometry
|
|
import Geometry.ConvexPoly
|
|
import qualified IntMapHelp as IM
|
|
import Padding
|
|
import Picture
|
|
import Polyhedra
|
|
import ShapePicture
|
|
import ShortShow
|
|
import Sound.Data
|
|
|
|
singleSPic :: SPic -> SPic
|
|
singleSPic = id
|
|
|
|
worldSPic :: Configuration -> World -> SPic
|
|
worldSPic cfig w =
|
|
singleSPic (mempty, extraPics cfig w)
|
|
<> foldup drawProp' (filtOn _prPos _props)
|
|
<> foldup drawProjectile (filtOn _prjPos _projectiles)
|
|
<> foldup (shiftDraw _blPos _blDir (drawBlock . _blDraw)) (filtOn _blPos _blocks)
|
|
<> foldup (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _foregroundShapes)
|
|
<> foldup (shiftDraw' _cpPos _cpDir _cpSPic) (filtOn _cpPos _corpses)
|
|
<> foldup drawCreature (filtOn _crPos _creatures)
|
|
<> foldup floorItemSPic (filtOn _flItPos _floorItems)
|
|
<> foldup btSPic (filtOn _btPos _buttons)
|
|
<> foldup mcSPic (filtOn _mcPos _machines)
|
|
<> singleSPic (anyTargeting cfig w)
|
|
where
|
|
foldup = foldMap'
|
|
filtOn f g = IM.filter (pointIsClose . f) (g (_lWorld (_cWorld w)))
|
|
pointIsClose = cullPoint cfig w
|
|
|
|
anyTargeting :: Configuration -> World -> SPic
|
|
anyTargeting cfig w = (mempty, pictures $ IM.elems $ IM.mapMaybe f $ _crInv cr)
|
|
where
|
|
cr = you w
|
|
f it = fmap (\g -> drawTargeting g it cr cfig w) (it ^? itTargeting . tgDraw)
|
|
|
|
drawCreature :: Creature -> SPic
|
|
drawCreature cr = case _crType cr of
|
|
Humanoid{} -> basicCrPict cr
|
|
Barreloid{} ->
|
|
picAtCrPos1
|
|
( setDepth 20 $
|
|
pictures
|
|
[ color orange $ circleSolid 10
|
|
, setDepth 0.049 . color (greyN 0.5) $ circleSolid 8
|
|
, color (greyN 0.5) $ circleSolid 8
|
|
]
|
|
)
|
|
cr
|
|
Lampoid{_lampHeight = h} -> picAtCrPosNoRot1 (lampCrPic h) cr
|
|
NonDrawnCreature -> mempty
|
|
|
|
lampCrPic :: Float -> Picture
|
|
lampCrPic h =
|
|
pictures
|
|
[ setLayer BloomLayer (setDepth h . color white $ circleSolid 3)
|
|
, foldMap (polyToTris . map f) $ boxXYZnobase 5 5 (h -1)
|
|
]
|
|
where
|
|
f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] BottomLayer polyNum
|
|
|
|
--DrawnCreature f -> f cr
|
|
--
|
|
picAtCrPosNoRot1 :: Picture -> Creature -> SPic
|
|
--{-# INLINE picAtCrPos #-}
|
|
picAtCrPosNoRot1 thePic cr = (,) mempty $ uncurryV translate (_crPos cr) thePic
|
|
|
|
picAtCrPos1 :: Picture -> Creature -> SPic
|
|
--{-# INLINE picAtCrPos #-}
|
|
picAtCrPos1 thePic cr = (,) mempty $ tranRot (_crPos cr) (_crDir cr) thePic
|
|
|
|
shiftDraw :: (a -> Point2) -> (a -> Float) -> (a -> a -> SPic) -> a -> SPic
|
|
shiftDraw fpos fdir fdraw x =
|
|
uncurryV translateSPf (fpos x)
|
|
. rotateSP (fdir x)
|
|
$ fdraw x x
|
|
|
|
shiftDraw' :: (a -> Point2) -> (a -> Float) -> (a -> SPic) -> a -> SPic
|
|
shiftDraw' fpos fdir fdraw x =
|
|
uncurryV translateSPf (fpos x)
|
|
. rotateSP (fdir x)
|
|
$ fdraw x
|
|
|
|
cullPoint :: Configuration -> World -> Point2 -> Bool
|
|
cullPoint cfig w p
|
|
| debugOn Close_shape_culling cfig = pointInPolygon p (w ^. cWorld . camPos . camBoundBox)
|
|
| otherwise = dist (w ^. cWorld . camPos . camCenter) p < (w ^. cWorld . camPos . camViewDistance)
|
|
|
|
extraPics :: Configuration -> World -> Picture
|
|
extraPics cfig w =
|
|
pictures (_decorations lw)
|
|
<> concatMapPic drawTractorBeam (_tractorBeams lw)
|
|
<> concatMapPic drawLinearShockwave (_linearShockwaves lw)
|
|
<> concatMapPic drawShockwave (_shockwaves lw)
|
|
<> concatMapPic drawLaser (_lasersToDraw lw)
|
|
<> concatMapPic drawTeslaArc (_teslaArcs lw)
|
|
-- <> concatMapPic drawParticle (_particles w)
|
|
<> concatMapPic drawRadarSweep (_radarSweeps lw)
|
|
<> concatMapPic drawFlame (_flames lw)
|
|
<> concatMapPic drawEnergyBall (_energyBalls lw)
|
|
<> concatMapPic drawSpark (_sparks lw)
|
|
<> concatMapPic drawBul (_bullets lw)
|
|
<> concatMapPic drawBlip (_radarBlips lw)
|
|
<> concatMapPic drawFlare (_flares lw)
|
|
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_positronBeams $ _beams lw)
|
|
<> concatMapPic (dbArg (drawBeam . _bmDraw)) (_electronBeams $ _beams lw)
|
|
<> concatMapPic (dbArg (drawLightSource . _lsPict)) (_lightSources lw)
|
|
<> testPic cfig w
|
|
<> concatMapPic clDraw (_clouds lw)
|
|
<> concatMapPic ppDraw (_pressPlates lw)
|
|
<> viewClipBounds cfig w
|
|
<> debugDraw cfig w
|
|
where
|
|
lw = w ^. cWorld . lWorld
|
|
|
|
debugDraw :: Configuration -> World -> Picture
|
|
{-# INLINE debugDraw #-}
|
|
debugDraw cfig w
|
|
| Show_debug `Set.member` _debug_booleans cfig =
|
|
pic
|
|
<> setLayer FixedCoordLayer (listPicturesAt (0.5 * halfWidth cfig) 0 cfig $ map text ts)
|
|
| otherwise = mempty
|
|
where
|
|
pic = foldMap (debugDraw' cfig w) (_debug_booleans cfig)
|
|
ts = map show (Set.toList $ _debug_booleans cfig)
|
|
|
|
debugDraw' :: Configuration -> World -> DebugBool -> Picture
|
|
{-# INLINE debugDraw' #-}
|
|
debugDraw' cfig w bl = case bl of
|
|
Show_debug -> mempty
|
|
Noclip -> mempty
|
|
Remove_LOS -> mempty
|
|
Cull_more_lights -> mempty
|
|
Close_shape_culling -> mempty
|
|
Bound_box_screen -> mempty
|
|
Show_ms_frame -> mempty
|
|
View_boundaries -> viewBoundaries (w ^. cWorld)
|
|
Show_bound_box -> drawBoundingBox w
|
|
Show_wall_search_rays -> drawWallSearchRays w
|
|
Show_dda_test -> drawDDATest w
|
|
Show_far_wall_detect -> drawFarWallDetect w
|
|
Show_select -> drawWorldSelect w
|
|
Inspect_wall -> drawInspectWalls w
|
|
Cr_awareness -> drawCreatureDisplayTexts w
|
|
Show_sound -> pictures $ M.map (soundPic cfig w) $ _playingSounds w
|
|
Cr_status -> drawCrInfo cfig (w ^. cWorld)
|
|
Mouse_position -> drawMousePosition cfig w
|
|
Walls_info -> drawWlIDs cfig w
|
|
Pathing -> drawPathing cfig w
|
|
Show_nodes_near_select -> undefined --drawNodesNearSelect w
|
|
Show_path_between -> drawPathBetween w
|
|
Collision_test -> drawCollisionTest cfig w
|
|
|
|
drawCollisionTest :: Configuration -> World -> Picture
|
|
drawCollisionTest cfig w =
|
|
setLayer DebugLayer (color orange $ line [a,b])
|
|
<> foldMap (drawCross . fst) (crHit a b w)
|
|
<> foldMap (drawCross . _crPos) (crsNearSeg a b w)
|
|
-- <> foldMap (drawZoneCol green crZoneSize) (zoneOfSeg' crZoneSize a b)
|
|
<> foldMap (drawZoneCol green crZoneSize . zoneOfPoint crZoneSize) (xIntercepts crZoneSize a b)
|
|
<> foldMap (drawZoneCol yellow crZoneSize . zoneOfPoint crZoneSize) (yIntercepts' crZoneSize a b)
|
|
<> foldMap (drawLabCrossCol cfig cam blue) (xIntercepts crZoneSize a b)
|
|
where
|
|
(a, b) = _lrLine (_input w)
|
|
cam = w ^. cWorld . camPos
|
|
|
|
drawCreatureDisplayTexts :: World -> Picture
|
|
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (w ^. cWorld . lWorld . creatures)
|
|
|
|
drawPathBetween :: World -> Picture
|
|
drawPathBetween w =
|
|
setLayer DebugLayer $
|
|
color rose (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
|
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
|
|
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
|
|
<> foldMap (color orange . arrow sp) (pointTowardsImpulse sp ep w)
|
|
where
|
|
nodepos = (`getNodePos` w)
|
|
nodelist = makePathBetween sp ep w
|
|
sp = _lSelect (_input w)
|
|
ep = _rSelect (_input w)
|
|
|
|
--drawNodesNearSelect :: World -> Picture
|
|
--drawNodesNearSelect w =
|
|
-- setLayer DebugLayer $
|
|
-- runIdentity (S.foldMap_ (drawZoneCol orange pnZoneSize) (zoneAroundPoint pnZoneSize sp))
|
|
-- <> color green (drawCross sp)
|
|
-- where
|
|
-- sp = _lSelect w
|
|
|
|
drawInspectWalls :: World -> Picture
|
|
drawInspectWalls w =
|
|
setLayer DebugLayer (color orange $ line [a,b]) <>
|
|
foldMap (drawInspectWall w) (
|
|
filter (isJust . uncurry (intersectSegSeg a b) . _wlLine) $
|
|
IM.elems $ w ^. cWorld . lWorld . walls
|
|
)
|
|
where
|
|
(a, b) = _lLine (_input w)
|
|
|
|
drawInspectWall :: World -> Wall -> Picture
|
|
drawInspectWall w wl =
|
|
setLayer DebugLayer $
|
|
color rose (thickLine 3 [a, b])
|
|
<> foldMap (drawDoorPaths w) (wl ^? wlStructure . wsDoor)
|
|
where
|
|
(a, b) = _wlLine wl
|
|
|
|
drawDoorPaths :: World -> Int -> Picture
|
|
drawDoorPaths w drid = fromMaybe mempty $ do
|
|
paths <- w ^? cWorld . lWorld . doors . ix drid . drObstructs
|
|
return $ foldMap' (drawPathEdge . (^. penPathEdge)) paths
|
|
|
|
drawPathEdge :: PathEdge -> Picture
|
|
drawPathEdge pe =
|
|
setLayer DebugLayer $
|
|
multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))
|
|
|
|
obstacleColor :: EdgeObstacle -> Color
|
|
obstacleColor eo = case eo of
|
|
WallObstacle -> cyan
|
|
DoorObstacle -> red
|
|
AutoDoorObstacle -> yellow
|
|
BlockObstacle -> blue
|
|
|
|
drawWorldSelect :: World -> Picture
|
|
drawWorldSelect w =
|
|
setLayer DebugLayer $
|
|
color cyan (line [a, b])
|
|
<> color magenta (line [c, d])
|
|
where
|
|
(a, b) = _lLine (_input w)
|
|
(c, d) = _rLine (_input w)
|
|
|
|
drawFarWallDetect :: World -> Picture
|
|
drawFarWallDetect w =
|
|
setLayer DebugLayer
|
|
. color yellow
|
|
. foldMap
|
|
( \q ->
|
|
line
|
|
[ p
|
|
, fst $ collidePoint p q $ filter wlIsOpaque $ wlsNearSeg p q w
|
|
]
|
|
)
|
|
$ getViewpoints p (_cWorld w)
|
|
-- $ runIdentity $ S.toList_ $ streamViewpoints p w
|
|
where
|
|
p = w ^. cWorld . camPos . camViewFrom
|
|
|
|
drawDDATest :: World -> Picture
|
|
drawDDATest w =
|
|
foldMap (drawZoneCol orange 50) ps
|
|
-- runIdentity (S.foldMap_ (drawZoneCol orange 50) ps)
|
|
-- <> runIdentity (S.foldMap_ (drawZoneCol green 50) ps')
|
|
-- <> runIdentity (S.foldMap_ drawCross qs)
|
|
-- <> color blue (runIdentity (S.foldMap_ drawCross qs'))
|
|
<> setLayer DebugLayer (color yellow (line [cvf, mwp]))
|
|
where
|
|
cvf = w ^. cWorld . camPos . camViewFrom
|
|
mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
|
|
--ps = ddaStreamX 50 cvf mwp
|
|
ps = zoneOfSeg 50 cvf mwp
|
|
|
|
--ps' = ddaStreamY 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
|
|
--qs = xIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
|
|
--qs' = yIntercepts 50 (_cameraViewFrom (_cWorld w)) (mouseWorldPos w)
|
|
|
|
|
|
drawZoneCol :: Color -> Float -> V2 Int -> Picture
|
|
drawZoneCol col s (V2 x y) = setLayer DebugLayer . color col $ thickLine 2 (p : ps ++ [p])
|
|
where
|
|
(p : ps) =
|
|
zipWith (+.+) innerSquare $
|
|
map ((s *.*) . (each %~ fromIntegral)) [V2 x y, V2 (x + 1) y, V2 (x + 1) (y + 1), V2 x (y + 1)]
|
|
|
|
innerSquare :: [Point2]
|
|
innerSquare = [V2 1 1, V2 (-1) 1, V2 (-1) (-1), V2 1 (-1)]
|
|
|
|
drawWallSearchRays :: World -> Picture
|
|
drawWallSearchRays w = foldMap (f . fst) $ allVisibleWalls w
|
|
where
|
|
f p =
|
|
setLayer DebugLayer $
|
|
color yellow $
|
|
uncurryV translate p (circle 5)
|
|
<> line [w ^. cWorld . camPos . camViewFrom , p]
|
|
|
|
testPic :: Configuration -> World -> Picture
|
|
testPic _ _ = mempty
|
|
--testPic cfig _ = setLayer FixedCoordLayer $ listPicturesAt 100 100 cfig $ map centerText
|
|
-- ["A"
|
|
-- ,"AA"
|
|
-- ,"AAA"
|
|
-- ,"AAAA"
|
|
-- ,"AAAAA"
|
|
-- ,"AAAAAA"
|
|
-- ]
|
|
|
|
drawBoundingBox :: World -> Picture
|
|
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x : xs) ++ [x]
|
|
where
|
|
(x : xs) = w ^. cWorld . camPos . camBoundBox
|
|
|
|
clDraw :: Cloud -> Picture
|
|
clDraw c = translate3 (_clPos c) (drawCloud (_clPict c) c)
|
|
|
|
ppDraw :: PressPlate -> Picture
|
|
ppDraw c = uncurryV translate (_ppPos c) $ rotate (_ppRot c) (_ppPict c)
|
|
|
|
floorItemSPic :: FloorItem -> SPic
|
|
floorItemSPic flit =
|
|
uncurryV translateSPf (_flItPos flit) $
|
|
rotateSP (_flItRot flit) (itemSPic (_flIt flit))
|
|
|
|
btSPic :: Button -> SPic
|
|
btSPic bt =
|
|
uncurryV translateSPf (_btPos bt) $
|
|
rotateSP (_btRot bt) (drawButton (_btPict bt) bt)
|
|
|
|
mcSPic :: Machine -> SPic
|
|
mcSPic mc =
|
|
uncurryV translateSPf (_mcPos mc) $
|
|
rotateSP (_mcDir mc) (drawMachine mc)
|
|
|
|
soundPic :: Configuration -> World -> Sound -> Picture
|
|
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig (w ^. cWorld)
|
|
where
|
|
p = _soundPos s
|
|
thePic =
|
|
rotate (w ^. cWorld . camPos . camRot)
|
|
. scale theScale theScale
|
|
. centerText
|
|
. soundToOnomato
|
|
$ _soundChunkID s
|
|
theScale = 0.15 * f (_soundVolume s * 0.0001)
|
|
f x = 1 - 0.5 * (1 - x)
|
|
|
|
drawMousePosition :: Configuration -> World -> Picture
|
|
drawMousePosition cfig w =
|
|
setLayer FixedCoordLayer . winScale cfig
|
|
. uncurryV translate p
|
|
. scale 0.1 0.1
|
|
. text
|
|
$ shortPoint2 mwp
|
|
where
|
|
p = worldPosToScreen (w ^. cWorld . camPos) mwp
|
|
mwp = mouseWorldPos (w ^. input) (w ^. cWorld . camPos)
|
|
|
|
drawWlIDs :: Configuration -> World -> Picture
|
|
drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (w ^. cWorld . lWorld . walls)
|
|
where
|
|
f wl
|
|
| dist (_crPos $ you w) (fst (_wlLine wl)) > 200 = mempty -- this should be improved with a better "on screen test"
|
|
| otherwise =
|
|
winScale cfig
|
|
. uncurryV translate p
|
|
. scale 0.1 0.1
|
|
. text
|
|
$ show $ _wlID wl
|
|
where
|
|
p = worldPosToScreen (w ^. cWorld . camPos) $ 0.5 *.* uncurry (+.+) (_wlLine wl)
|
|
|
|
edgeToPic :: [Point2] -> PathEdge -> Picture
|
|
edgeToPic poly pe
|
|
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
|
|
| otherwise = drawPathEdge pe
|
|
where
|
|
sp = _peStart pe
|
|
ep = _peEnd pe
|
|
|
|
drawPathing :: Configuration -> World -> Picture
|
|
drawPathing cfig w =
|
|
setLayer DebugLayer $
|
|
foldMap (edgeToPic (screenPolygon cfig (w ^. cWorld . camPos)) . (^?! _3)) (FGL.labEdges gr)
|
|
<> foldMap dispInc (graphToIncidence gr)
|
|
where
|
|
dispInc (p, n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
|
gr = w ^. cWorld . lWorld . pathGraph
|
|
|
|
crDisplayInfo :: Configuration -> CamPos -> Creature -> Maybe (Point2, [String])
|
|
crDisplayInfo cfig cam cr
|
|
| _crID cr == 0 = Nothing
|
|
| crOnScreen =
|
|
Just
|
|
( _crPos cr
|
|
, catMaybes
|
|
-- [fmap show $ ap ^? crGoal
|
|
[ fpreShow "crHP" $ cr ^? crHP
|
|
, fpreShow "crStrategy" $ ap ^? apStrategy
|
|
, fmap (("crPos....." ++) . shortShow) $ cr ^? crPos
|
|
, fpreShow "cpVigilance" $ cr ^? crPerception . cpVigilance
|
|
, -- , fmap show $ cr ^? crOldPos
|
|
fpreShow "crAction" $ ap ^? apAction
|
|
, fpreShow "crImpulse" $ ap ^? apImpulse
|
|
]
|
|
)
|
|
| otherwise = Nothing
|
|
where
|
|
ap = _crActionPlan cr
|
|
crOnScreen = pointOnScreen cfig cam $ _crPos cr
|
|
|
|
fpreShow :: (Show a, Functor f) => String -> f a -> f String
|
|
fpreShow str = fmap (((rightPad 7 '.' str ++ "...") ++) . show)
|
|
|
|
drawCrInfo :: Configuration -> CWorld -> Picture
|
|
drawCrInfo cfig w =
|
|
setLayer FixedCoordLayer $
|
|
renderInfoListsAt (2 * hw - 400) 0 cfig cam $
|
|
mapMaybe (crDisplayInfo cfig cam) $ IM.elems $ w ^. lWorld . creatures
|
|
where
|
|
cam = w ^. camPos
|
|
hw = halfWidth cfig
|
|
|
|
viewBoundaries :: CWorld -> Picture
|
|
viewBoundaries w =
|
|
setLayer DebugLayer $
|
|
color green (foldMap (polygonWire . _grBound) grs)
|
|
<> color yellow (foldMap (\q -> line [p, q]) $ farWallPoints p w)
|
|
where
|
|
p = _crPos $ youc w
|
|
grs = filter (pointInOrOnPolygon p . _grBound) (_cwgGameRooms $ _cwGen w)
|
|
|
|
viewClipBounds :: Configuration -> World -> Picture
|
|
viewClipBounds cfig w
|
|
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries =
|
|
setLayer DebugLayer $ color green $ foldMap (polygonWire . _cpPoints) (_cwgRoomClipping $ _cwGen (_cWorld w))
|
|
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries =
|
|
setLayer DebugLayer $ f (_cwgRoomClipping $ _cwGen (_cWorld w))
|
|
| otherwise = mempty
|
|
where
|
|
f (x : xs) = g x xs <> f xs
|
|
f [] = mempty
|
|
g x (y : ys)
|
|
| convexPolysOverlap x y =
|
|
color green (polygonWire $ _cpPoints x)
|
|
<> color yellow (polygonWire $ _cpPoints y)
|
|
<> g x ys
|
|
| otherwise = g x ys
|
|
g _ [] = mempty
|
|
|
|
--wallFloorsToDraw :: World -> [Wall]
|
|
--wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
|
|
-- where
|
|
-- onScreen wall = uncurry (lineOnScreen w) $ _wlLine wall
|
|
-- isVisible wl
|
|
-- | wl ^? wlUnshadowed == Just False = False
|
|
-- | otherwise = onScreen wl
|
|
--
|
|
--lineOnScreen :: World -> Point2 -> Point2 -> Bool
|
|
--lineOnScreen w p1 p2 = pointInPolygon p1 sp
|
|
-- || pointInPolygon p2 sp
|
|
-- || any (isJust . uncurry (intersectSegSeg p1 p2)) sps
|
|
-- where
|
|
-- sp = screenPolygon w
|
|
-- sps = zip sp (tail sp ++ [head sp])
|
|
--
|
|
--drawWallFloor :: Wall -> Picture
|
|
--drawWallFloor wl = if _wlOpacity wl == SeeThrough
|
|
-- 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
|