diff --git a/src/Dodge/Config/Data.hs b/src/Dodge/Config/Data.hs index 762e2adc4..bee14747c 100644 --- a/src/Dodge/Config/Data.hs +++ b/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) diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index fe0b72164..a337ac3fb 100644 --- a/src/Dodge/Event/Menu.hs +++ b/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 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index bd93d5b19..53d4b80b2 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/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 diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index ad2cb385a..637196b8f 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/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 diff --git a/src/Dodge/Zone.hs b/src/Dodge/Zone.hs index 1ff356c7a..e48247c29 100644 --- a/src/Dodge/Zone.hs +++ b/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] diff --git a/src/Geometry/Zone.hs b/src/Geometry/Zone.hs index 278affd4c..5bf076c6c 100644 --- a/src/Geometry/Zone.hs +++ b/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 s (V2 sx sy) (V2 ex ey) = S.each [(x,y) | x <- [minx..maxx], y <- [miny..maxy]] - where - maxMin a b | a >= b = (a,b) - | otherwise = (b,a) - (maxx,minx) = maxMin (divTo s sx) (divTo s ex) - (maxy,miny) = maxMin (divTo s sy) (divTo s ey) +--ddaSqStream :: Monad m => Float -> V2 Float -> V2 Float -> Stream (Of (V2 Int)) m () +--ddaSqStream s (V2 sx sy) (V2 ex ey) = S.each [V2 x y | x <- [minx..maxx], y <- [miny..maxy]] +-- where +-- maxMin a b | a >= b = (a,b) +-- | otherwise = (b,a) +-- (maxx,minx) = maxMin (divTo s sx) (divTo s ex) +-- (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) - = S.yield $ sizeZoneOfPoint' s sp +ddaStream s sp ep = S.map (sizeZoneOfPoint' 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 (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