Excise streaming

package.yaml

@@ -58,7 +58,7 @@ dependencies:
 - directory
 - extra
 - primitive
-- streaming
+  #- streaming
   #- repa
 - monad-parallel
 - parallel

src/Dodge/Path.hs.orig

@@ -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

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

src/Dodge/Render/ShapePicture.hs.orig

@@ -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

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
 

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 ::

src/Dodge/Zone/Object.hs

@@ -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

src/Geometry/Zone.hs

@@ -1,21 +1,7 @@
---{-# LANGUAGE TupleSections #-}
 module Geometry.Zone
-    ( ddaStreamX
+    ( divTo
-    , ddaStreamY
-    , xIntercepts
-    , yIntercepts
-    , 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

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]