From 947752b8d54607b82d3749986044c3c68fc128ff Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 22 Aug 2022 11:23:19 +0100 Subject: [PATCH] Excise streaming --- package.yaml | 2 +- src/Dodge/Path.hs.orig | 250 ----------------- src/Dodge/Projectile/Update.hs | 1 - src/Dodge/Render/ShapePicture.hs.orig | 388 -------------------------- src/Dodge/Update.hs | 1 - src/Dodge/WorldEvent/Cloud.hs | 2 - src/Dodge/Zone/Object.hs | 17 -- src/Geometry/Zone.hs | 69 +---- src/Picture/Data.hs | 3 - 9 files changed, 2 insertions(+), 731 deletions(-) delete mode 100644 src/Dodge/Path.hs.orig delete mode 100644 src/Dodge/Render/ShapePicture.hs.orig delete mode 100644 src/Dodge/Zone/Object.hs diff --git a/package.yaml b/package.yaml index c737b1fbd..d0c96290a 100644 --- a/package.yaml +++ b/package.yaml @@ -58,7 +58,7 @@ dependencies: - directory - extra - primitive -- streaming + #- streaming #- repa - monad-parallel - parallel diff --git a/src/Dodge/Path.hs.orig b/src/Dodge/Path.hs.orig deleted file mode 100644 index ecadf0ef6..000000000 --- a/src/Dodge/Path.hs.orig +++ /dev/null @@ -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 diff --git a/src/Dodge/Projectile/Update.hs b/src/Dodge/Projectile/Update.hs index 6369c25fb..3944210e9 100644 --- a/src/Dodge/Projectile/Update.hs +++ b/src/Dodge/Projectile/Update.hs @@ -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 diff --git a/src/Dodge/Render/ShapePicture.hs.orig b/src/Dodge/Render/ShapePicture.hs.orig deleted file mode 100644 index f895947ff..000000000 --- a/src/Dodge/Render/ShapePicture.hs.orig +++ /dev/null @@ -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 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index b53db7589..b1bfad2ff 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -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 diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index 61291d275..57c6a16e7 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -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 :: diff --git a/src/Dodge/Zone/Object.hs b/src/Dodge/Zone/Object.hs deleted file mode 100644 index bb2250cab..000000000 --- a/src/Dodge/Zone/Object.hs +++ /dev/null @@ -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 diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index 1653a80fb..43d1d1f8e 100644 --- a/src/Geometry/Zone.hs +++ b/src/Geometry/Zone.hs @@ -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 diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 45975161e..37d8c15ea 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -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]