Fix wall zoning

src/Dodge/Config/Data.hs

@@ -41,6 +41,9 @@ data DebugBool
     | Bound_box_screen
     | Show_wall_search_rays
     | Show_dda_test
+    | Show_far_wall_detect
+    | Show_select
+    | Inspect_wall
   deriving (Generic, Eq,Ord,Bounded, Enum, Show)
 data ResFactor = FullRes | HalfRes | QuarterRes
   deriving (Generic, Show, Eq, Ord, Enum, Bounded)

src/Dodge/Data.hs

@@ -169,9 +169,9 @@ data World = World
     , _genRooms             :: IM.IntMap Room
     , _deathDelay           :: Maybe Int
     , _testFloat            :: Float
+    , _wSelect              :: (Point2,Point2)
     }
 
-
 newtype GenParams = GenParams
     { _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape)
     }
@@ -1405,6 +1405,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
     | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | RandPS (State StdGen PSType)
     | PutShape Shape
+    | PutForeground ForegroundShape
     | PutWorldUpdate (PlacementSpot -> World -> World)
     | PutNothing
     | PutUsingGenParams (World -> (World,PSType))

src/Dodge/Data/ForegroundShape.hs

@@ -9,7 +9,7 @@ data ForegroundShape = ForegroundShape
     { _fsID :: Int
     , _fsPos :: Point2
     , _fsDir :: Float
-    , _fsRad :: Float
+    , _fsRad :: Float  -- This should probably be a bounding box
     , _fsSPic :: SPic
     }
   deriving (Eq,Show,Ord)

src/Dodge/Default/World.hs

@@ -110,6 +110,7 @@ defaultWorld = World
     , _testFloat = 0
     , _boundBox = square 100
     , _boundDist = (100,-100,100,-100)
+    , _wSelect      = (0,0)
     }
 youLight :: TempLightSource
 youLight = TLS 

src/Dodge/Floor.hs

@@ -41,10 +41,10 @@ initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
         $ intersperse (AnTree corDoor)
     [ IntAnno $ AnTree . startRoom
-    , AnRoom slowDoorRoom
+--    , AnRoom slowDoorRoom
-    , AnRoom $ roomCCrits 10
+--    , AnRoom $ roomCCrits 10
-    , AnTree firstBreather
+--    , AnTree firstBreather
-    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
+--    , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward
     ]
 
 extraAnoList :: [Annotation]

src/Dodge/Initialisation.hs

@@ -41,6 +41,6 @@ initialWorld = defaultWorld
     }
 
 testStringInit :: Configuration -> World -> [String]
-testStringInit _ _ = mempty
+testStringInit _ w = [show $ _boundDist w]
 --testStringInit = map (show . _drStatus) . IM.elems . _doors
 --testStringInit = const . const [] 

src/Dodge/Placement/PlaceSpot.hs

@@ -96,6 +96,7 @@ placeSpotID ps pt w = case pt of
     PutTerminal tm          -> plNewUpID terminals tmID tm w
     PutFlIt     itm         -> plNewUpID floorItems flItID (createFlIt p rot itm) w
     PutCrit     cr          -> plNewUpID creatures crID (mvCr p rot cr) w
