justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Digital line zoning

Browse Source
This commit is contained in:
justin
2022-06-25 14:01:19 +01:00
parent dd0afc6166
commit 81b1fa5b5e
6 changed files with 96 additions and 19 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Config/Data.hs
+1
View File
@@ -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
+3 -4
View File
@@ -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
-1
View File
@@ -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
+35
View File
@@ -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
+4 -4
View File
@@ -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]
src/Geometry/Zone.hs
+53 -10
View File
@@ -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