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}
+    OptionScreen { _scOptions = mos, _scDefaultEff = defeff}
-                        -> optionListToEffects defeff scode offset mos
+                        -> 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 :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-zoneOfLineStream = ddaSqStream zoneSize
+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]

src/Geometry/Zone.hs

@@ -3,8 +3,12 @@ module Geometry.Zone
     ( ddaExt
     , ddaExt'
     , ddaSq
-    , ddaSqStream
+--    , ddaSqStream
     , ddaStream
+    , ddaStreamX
+    , ddaStreamY
+    , xIntercepts
+    , yIntercepts
     ) where
 import Geometry.Data
 
@@ -13,6 +17,7 @@ import qualified Streaming.Prelude as S
 import Data.Foldable
 import qualified Data.IntMap.Strict as IM
 import qualified Data.IntSet as IS
+--import Control.Monad
 
 --foldl2'
 --    :: (b -> a -> a -> b) 
@@ -62,6 +67,17 @@ divTo :: Float -> Float -> Int
 {-# INLINE divTo #-}
 divTo s = floor . (/s)
 
+modTo :: Float -> Float -> Float
+modTo s x = x - s * fromIntegral (divTo s x)
+
+--remTo :: Float -> Float -> Float
+--remTo s x = x - s * fromIntegral (quotTo s x)
+--
+--quotTo :: Float -> Float -> Int
+--{-# INLINE quotTo #-}
+--quotTo s = truncate . (/s)
+
+
 --flipV :: Point2 -> Point2
 --{-# INLINE flipV #-}
 --flipV (V2 a b) = V2 b a
@@ -93,13 +109,13 @@ ddaSq s (V2 sx sy) (V2 ex ey) = IM.fromSet (const ys) xs
     xs = IS.fromDistinctAscList [minx-1..maxx+1]
     ys = IS.fromDistinctAscList [miny-1..maxy+1]
 
-ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (Int,Int)) m ()
+--ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (V2 Int)) m ()
-ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [(x,y) | x <- [minx..maxx], y <- [miny..maxy]]
+--ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [V2 x y | x <- [minx..maxx], y <- [miny..maxy]]
-  where
+--  where
-    maxMin a b | a >= b = (a,b)
+--    maxMin a b | a >= b = (a,b)
-        | otherwise = (b,a)
+--        | otherwise = (b,a)
-    (maxx,minx) = maxMin (divTo s sx) (divTo s ex)
+--    (maxx,minx) = maxMin (divTo s sx) (divTo s ex)
-    (maxy,miny) = maxMin (divTo s sy) (divTo s ey)
+--    (maxy,miny) = maxMin (divTo s sy) (divTo s ey)
 
 -- | Determines which horizontal and vertical lines on a grid are crossed by a
 -- line. For each adds the x-y index of the square to the right or above the
@@ -129,8 +145,35 @@ ddaExt' s sp@(V2 sx sy) ep@(V2 ex ey)
         | otherwise = zip (map (divTo s) [y2x,y2x+xdy..])
                          [y2-1 .. y1-1] 
 ddaStream :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
-ddaStream s sp _ -- @(V2 sx sy) ep@(V2 ex ey) 
+ddaStream s sp ep = S.map (sizeZoneOfPoint' s)
-    = S.yield $ sizeZoneOfPoint' s sp
+    $  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 (sizeZoneOfPoint' s) $ xIntercepts s sp ep
+
+ddaStreamY :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
+ddaStreamY s sp ep = S.map (sizeZoneOfPoint' s) $ yIntercepts s sp ep
+
+xIntercepts :: Float -> Point2 -> Point2 -> Stream (Of Point2) Identity ()
+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]
+    | otherwise = S.each $ zipWith V2 [sx'-50,sx'+xdx*50-50..ex-50] [sy',sy'+ydx*50..ey]
+  where
+    xdx = signum (ex - sx)
+    ydx = (ey - sy) / abs (ex - sx)
+
+    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 ()
+yIntercepts s sp ep = S.map f $ xIntercepts s (f sp) (f ep)
+  where
+    f (V2 x y) = V2 y x
+
 
 -- | Determines which horizontal and vertical lines on a grid are crossed by a
 -- line. For each adds the x-y index of the square to the right or above the