+    PutForeground fs        -> plNewUpID shapes fsID (mvFS p rot fs) w
     PutMachine  pps mc      -> plMachine (map doShift pps) mc p rot w
     PutLS       ls          -> plNewUpID lightSources lsID (mvLS p' rot ls) w
     PutPPlate   pp          -> plNewUpID pressPlates ppID (mvPP p rot pp) w
@@ -172,6 +173,9 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
 mvCr :: Point2 -> Float -> Creature -> Creature
 mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
 
+mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape
+mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a ))
+
 plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
 plMachine wallpoly mc p rot gw = (mcid
     , gw & machines  %~ addMc

src/Dodge/Render/ShapePicture.hs

@@ -7,6 +7,7 @@ import Dodge.Render.InfoBox
 import Dodge.Debug.Picture
 import Dodge.Picture.SizeInvariant
 import Dodge.Data
+import Dodge.Zone
 import Dodge.Base
 --import Dodge.Base.Window
 import Dodge.SoundLogic.LoadSound
@@ -14,6 +15,7 @@ import Dodge.Graph
 import Dodge.GameRoom
 import Dodge.Update.Camera
 import Dodge.Item.Draw
+import Dodge.Wall.Zone
 --import Dodge.Zone
 import Geometry
 import Geometry.Zone
@@ -34,9 +36,11 @@ import qualified Streaming.Prelude as S
 worldSPic :: Configuration -> World -> SPic
 worldSPic cfig w = 
     (extraShapes w, extraPics 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 (\fs -> uncurryV translateSPf (_fsPos fs) . rotateSP (_fsDir fs) $ _fsSPic fs) (_shapes w)
     <> foldMap (dbArg _cpPict) (filtOn _cpPos _corpses)
     <> foldMap ((($ w) . ($ cfig)) . dbArg _crPict) (filtOn _crPos _creatures)
     <> foldMap floorItemSPic (filtOn _flItPos _floorItems)
@@ -51,7 +55,6 @@ 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)
@@ -72,20 +75,55 @@ extraPics cfig w = pictures (_decorations w)
     <> concatMapPic clDraw (_clouds w      )
     <> concatMapPic ppDraw (_pressPlates w )
     <> soundPics cfig w
-    <> viewBoundaries cfig w
     <> viewClipBounds cfig w
     <> drawMousePosition cfig w
     <> drawWallIDs cfig w
     <> drawPathing cfig w
     <> drawCrInfo cfig w
+    <> cfigdraw View_boundaries (const viewBoundaries)
     <> cfigdraw Show_bound_box (const drawBoundingBox)
     <> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
     <> cfigdraw Show_dda_test (const drawDDATest)
+    <> cfigdraw Show_far_wall_detect (const drawFarWallDetect)
+    <> cfigdraw Show_select          (const drawWorldSelect)
+    <> cfigdraw Inspect_wall         (const drawInspectWalls)
   where
     cfigdraw boption draw
         | debugOn boption cfig = draw cfig w
         | otherwise = mempty
 
+drawInspectWalls :: World -> Picture
+drawInspectWalls w = foldMap (drawInspectWall w) 
+    $ filter (isJust . uncurry (intersectSegSeg a b) . _wlLine)
+    $ IM.elems $ _walls w
+  where
+    (a,b) = _wSelect w
+
+drawInspectWall :: World -> Wall -> Picture
+drawInspectWall _ wl = setLayer DebugLayer $ 
+        color rose (thickLine 3 [a,b])
+    <> foldMap (drawZone zoneSize)
+        (runIdentity $ S.toList_ $ zoneOfWall wl)
+  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]
+  where
+    (a,b) = _wSelect w
+
+drawFarWallDetect :: World -> Picture
+drawFarWallDetect w = setLayer DebugLayer . color yellow 
+    . concatMap (\q -> line [p,q]) 
+    . map (\q -> fst $ collidePoint p q $ S.filter wlIsOpaque $ wallsAlongLine 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')
@@ -107,7 +145,7 @@ 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 $ line (p:ps ++ [p])
+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)]
 
@@ -235,12 +273,9 @@ drawCrInfo cfig w
   where
     hw = halfWidth cfig
 
-viewBoundaries :: Configuration -> World -> Picture
+viewBoundaries :: World -> Picture
-viewBoundaries cfig w
+viewBoundaries w = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
-    | debugOn View_boundaries cfig 
+    <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
-        = setLayer DebugLayer $ color green (concatMap (polygonWire . _grBound) grs)
-        <> color yellow (concatMap (\q -> line [p,q]) $ farWallPoints p w)
-    | otherwise = []
   where
     p = _crPos $ you w
     grs = filter (pointInOrOnPolygon p . _grBound) (_gameRooms w)

src/Dodge/Room/Foreground.hs

@@ -5,8 +5,12 @@ import Geometry
 import Shape
 import Quaternion
 
+import Dodge.Data.ForegroundShape
+import Dodge.Default.Foreground
 import Data.List
 import Data.Maybe
+import Control.Lens
+import ShapePicture
 
 highDiagonalMesh
     :: Point2 
@@ -111,6 +115,25 @@ girderVCapLR csize h d w x y = thinHighBar h (x -.- n) (x +.+ n)
   where
     n = csize *.* vNormal (normalizeV (x -.- y))
 
+girderV'
+    :: Float -- ^ "cap" size
+    -> Float -- ^ height
+    -> Float -- ^ distance between cross bars
+    -> Float -- ^ width
+    -> Point2 -> Point2 -> ForegroundShape
+girderV' csize h d w x y = defaultForeground
+    & fsPos .~ m
+    & fsRad .~ dist m x'
+    & fsSPic .~ noPic sh
+  where
+    m = midPoint x y
+    x' = x - m
+    y' = y - m
+    sh = thinHighBar h (x' -.- n) (x' +.+ n)
+        <> thinHighBar h (y' -.- n) (y' +.+ n)
+        <> girderV h d w x' y'
+    n = csize *.* vNormal (normalizeV (x' -.- y'))
+
 girderV 
     :: Float -- ^ height
     -> Float -- ^ distance between cross bars

src/Dodge/Room/Modify/Girder.hs

@@ -151,13 +151,13 @@ addGirderLights rm = do
         midw = wiToFloat rm midi
         extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis
         extragirders = mapMaybe (\(i,hi) -> case i of
-            x | x < 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) 
+            x | x < 0 -> Just $ girderV' 20 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) 
                                                 (V2 0 (hiToFloat rm hi))
-            x | x > 0 -> Just $ girderVCapL 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) 
+            x | x > 0 -> Just $ girderV' 20 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) 
                                                 (V2 w (hiToFloat rm hi))
             _ -> Nothing
             ) extragirderpos
     return $ rm & rmPmnts .++~ 
