Excise streaming
This commit is contained in:
+1
-1
@@ -58,7 +58,7 @@ dependencies:
|
||||
- directory
|
||||
- extra
|
||||
- primitive
|
||||
- streaming
|
||||
#- streaming
|
||||
#- repa
|
||||
- monad-parallel
|
||||
- parallel
|
||||
|
||||
@@ -1,250 +0,0 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Dodge.Path
|
||||
( pointTowardsImpulse
|
||||
, makePathBetween
|
||||
, makePathBetweenPs
|
||||
<<<<<<< HEAD
|
||||
, pairsToGraph
|
||||
, walkableNodeNear
|
||||
, nodesNearL
|
||||
, getNodePos
|
||||
, addObstacleCrossing'
|
||||
=======
|
||||
-- , removePathsCrossing
|
||||
, obstructPathsCrossing
|
||||
, pairsToGraph
|
||||
, getNodePos
|
||||
, walkableNodeNear
|
||||
>>>>>>> efficientRuntime
|
||||
) where
|
||||
import Dodge.Data
|
||||
import Dodge.Base.Collide
|
||||
import Dodge.Zone
|
||||
import Geometry.Data
|
||||
import Geometry
|
||||
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
--import qualified IntMapHelp as IM
|
||||
import Data.Graph.Inductive hiding ((&))
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
<<<<<<< HEAD
|
||||
import Data.Map.Strict (Map)
|
||||
import qualified Data.Map.Strict as M
|
||||
=======
|
||||
import qualified Data.Map.Strict as M
|
||||
import Data.Map.Strict (Map)
|
||||
import StreamingHelp
|
||||
>>>>>>> efficientRuntime
|
||||
import qualified Streaming.Prelude as S
|
||||
import StreamingHelp
|
||||
--import Data.Graph.Inductive.PatriciaTree
|
||||
--import Data.Graph.Inductive.Graph hiding ((&))
|
||||
|
||||
getNodePos :: Int -> World -> Maybe Point2
|
||||
<<<<<<< HEAD
|
||||
getNodePos i w = _pgGraph (_pathGraph w) `lab` i
|
||||
|
||||
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
|
||||
makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
|
||||
(na,_) <- walkableNodeNear a w
|
||||
(nb,_) <- walkableNodeNear b w
|
||||
sp na nb (second pathDist $ efilter noobstacle $ _pgGraph $ _pathGraph w)
|
||||
where
|
||||
noobstacle (_,_,PathEdge _ _ s) = null s
|
||||
|
||||
pathDist :: PathEdge -> Float
|
||||
pathDist pe = dist (_peStart pe) (_peEnd pe)
|
||||
|
||||
walkableNodeNear :: Point2 -> World -> Maybe (Int,Point2)
|
||||
{-# INLINE walkableNodeNear #-}
|
||||
walkableNodeNear p w = minStreamOn (dist p . snd)
|
||||
. S.filter (flip (isWalkable p) w . snd) $ nodesNear p w
|
||||
|
||||
nodesNear :: Point2 -> World -> StreamOf (Int,Point2)
|
||||
{-# INLINE nodesNear #-}
|
||||
nodesNear = aroundPoint _pnZoning
|
||||
|
||||
nodesNearL :: Point2 -> World -> [(Int,Point2)]
|
||||
nodesNearL p = runIdentity . S.toList_ . nodesNear p
|
||||
=======
|
||||
getNodePos i w = _pathGraph w `lab` i
|
||||
|
||||
makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int]
|
||||
makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
|
||||
na <- walkableNodeNear w a
|
||||
nb <- walkableNodeNear w b
|
||||
sp na nb (second _peDist (_pathGraph w))
|
||||
where
|
||||
--nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
|
||||
-- nodesNear p = runIdentity . S.toList_ $ nearPoint _pnZoning p w
|
||||
-- walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
|
||||
|
||||
walkableNodeNear :: World -> Point2 -> Maybe Int
|
||||
{-# INLINE walkableNodeNear #-}
|
||||
walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
|
||||
where
|
||||
--nodesNear = runIdentity . S.toList_ $ nearPoint _pnZoning p w
|
||||
nodesNear = runIdentity . S.toList_ $ aroundPoint _pnZoning p w
|
||||
>>>>>>> efficientRuntime
|
||||
|
||||
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
|
||||
makePathBetweenPs a b w = mapMaybe (lab $ _pgGraph $ _pathGraph w) <$> makePathBetween a b w
|
||||
|
||||
pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2
|
||||
pointTowardsImpulse a b w = find (flip (isWalkable a) w) =<< makePathBetweenPs a b w
|
||||
|
||||
------ continues a walk from a list of points, without repetitions
|
||||
------ supposes that the list is non-empty
|
||||
--randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int]
|
||||
--randomGraphWalk (n:ns) g = do
|
||||
-- next' <- randomGraphStepRestricted n ns g
|
||||
-- case next' of
|
||||
-- Nothing -> return (n:ns)
|
||||
-- Just n' -> randomGraphWalk (n':n:ns) g
|
||||
--randomGraphWalk _ _ = error "Trying to walk in an empty list"
|
||||
--
|
||||
--randomPointXStepsFrom :: Int -> Point2 -> World -> Point2
|
||||
--randomPointXStepsFrom i p w =
|
||||
-- let g = _pathGraph w
|
||||
-- ns = labNodes g
|
||||
-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
|
||||
-- in case mp of
|
||||
-- Nothing -> p
|
||||
-- Just (n,_) -> fromJust
|
||||
-- $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
|
||||
--
|
||||
--randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2]
|
||||
--randomPointsXStepsFrom i p w =
|
||||
-- let g = _pathGraph w
|
||||
-- ns = labNodes g
|
||||
-- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns
|
||||
-- in case mp of
|
||||
-- Nothing -> [p]
|
||||
-- Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w)
|
||||
--
|
||||
--randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int)
|
||||
--randomGraphStep n g =
|
||||
-- do let ns = neighbors g n
|
||||
-- i <- state $ randomR (0,length ns - 1)
|
||||
-- case ns of [] -> return Nothing
|
||||
-- _ -> return $ Just $ ns !! i
|
||||
--randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int)
|
||||
--randomGraphStepRestricted n notns g = do
|
||||
-- let ns = neighbors g n \\ notns
|
||||
-- i <- state $ randomR (0,length ns - 1)
|
||||
-- case ns of
|
||||
-- [] -> return Nothing
|
||||
-- _ -> return $ Just $ ns !! i
|
||||
--
|
||||
<<<<<<< HEAD
|
||||
|
||||
pairsToGraph :: Set.Set (Point2,Point2) -> PathGraph
|
||||
pairsToGraph pairset = PathGraph gr' nodemap ncount edgemap
|
||||
where
|
||||
(gr,nodemap,ncount) = insertNodes pairset
|
||||
(gr',edgemap) = insertEdges toPathEdge gr nodemap pairset
|
||||
|
||||
toPathEdge :: Point2 -> Point2 -> PathEdge
|
||||
toPathEdge sp' ep = PathEdge sp' ep mempty
|
||||
|
||||
insertEdges :: (Point2 -> Point2 -> b)
|
||||
-> Gr Point2 b -> Map Point2 Int
|
||||
-> Set (Point2,Point2)
|
||||
-> (Gr Point2 b, Map (V2 Point2) (Int,Int,b))
|
||||
insertEdges efunc gr nm = runIdentity . S.fold_ (insertEdge efunc nm) (gr,mempty) id . S.each
|
||||
|
||||
insertEdge :: Ord a => (a -> a -> c) -> Map a Int -> (Gr b c,Map (V2 a) (Int,Int,c))
|
||||
-> (a,a)
|
||||
-> (Gr b c,Map (V2 a) (Int,Int,c))
|
||||
insertEdge efunc nm (gr',em) (a,b) = (insEdge (f a,f b,efunc a b) gr'
|
||||
, M.insert (V2 a b) (f a,f b,efunc a b) em)
|
||||
where
|
||||
f x = nm M.! x
|
||||
|
||||
insertNodes :: Set (Point2,Point2) -> (Gr Point2 b, Map Point2 Int, Int)
|
||||
insertNodes pairset = runIdentity $ S.fold_ insertnode (Data.Graph.Inductive.empty,mempty,0) id nodestream
|
||||
where
|
||||
nodestream :: StreamOf Point2
|
||||
nodestream = S.each . runIdentity $ S.fold_ getnode Set.empty id $ S.each pairset
|
||||
getnode strm (x,y) = Set.insert x $ Set.insert y strm
|
||||
insertnode :: (Gr Point2 b,Map Point2 Int,Int) -> Point2 -> (Gr Point2 b,Map Point2 Int,Int)
|
||||
insertnode (gr,nm,i) n = case M.lookup n nm of
|
||||
Nothing -> (insNode (j,n) gr, M.insert n j nm, j)
|
||||
Just _ -> (gr,nm,i)
|
||||
where
|
||||
j = i + 1
|
||||
|
||||
--pairsToGraph :: (Ord a, Ord b) => (a -> a -> b) -> Set.Set (a,a) -> Gr a b
|
||||
--pairsToGraph f pairs = undir
|
||||
-- $ run_ Data.Graph.Inductive.empty
|
||||
-- $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
|
||||
-- where
|
||||
-- nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
|
||||
-- pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
|
||||
|
||||
addObstacleCrossing :: World -> EdgeObstacle -> Point2 -> Point2
|
||||
-> Gr Point2 PathEdge
|
||||
-> Gr Point2 PathEdge
|
||||
addObstacleCrossing w eo a b gr = runIdentity $ S.fold_ updateedge gr id paths
|
||||
where
|
||||
updateedge gr' (xi,yi,PathEdge x y obs) = insEdge (xi,yi,PathEdge x y (Set.insert eo obs))
|
||||
$ delEdge (xi,yi) gr'
|
||||
paths = S.filter f $ nearSeg _peZoning a b w
|
||||
f (_,_,PathEdge x y _) = isJust $ intersectSegSeg x y a b
|
||||
|
||||
addObstacleCrossing' :: EdgeObstacle -> Point2 -> Point2
|
||||
-> World
|
||||
-> World
|
||||
addObstacleCrossing' eo a b w = w & pathGraph . pgGraph %~ addObstacleCrossing w eo a b
|
||||
=======
|
||||
pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge)
|
||||
pairsToGraph pairs = addEdges nodemap gr $ S.each pairs
|
||||
where
|
||||
(nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs)
|
||||
-- let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs
|
||||
-- pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs
|
||||
-- in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs')
|
||||
|
||||
addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge)
|
||||
addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id
|
||||
where
|
||||
f (nodemap,i,gr) p = case nodemap M.!? p of
|
||||
Just _ -> (nodemap,i,gr)
|
||||
Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr)
|
||||
addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2)
|
||||
-> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge)
|
||||
addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id
|
||||
where
|
||||
f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap
|
||||
, insEdge theedge gr'
|
||||
)
|
||||
where
|
||||
theedge = (g a,g b,PathEdge a b (dist a b) mempty)
|
||||
g a = nodemap M.! a
|
||||
|
||||
obstructPathsCrossing :: Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)])
|
||||
obstructPathsCrossing sp ep w =
|
||||
( w & pathGraph %~ updateedges
|
||||
, runIdentity $ S.toList_ edges
|
||||
)
|
||||
where
|
||||
edges = S.filter edgecrosses $ nearSeg _peZoning sp ep w
|
||||
edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp ep (_peStart pe) (_peEnd pe)
|
||||
updateedges gr = runIdentity $ S.fold_ updateedge gr id edges
|
||||
updateedge gr (x,y,pe)
|
||||
= insEdge (x,y,pe & peObstacles . at BlockObstacle .~ Just ()) $ delEdge (x,y) gr
|
||||
|
||||
removePathsCrossing :: Point2 -> Point2 -> World -> World
|
||||
removePathsCrossing a b w = w
|
||||
-- & pathGraph .~ newGraph
|
||||
-- & pathGraphP .~ pg'
|
||||
-- & phZoning %~ \zn -> foldl' (flip $ updateZoning (:)) (zn & znObjects .~ mempty)
|
||||
-- (labNodes newGraph)
|
||||
-- where
|
||||
-- pg' = Set.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
|
||||
-- -- insertPoint pp@(_,p) = insertInZoneWith (wlZoneOfPoint p) (++) [pp]
|
||||
-- newGraph = pairsToGraph pg'
|
||||
>>>>>>> efficientRuntime
|
||||
@@ -24,7 +24,6 @@ import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import RandomHelp
|
||||
import qualified SDL
|
||||
import qualified Streaming.Prelude as S
|
||||
|
||||
updateProjectile :: Proj -> World -> World
|
||||
updateProjectile pj = case pj of
|
||||
|
||||
@@ -1,388 +0,0 @@
|
||||
module Dodge.Render.ShapePicture
|
||||
( worldSPic
|
||||
) where
|
||||
import Dodge.Creature.Picture.Awareness
|
||||
import Dodge.ShortShow
|
||||
import Dodge.Config.Data
|
||||
import Dodge.Render.InfoBox
|
||||
import Dodge.Debug.Picture
|
||||
import Dodge.Picture.SizeInvariant
|
||||
import Dodge.Data.World
|
||||
import Dodge.Zone
|
||||
import Dodge.Base
|
||||
import Dodge.SoundLogic.LoadSound
|
||||
import Dodge.Graph
|
||||
import Dodge.GameRoom
|
||||
import Dodge.Update.Camera
|
||||
import Dodge.Item.Draw
|
||||
import Dodge.Render.List
|
||||
import Dodge.Path
|
||||
import Geometry
|
||||
import Geometry.Zone
|
||||
import ShapePicture
|
||||
import Picture
|
||||
import Sound.Data
|
||||
import Geometry.ConvexPoly
|
||||
|
||||
import qualified IntMapHelp as IM -- Lazy?
|
||||
import qualified Data.Map.Strict as M
|
||||
--import qualified Data.Set as Set
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import qualified Streaming.Prelude as S
|
||||
import qualified Data.Graph.Inductive as FGL
|
||||
import qualified Data.Set as Set
|
||||
|
||||
-- TODO only filter out shapes outside the range of the furthest shown light source
|
||||
worldSPic :: Configuration -> World -> SPic
|
||||
worldSPic cfig w = (mempty, extraPics cfig w)
|
||||
<> foldMap (dbArg _prDraw) (filtOn _prPos _props)
|
||||
<> foldMap (shiftDraw _blPos _blDir _blDraw) (filtOn _blPos _blocks)
|
||||
<> foldMap (shiftDraw _fsPos _fsDir (const _fsSPic)) (filtOn _fsPos _shapes)
|
||||
<> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
|
||||
<> foldMap (dbArg _crPict) (filtOn _crPos _creatures)
|
||||
<> foldMap floorItemSPic (filtOn _flItPos _floorItems)
|
||||
<> foldMap btSPic (filtOn _btPos _buttons)
|
||||
<> foldMap mcSPic (filtOn _mcPos _machines)
|
||||
<> anyTargeting cfig w
|
||||
where
|
||||
filtOn f g = IM.filter (pointIsClose . f) (g 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 -> g it cr cfig w) (it ^? itTargeting . tgDraw)
|
||||
|
||||
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
|
||||
|
||||
cullPoint :: Configuration -> World -> Point2 -> Bool
|
||||
cullPoint cfig w p
|
||||
| debugOn Close_shape_culling cfig = pointInPolygon p (_boundBox w)
|
||||
| otherwise = dist (_cameraCenter w) p < _viewDistance w
|
||||
|
||||
-- TODO filter out pictures not in the frame
|
||||
extraPics :: Configuration -> World -> Picture
|
||||
extraPics cfig w = pictures (_decorations w)
|
||||
<> concatMapPic (dbArg _ptDraw) (_particles w)
|
||||
<> concatMapPic (dbArg _bmDraw) (_positronBeams $ _beams w)
|
||||
<> concatMapPic (dbArg _bmDraw) (_electronBeams $ _beams w)
|
||||
<> concatMapPic (dbArg _lsPict) (_lightSources w)
|
||||
<> testPic cfig w
|
||||
<> _debugPicture w
|
||||
-- <> runIdentity (S.foldMap_ clDraw (_clouds w))
|
||||
<> concatMapPic clDraw (_clouds w )
|
||||
<> concatMapPic ppDraw (_pressPlates w )
|
||||
<> viewClipBounds cfig w
|
||||
<<<<<<< HEAD
|
||||
<> debugDraw cfig w
|
||||
=======
|
||||
-- <> debugDraw cfig w
|
||||
>>>>>>> efficientRuntime
|
||||
|
||||
debugDraw :: Configuration -> World -> Picture
|
||||
debugDraw cfig w = pic
|
||||
<> setLayer FixedCoordLayer (listPicturesAt (0.5*halfWidth cfig) 0 cfig $ map text ts)
|
||||
where
|
||||
(ts, pic) = foldMap (f . debugDraw' cfig w) (_debug_booleans cfig)
|
||||
f (Left s) = ([s],mempty)
|
||||
f (Right pic') = (mempty,pic')
|
||||
|
||||
debugDraw' :: Configuration -> World -> DebugBool -> Either String Picture
|
||||
debugDraw' cfig w bl = case bl of
|
||||
Noclip -> Left "Noclip"
|
||||
Remove_LOS -> Left "No line of sight"
|
||||
Cull_more_lights -> Left "Cull more lights"
|
||||
Close_shape_culling -> Left "Close shape culling"
|
||||
Bound_box_screen -> Left "bound box screen, this should be moved"
|
||||
Show_ms_frame -> Right mempty
|
||||
View_boundaries -> Right $ viewBoundaries w
|
||||
Show_bound_box -> Right $ drawBoundingBox w
|
||||
Show_wall_search_rays -> Right $ drawWallSearchRays w
|
||||
Show_dda_test -> Right $ drawDDATest w
|
||||
Show_far_wall_detect -> Right $ drawFarWallDetect w
|
||||
Show_select -> Right $ drawWorldSelect w
|
||||
Inspect_wall -> Right $ drawInspectWalls w
|
||||
Cr_awareness -> Right $ drawCreatureDisplayTexts w
|
||||
Show_sound -> Right $ pictures $ M.map (soundPic cfig w) $ _playingSounds w
|
||||
Cr_status -> Right $ drawCrInfo cfig w
|
||||
Mouse_position -> Right $ drawMousePosition cfig w
|
||||
Walls_info -> Right $ drawWlIDs cfig w
|
||||
Pathing -> Right $ drawPathing cfig w
|
||||
Show_nodes_near_select -> Right $ drawNodesNearSelect w
|
||||
Show_path_between -> Right $ drawPathBetween w
|
||||
|
||||
drawCreatureDisplayTexts :: World -> Picture
|
||||
drawCreatureDisplayTexts w = foldMap (creatureDisplayText w) (_creatures w)
|
||||
|
||||
drawPathBetween :: World -> Picture
|
||||
drawPathBetween w = setLayer DebugLayer
|
||||
$ color yellow (foldMap (arrowPath . mapMaybe nodepos) nodelist)
|
||||
<<<<<<< HEAD
|
||||
<> foldMap (color green . arrow sp) (nodepos =<< nodelist ^? _Just . ix 0)
|
||||
<> foldMap (color cyan . flip arrow ep) (nodepos =<< lastOf traverse =<< nodelist ^? _Just)
|
||||
=======
|
||||
<> foldMap (color green . arrow sp) (nodepos =<< walkableNodeNear w sp)
|
||||
<> foldMap (color cyan . flip arrow ep) (nodepos =<< walkableNodeNear w ep)
|
||||
>>>>>>> efficientRuntime
|
||||
where
|
||||
nodepos = (`getNodePos` w)
|
||||
nodelist = makePathBetween sp ep w
|
||||
sp = _lSelect w
|
||||
ep = _rSelect w
|
||||
|
||||
drawNodesNearSelect :: World -> Picture
|
||||
drawNodesNearSelect w = setLayer DebugLayer $
|
||||
runIdentity (S.foldMap_ (drawZone pnZoneSize) (zoneAroundPoint pnZoneSize sp))
|
||||
<<<<<<< HEAD
|
||||
<> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
|
||||
<> color green (drawCross sp)
|
||||
<> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
|
||||
=======
|
||||
-- <> color red (foldMap (drawCross . snd) $ nodesNearL sp w)
|
||||
<> color green (drawCross sp)
|
||||
-- <> color cyan (foldMap (drawCross . snd) $ walkableNodeNear sp w)
|
||||
>>>>>>> efficientRuntime
|
||||
where
|
||||
sp = _lSelect w
|
||||
|
||||
drawInspectWalls :: World -> Picture
|
||||
drawInspectWalls w = foldMap (drawInspectWall w)
|
||||
$ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
|
||||
$ IM.elems $ _walls w
|
||||
where
|
||||
(a,b) = _lLine w
|
||||
|
||||
drawInspectWall :: World -> Wall -> Picture
|
||||
drawInspectWall _ wl = setLayer DebugLayer $
|
||||
color rose (thickLine 3 [a,b])
|
||||
<> foldMap (drawZone wlZoneSize)
|
||||
(runIdentity $ S.toList_ $ zoneOfWall wlZoneSize wl) -- this won't work if wlZoneSize is not consistent
|
||||
where
|
||||
(a,b) = _wlLine wl
|
||||
-- $ line [a,b]
|
||||
-- where
|
||||
-- (a,b) = _wSelect w
|
||||
|
||||
drawWorldSelect :: World -> Picture
|
||||
drawWorldSelect w = setLayer DebugLayer
|
||||
$ color cyan (line [a,b])
|
||||
<> color magenta (line [c,d])
|
||||
where
|
||||
(a,b) = _lLine w
|
||||
(c,d) = _rLine w
|
||||
|
||||
drawFarWallDetect :: World -> Picture
|
||||
drawFarWallDetect w = setLayer DebugLayer
|
||||
. color yellow
|
||||
. concatMap (\q -> line
|
||||
[ p
|
||||
, fst $ collidePoint p q $ S.filter wlIsOpaque $ wlsNearSeg p q w
|
||||
] )
|
||||
$ runIdentity $ S.toList_ $ streamViewpoints p w
|
||||
where
|
||||
p = _cameraViewFrom w
|
||||
|
||||
drawDDATest :: World -> Picture
|
||||
drawDDATest w = runIdentity (S.foldMap_ (drawZone 50) ps)
|
||||
<> runIdentity (S.foldMap_ (drawZone' 50) ps')
|
||||
<> runIdentity (S.foldMap_ drawCross qs)
|
||||
<> color blue (runIdentity (S.foldMap_ drawCross qs'))
|
||||
<> setLayer DebugLayer (color yellow (line [cvf,mwp]))
|
||||
where
|
||||
cvf = _cameraViewFrom w
|
||||
mwp = mouseWorldPos w
|
||||
ps = ddaStreamX 50 cvf mwp
|
||||
ps' = ddaStreamY 50 (_cameraViewFrom w) (mouseWorldPos w)
|
||||
qs = xIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
|
||||
qs' = yIntercepts 50 (_cameraViewFrom w) (mouseWorldPos w)
|
||||
|
||||
drawCross :: Point2 -> Picture
|
||||
drawCross p = setLayer DebugLayer . color red . uncurryV translate p $ crossPic 5
|
||||
|
||||
crossPic :: Float -> Picture
|
||||
crossPic x = line [V2 x x,V2 (-x) (-x)] <> line [V2 (-x) x,V2 x (-x)]
|
||||
|
||||
drawZone :: Float -> V2 Int -> Picture
|
||||
drawZone s (V2 x y) = setLayer DebugLayer . color orange $ 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)]
|
||||
|
||||
drawZone' :: Float -> V2 Int -> Picture
|
||||
drawZone' s (V2 x y) = setLayer DebugLayer . color green $ line (p:ps ++ [p])
|
||||
where
|
||||
(p:ps) = zipWith (+.+) (map (2*.*) 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 = runIdentity $ S.foldMap_ f $ S.map fst $ allVisibleWalls w
|
||||
where
|
||||
f p = setLayer DebugLayer $ color yellow $ uncurryV translate p (circle 5)
|
||||
<> line [_cameraViewFrom w, p]
|
||||
|
||||
testPic :: Configuration -> World -> Picture
|
||||
testPic _ _ = mempty
|
||||
|
||||
drawBoundingBox :: World -> Picture
|
||||
drawBoundingBox w = setLayer DebugLayer $ color green $ line $ (x:xs) ++ [x]
|
||||
where
|
||||
(x:xs) = _boundBox w
|
||||
|
||||
clDraw :: Cloud -> Picture
|
||||
clDraw c = translate3 (_clPos c) (_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) (itSPic (_flIt flit))
|
||||
|
||||
btSPic :: Button -> SPic
|
||||
btSPic bt = uncurryV translateSPf (_btPos bt)
|
||||
$ rotateSP (_btRot bt) (_btPict bt bt)
|
||||
mcSPic :: Machine -> SPic
|
||||
mcSPic bt = uncurryV translateSPf (_mcPos bt)
|
||||
$ rotateSP (_mcDir bt) (_mcDraw bt bt)
|
||||
|
||||
soundPic :: Configuration -> World -> Sound -> Picture
|
||||
soundPic cfig w s = fixedSizePicClampArrow 50 50 thePic p cfig w
|
||||
where
|
||||
p = _soundPos s
|
||||
thePic
|
||||
= rotate (_cameraRot w)
|
||||
. 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 mwp
|
||||
mwp = mouseWorldPos w
|
||||
|
||||
drawWlIDs :: Configuration -> World -> Picture
|
||||
drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
|
||||
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 $ 0.5 *.* uncurry (+.+) (_wlLine wl)
|
||||
|
||||
edgeToPic :: [Point2] -> PathEdge -> Picture
|
||||
edgeToPic poly pe
|
||||
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
|
||||
| null $ _peObstacles pe
|
||||
= anarrow green
|
||||
| hasobstacle BlockObstacle
|
||||
= anarrow red
|
||||
| hasobstacle AutoDoorObstacle = anarrow yellow
|
||||
| otherwise = anarrow cyan
|
||||
where
|
||||
hasobstacle = (`Set.member` _peObstacles pe)
|
||||
anarrow col = color col $ arrow sp ep
|
||||
sp = _peStart pe
|
||||
ep = _peEnd pe
|
||||
|
||||
drawPathing :: Configuration -> World -> Picture
|
||||
drawPathing cfig w = setLayer DebugLayer
|
||||
$ foldMap (edgeToPic (screenPolygon cfig w) . (^?! _3)) (FGL.labEdges gr)
|
||||
<> concatMap dispInc (graphToIncidence gr)
|
||||
where
|
||||
dispInc (p,n) = setDepth 2 . uncurryV translate p . scale 0.1 0.1 $ text $ show n
|
||||
gr = _pgGraph $ _pathGraph w
|
||||
|
||||
crDisplayInfo :: Configuration -> World -> Creature -> Maybe (Point2,[String])
|
||||
crDisplayInfo cfig w cr
|
||||
-- | _crID cr == 0 = Nothing
|
||||
| crOnScreen = Just (_crPos cr, catMaybes
|
||||
-- [fmap show $ ap ^? crGoal
|
||||
[ fmap show $ cr ^? crHP
|
||||
, fmap show $ ap ^? crStrategy
|
||||
, fmap show $ cr ^? crPos
|
||||
, fmap show $ cr ^? crPerception . cpVigilance
|
||||
-- , fmap show $ cr ^? crOldPos
|
||||
, fmap show $ ap ^? crAction
|
||||
, fmap show $ ap ^? crImpulse
|
||||
]
|
||||
)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
ap = _crActionPlan cr
|
||||
crOnScreen = pointOnScreen cfig w $ _crPos cr
|
||||
|
||||
drawCrInfo :: Configuration -> World -> Picture
|
||||
drawCrInfo cfig w = setLayer FixedCoordLayer
|
||||
$ renderInfoListsAt (2*hw - 400) 0 cfig w
|
||||
$ mapMaybe (crDisplayInfo cfig w) $ IM.elems $ _creatures w
|
||||
where
|
||||
hw = halfWidth cfig
|
||||
|
||||
viewBoundaries :: World -> Picture
|
||||
viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
|
||||
<> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
|
||||
where
|
||||
p = _crPos $ you w
|
||||
grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)
|
||||
|
||||
viewClipBounds :: Configuration -> World -> Picture
|
||||
viewClipBounds cfig w
|
||||
| _debug_view_clip_bounds cfig == AllRoomClipBoundaries
|
||||
= setLayer DebugLayer $ color green $ concatMap (polygonWire . _cpPoints) (_roomClipping w)
|
||||
| _debug_view_clip_bounds cfig == IntersectingRoomClipBoundaries
|
||||
= setLayer DebugLayer $ f (_roomClipping w)
|
||||
| otherwise = []
|
||||
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
|
||||
@@ -57,7 +57,6 @@ import Geometry
|
||||
import qualified IntMapHelp as IM
|
||||
import LensHelp
|
||||
import MaybeHelp
|
||||
--import qualified Streaming.Prelude as S
|
||||
import SDL
|
||||
import Sound.Data
|
||||
|
||||
|
||||
@@ -13,8 +13,6 @@ import Dodge.Data.World
|
||||
import Geometry.Data
|
||||
import LensHelp
|
||||
import Picture
|
||||
--import qualified Streaming.Prelude as S
|
||||
--import Control.Lens
|
||||
import System.Random
|
||||
|
||||
makeCloudAt ::
|
||||
|
||||
@@ -1,17 +0,0 @@
|
||||
module Dodge.Zone.Object where
|
||||
|
||||
import Dodge.Data.Creature
|
||||
import Dodge.Data.Wall
|
||||
import Geometry.Data
|
||||
import Geometry.Zone
|
||||
import qualified Streaming.Prelude as S
|
||||
import StreamingHelp
|
||||
|
||||
zoneOfCreature :: Float -> Creature -> StreamOf Int2
|
||||
zoneOfCreature x cr = zoneInsideCirc x (_crPos cr) (_crRad cr)
|
||||
|
||||
zoneOfWall :: Float -> Wall -> StreamOf Int2
|
||||
zoneOfWall x = uncurry (zoneOfSeg x) . _wlLine
|
||||
|
||||
zonePos :: (a -> Point2) -> Float -> a -> StreamOf Int2
|
||||
zonePos f x = S.yield . zoneOfPoint x . f
|
||||
+1
-68
@@ -1,21 +1,7 @@
|
||||
--{-# LANGUAGE TupleSections #-}
|
||||
module Geometry.Zone
|
||||
( ddaStreamX
|
||||
, ddaStreamY
|
||||
, xIntercepts
|
||||
, yIntercepts
|
||||
, divTo
|
||||
( divTo
|
||||
, modTo
|
||||
, zoneOfPoint
|
||||
, zoneOfSeg
|
||||
, zoneInsideCirc
|
||||
, makeInterval
|
||||
) where
|
||||
import Geometry.Data
|
||||
import Geometry.Vector
|
||||
|
||||
import StreamingHelp
|
||||
import qualified Streaming.Prelude as S
|
||||
|
||||
divTo :: Float -> Float -> Int
|
||||
{-# INLINE divTo #-}
|
||||
@@ -31,56 +17,3 @@ modTo s x = x - s * fromIntegral (divTo s x)
|
||||
--quotTo :: Float -> Float -> Int
|
||||
--{-# INLINE quotTo #-}
|
||||
--quotTo s = truncate . (/s)
|
||||
|
||||
zoneOfPoint :: Float -> Point2 -> V2 Int
|
||||
{-# INLINE zoneOfPoint #-}
|
||||
zoneOfPoint s = fmap (divTo s)
|
||||
|
||||
zoneOfRect :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
|
||||
{-# INLINE zoneOfRect #-}
|
||||
zoneOfRect s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
|
||||
where
|
||||
V2 sx sy = zoneOfPoint s sp
|
||||
V2 ex ey = zoneOfPoint s ep
|
||||
|
||||
makeInterval :: Int -> Int -> [Int]
|
||||
makeInterval x y
|
||||
| x < y = [x-1..y+1]
|
||||
| otherwise = [y-1..x+1]
|
||||
|
||||
zoneInsideCirc :: Float -> Point2 -> Float -> StreamOf Int2
|
||||
{-# INLINE zoneInsideCirc #-}
|
||||
zoneInsideCirc x p r = zoneOfRect x (p +.+ V2 r r) (p -.- V2 r r)
|
||||
|
||||
zoneOfSeg :: Float -> Point2 -> Point2 -> StreamOf Int2
|
||||
{-# INLINE zoneOfSeg #-}
|
||||
zoneOfSeg s sp ep = S.map (zoneOfPoint s)
|
||||
$ S.yield sp
|
||||
<> xIntercepts s sp ep
|
||||
<> yIntercepts s sp ep
|
||||
|
||||
ddaStreamX :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
|
||||
ddaStreamX s sp ep = S.map (zoneOfPoint s) $ xIntercepts s sp ep
|
||||
|
||||
ddaStreamY :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
|
||||
ddaStreamY s sp ep = S.map (zoneOfPoint s) $ yIntercepts s sp ep
|
||||
|
||||
xIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
|
||||
{-# INLINE xIntercepts #-}
|
||||
xIntercepts s (V2 sx sy) (V2 ex ey)
|
||||
| xdx == 0 = mempty
|
||||
| xdx > 0 = S.each $ zipWith V2 [sx',sx'+xdx*50..ex] ([sy',sy'+ydx*50..ey] ++ repeat ey)
|
||||
| otherwise = S.each $ zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] ([sy',sy'+ydx*50..ey] ++ repeat ey)
|
||||
where
|
||||
xdx = signum (ex - sx)
|
||||
ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero
|
||||
|
||||
sy' = sy + ydx * abs (sx - sx')
|
||||
sx' | xdx < 0 = sx - modTo s sx
|
||||
| otherwise = s + sx - modTo s sx
|
||||
|
||||
yIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
|
||||
{-# INLINE yIntercepts #-}
|
||||
yIntercepts s sp ep = S.map f $ xIntercepts s (f sp) (f ep)
|
||||
where
|
||||
f (V2 x y) = V2 y x
|
||||
|
||||
@@ -9,7 +9,6 @@ import Control.Lens
|
||||
import Data.Aeson
|
||||
import Data.Aeson.TH
|
||||
import Geometry.Data
|
||||
import Streaming
|
||||
|
||||
data Verx = Verx
|
||||
{ _vxPos :: !Point3
|
||||
@@ -52,8 +51,6 @@ textNum = ShadNum 3
|
||||
arcNum = ShadNum 4
|
||||
ellNum = ShadNum 5
|
||||
|
||||
type Picture' = Stream (Of Verx) IO ()
|
||||
|
||||
type Picture = [Verx]
|
||||
|
||||
flatV2 :: V2 a -> [a]
|
||||
|
||||
Reference in New Issue
Block a user