Digital line zoning

src/Dodge/Config/Data.hs

@@ -40,6 +40,7 @@ data DebugBool
     | Show_bound_box
     | Bound_box_screen
     | Show_wall_search_rays
+    | Show_dda_test
   deriving (Generic, Eq,Ord,Bounded, Enum, Show)
 data ResFactor = FullRes | HalfRes | QuarterRes
   deriving (Generic, Show, Eq, Ord, Enum, Bounded)

src/Dodge/Event/Menu.hs

@@ -16,8 +16,8 @@ import qualified Data.Text as T
 
 handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe)
 handlePressedKeyInMenu mState scode = case mState of
-    OptionScreen { _scOptions = mos, _scDefaultEff = defeff, _scOptionsOffset = offset}
-                        -> optionListToEffects defeff scode offset mos
+    OptionScreen { _scOptions = mos, _scDefaultEff = defeff}
+                        -> optionListToEffects defeff scode mos
     DisplayScreen {}    -> popScreen
     ColumnsScreen {}    -> popScreen
     WaitScreen {}       -> return . Just
@@ -36,10 +36,9 @@ handlePressedKeyInMenu mState scode = case mState of
 optionListToEffects 
     :: (Universe -> IO (Maybe Universe)) 
     -> Scancode
-    -> Int
     -> [MenuOption]
     -> Universe -> IO (Maybe Universe)
-optionListToEffects defaulteff sc offset mops u = case sc of
+optionListToEffects defaulteff sc mops u = case sc of
     ScancodeSpace -> return . Just 
         . (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines)))
         $ u

src/Dodge/Render/MenuScreen.hs

@@ -8,7 +8,6 @@ import Dodge.Base.Window
 import Picture
 import Dodge.Menu
 import Padding
-import Geometry
 
 import qualified Data.Text as T
 

src/Dodge/Render/ShapePicture.hs

@@ -17,6 +17,7 @@ import Dodge.Update.Camera
 import Dodge.Item.Draw
 --import Dodge.Zone
 import Geometry
+import Geometry.Zone
 import ShapePicture
 import Shape
 import Picture
@@ -80,11 +81,45 @@ extraPics cfig w = pictures (_decorations w)
     <> drawCrInfo cfig w
     <> cfigdraw Show_bound_box drawBoundingBox
     <> cfigdraw Show_wall_search_rays (const drawWallSearchRays)
+    <> cfigdraw Show_dda_test (const drawDDATest)
   where
     cfigdraw boption draw
         | debugOn boption cfig = draw cfig w
         | otherwise = mempty
 
+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 $ line (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

src/Dodge/Zone.hs

@@ -84,8 +84,8 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
     f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
     --f (x,y) = [(p,r) | p <-[x-2..x+2] , r<-[y-2..y+2]]
 
-zoneOfLineStream :: Monad m => Point2 -> Point2 -> Stream (Of (Int,Int)) m ()
-zoneOfLineStream = ddaSqStream zoneSize
+zoneOfLineStream :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
+zoneOfLineStream = ddaStream zoneSize
 
 zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
 --{-# INLINE zoneOfLineIntMap #-}
@@ -176,10 +176,10 @@ cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup
 --        Just val -> val
 --        _        -> IM.empty
 
-wallsAlongLineStream :: Monad m => Point2 -> Point2 -> World -> Stream (Of Wall) m ()
+wallsAlongLineStream :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
 wallsAlongLineStream sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep
   where
-    f (i,j) = w ^? wallsZone . znObjects . ix i . ix j
+    f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
 
 wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
 wallsAlongCirc p r w =  IM.unions [f y $ f x $ _znObjects $ _wallsZone w | (x,y) <- zoneOfCircle p r]