-        (sps0 (PutShape $ colorSH black $ girderVCapLR 20 96 20 10 (V2 midw 0) (V2 midw h))
+        (sps0 (PutForeground $ girderV' 20 96 20 10 (V2 midw 0) (V2 midw h))
         : map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps
-        ) ++ map (sps0 . PutShape . colorSH black) extragirders
+        )  ++ map (sps0 . PutForeground) extragirders

src/Dodge/Update.hs

@@ -35,6 +35,7 @@ import Control.Applicative
 --import Data.Monoid
 --import System.Random
 import qualified Streaming.Prelude as S
+import SDL
 --import Streaming
 
 {- For most menus the only way to change the world is using event handling.  -}
@@ -57,6 +58,7 @@ functionalUpdate cfig w = checkEndGame
 --    . updateRandGen
     . (mouseButtons . each .~ True)  -- to determine if the mouse button is held
     . (worldClock +~ 1)
+    . updateWorldSelect
     . doRewind
     . (doubleMouseHammer %~ moveHammerUp)
     . updateDistortions
@@ -100,6 +102,11 @@ functionalUpdate cfig w = checkEndGame
       where 
         (x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
 
+updateWorldSelect :: World -> World
+updateWorldSelect w = case w ^? mouseButtons . ix ButtonLeft of
+    Nothing     -> w
+    Just False  -> w & wSelect . _1 .~ mouseWorldPos w
+    Just True   -> w & wSelect . _2 .~ mouseWorldPos w
 
 mcChooseUpdate :: Machine -> Machine -> World -> World
 mcChooseUpdate mc mc'

src/Dodge/Update/Camera.hs

@@ -4,7 +4,7 @@ and the position that the character sees from: '_cameraViewFrom'.  -}
 module Dodge.Update.Camera 
     ( updateCamera
     , farWallPoints
---    , streamViewpoints
+    , streamViewpoints
     , farWallDistDirection
     ) where
 import Dodge.Data

src/Dodge/Wall/Zone.hs

@@ -6,19 +6,26 @@ import Dodge.Zone
 import Dodge.Base
 
 import Control.Lens
-import Data.Foldable
+--import Data.Foldable
+import Streaming
+import qualified Streaming.Prelude as S
 
-zoneOfWall :: Wall -> [(Int,Int)]
+zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity ()
-zoneOfWall wl 
+zoneOfWall = uncurry zoneOfLineStream . _wlLine
-    | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
+--    | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
-    | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
+--    | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
-  where
+--  where
-    wlline = _wlLine wl
+--    wlline = _wlLine wl
 
 insertWallInZones :: Wall -> World -> World
 insertWallInZones wl = wallsZone . znObjects
-    %~ flip (foldl' (flip $ \(a,b) -> insertIMInZone a b (_wlID wl) wl)) (zoneOfWall wl)
+    %~ (runIdentity . (\wlzns -> S.fold_ doinsert wlzns id (zoneOfWall wl)))
+  where
+    doinsert wlzns (V2 x y) = insertIMInZone x y (_wlID wl) wl wlzns
 
 deleteWallFromZones :: Wall -> World -> World
 deleteWallFromZones wl = wallsZone . znObjects 
-    %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)
+    %~ (runIdentity . (\wlzns -> S.fold_ dodelete wlzns id (zoneOfWall wl)))
+  where
+    dodelete wlzns (V2 x y) = deleteIMInZone x y (_wlID wl) wlzns
+--    %~ flip (foldl' (flip $ \(a,b) -> deleteIMInZone a b (_wlID wl))) (zoneOfWall wl)

src/Dodge/Zone.hs

@@ -13,6 +13,7 @@ module Dodge.Zone
     , zoneAroundPoint
     , floorHun
     , zoneOfLine
+    , zoneOfLineStream
     , wallsDoubleScreen
     , cloudZoneOfPoint
     , cloudsNearPoint
@@ -86,6 +87,7 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
     --f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]]
 
 zoneOfLineStream :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
+--zoneOfLineStream = ddaSqStream zoneSize
 zoneOfLineStream = ddaStream zoneSize
 
 zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet

src/Geometry/Zone.hs

@@ -3,7 +3,7 @@ module Geometry.Zone
     ( ddaExt
     , ddaExt'
     , ddaSq
---    , ddaSqStream
+    , ddaSqStream
     , ddaStream
     , ddaStreamX
     , ddaStreamY
@@ -144,6 +144,17 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey)
                          [y1 .. y2] 
         | otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
                          [y2-1 .. y1-1] 
+ddaSqStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
+ddaSqStream s sp ep = S.each [V2 x y | x <- makeInterval sx ex, y <- makeInterval sy ey]
+  where
+    V2 sx sy = sizeZoneOfPoint' s sp
+    V2 ex ey = sizeZoneOfPoint' s ep
+
+makeInterval :: Int -> Int -> [Int]
+makeInterval x y
+    | x < y = [x-1..y+1]
+    | otherwise = [y-1..x+1]
+
 ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
 ddaStream s sp ep = S.map (sizeZoneOfPoint' s)
     $  S.yield sp
@@ -160,11 +171,11 @@ 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]
+    | 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]
+    | 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)
+    ydx = (ey - sy) / abs (ex - sx) -- carefull: if this is zero
 
     sy' = sy + ydx * abs (sx - sx')
     sx' | xdx < 0 = sx - modTo s sx