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

Continue to refactor zoning to be more stream-based

Browse Source
This commit is contained in:
justin
2022-06-28 03:21:55 +01:00
parent f6d96ec92c
commit e06527091e
34 changed files with 214 additions and 252 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+1 -1
View File
@@ -128,7 +128,7 @@ mvPointToward !ep !p
| otherwise = p +.+ normalizeV (ep -.- p)
vecBetweenSpeed :: Float -> Point2 -> Point2 -> Point2
vecBetweenSpeed s sp ep
vecBetweenSpeed !s !sp !ep
| dist sp ep < s = ep -.- sp
| otherwise = s *.* normalizeV (ep -.- sp)
src/Dodge/Block.hs
+1 -1
View File
@@ -32,7 +32,7 @@ unshadowBlock wlid w = case w ^? walls . ix wlid of
& walls . ix wlid . wlDraw .~ True
& wallsZone . znObjects . ix x . ix y . ix wlid . wlDraw .~ True
where
(x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
V2 x y = wallZoneOfPoint $ uncurry midPoint (_wlLine wl)
Nothing -> w
checkBlockHP :: Block -> World -> World
src/Dodge/Data.hs
+1 -1
View File
@@ -1454,7 +1454,7 @@ data Room = Room
-> Room -- ^ parent room
-> Room
, _rmPos :: [RoomPos]
, _rmPath :: [(Point2, Point2)]
, _rmPath :: S.Set (Point2, Point2)
, _rmPmnts :: [Placement]
, _rmInPmnt :: [InPlacement]
, _rmOutPmnt :: [OutPlacement]
src/Dodge/Debug.hs
+1 -1
View File
@@ -61,6 +61,6 @@ debugWallZoningPic w = setLayer BloomLayer $ zonesPic `appendPic` wallsPic
$ wallsAlongLine sp ep w
drawTheWall (a,b) = thickLine 20 [a,b]
zonesPic = setDepth 20 $ drawDDA zones
zones = ddaExt zoneSize sp ep
zones = ddaExt wallZoneSize sp ep
sp = _crPos $ you w
ep = mouseWorldPos w
src/Dodge/Default/Room.hs
+10 -10
View File
@@ -8,20 +8,20 @@ import qualified Data.Set as S
defaultRoom :: Room
defaultRoom = Room
{ _rmPolys = []
, _rmLinks = []
{ _rmPolys = mempty
, _rmLinks = mempty
, _rmLinkEff = const . const . const . const id
, _rmPos = []
, _rmPath = []
, _rmPmnts = []
, _rmInPmnt = []
, _rmOutPmnt = []
, _rmBound = []
, _rmPos = mempty
, _rmPath = mempty
, _rmPmnts = mempty
, _rmInPmnt = mempty
, _rmOutPmnt = mempty
, _rmBound = mempty
, _rmFloor = InheritFloor
, _rmName = "defaultRoom"
, _rmShift = (V2 0 0 , 0)
, _rmViewpoints = []
, _rmRandPSs = []
, _rmViewpoints = mempty
, _rmRandPSs = mempty
-- , _rmLabel = Nothing
-- , _rmTakeFrom = Nothing
, _rmStartWires = IM.empty
src/Dodge/Graph.hs
+4 -3
View File
@@ -14,13 +14,14 @@ import Data.Graph
import Data.Maybe
import qualified Data.Graph.Inductive.Graph as F
import qualified Data.Graph.Inductive.PatriciaTree as F
import qualified Data.Set as S
import Data.Bifunctor
pairsToIncidence :: Ord a => [(a,a)] -> [(a,[a])]
pairsToIncidence :: Ord a => S.Set (a,a) -> [(a,[a])]
pairsToIncidence
= map (first head . unzip)
. groupOn fst
. sort
. S.toAscList -- TODO check that the lexicographic sorting is correct for groupOn fst
incidenceToFunction :: Eq a => [(a,[a])] -> a -> [a]
incidenceToFunction xs a = fromMaybe [] $ lookup a xs
@@ -28,7 +29,7 @@ incidenceToFunction xs a = fromMaybe [] $ lookup a xs
mkNode :: (a,[a]) -> (a,a,[a])
mkNode (x,xs) = (x,x,xs)
pairsToSCC :: Ord a => [(a,a)] -> [SCC a]
pairsToSCC :: Ord a => S.Set (a,a) -> [SCC a]
pairsToSCC = stronglyConnComp . map mkNode . pairsToIncidence
graphToEdges :: forall a b . F.Gr a b -> [(a,a)]
src/Dodge/Item/Weapon/SonicGuns.hs
+32 -31
View File
@@ -84,37 +84,38 @@ drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDe
mvSonicWave :: World -> Particle -> (World, Maybe Particle)
mvSonicWave w pt
| _ptTimer pt <= 0 = (w,Nothing)
| otherwise = (w, Just pt')
where
mvPointDir (p,a) = case wallsHit p ep w of
[] -> Just ((ep, a), (True,True))
(hp,wl):_ -> reflectShockLine wl p hp ep
where
ep = p +.+ 5 *.* unitVectorAtAngle a
dividePointDir (x:y:xs) = f x y ++ dividePointDir (y:xs)
dividePointDir xs = xs
f (p,a) (q,b)
| dist p q > 10 = [(p,a),(0.5 *.* (p +.+ q),mixAngles 0.5 a b)]
| otherwise = [(p,a)]
combineClose ((p,a):(q,b):pairs)
| dist p q < 5 = combineClose (( 0.5 *.* (p+.+q), mixa) : pairs)
| otherwise = (p,a) : combineClose ((q,b):pairs)
where
mixa = mixAngles 0.5 a b
combineClose pairs = pairs
pt' = pt & ptTimer -~ 10
-- & ptPointDirs %~ (map dividePointDir . filter (not . null) . dosplit . map mvPointDir)
& ptPointDirs %~ (map (dividePointDir . combineClose) . filter (not . null)
. concatMap (dosplit . map mvPointDir))
-- & ptPointDirs %~ (filter (not . null) . concatMap (dosplit . map mvPointDir))
dosplit :: [Maybe ((Point2,Float),(Bool,Bool))] -> [[(Point2,Float)]]
dosplit (x:xs) = case x of
Nothing -> [] : dosplit xs
Just (pair,(True,True)) -> overHead (pair:) $ dosplit xs
Just (pair,(False,True)) -> [] : overHead (pair:) (dosplit xs)
Just (pair,(True,False)) -> [pair] : dosplit xs
Just (_,(False,False)) -> [] : dosplit xs
dosplit [] = [[]]
| otherwise = (w, Just $ pt & ptTimer -~ 1)
-- | otherwise = (w, Just pt')
-- where
-- mvPointDir (p,a) = case wallsHit p ep w of
-- [] -> Just ((ep, a), (True,True))
-- (hp,wl):_ -> reflectShockLine wl p hp ep
-- where
-- ep = p +.+ 5 *.* unitVectorAtAngle a
-- dividePointDir (x:y:xs) = f x y ++ dividePointDir (y:xs)
-- dividePointDir xs = xs
-- f (p,a) (q,b)
-- | dist p q > 10 = [(p,a),(0.5 *.* (p +.+ q),mixAngles 0.5 a b)]
-- | otherwise = [(p,a)]
-- combineClose ((p,a):(q,b):pairs)
-- | dist p q < 5 = combineClose (( 0.5 *.* (p+.+q), mixa) : pairs)
-- | otherwise = (p,a) : combineClose ((q,b):pairs)
-- where
-- mixa = mixAngles 0.5 a b
-- combineClose pairs = pairs
-- pt' = pt & ptTimer -~ 10
-- -- & ptPointDirs %~ (map dividePointDir . filter (not . null) . dosplit . map mvPointDir)
-- & ptPointDirs %~ (map (dividePointDir . combineClose) . filter (not . null)
-- . concatMap (dosplit . map mvPointDir))
-- -- & ptPointDirs %~ (filter (not . null) . concatMap (dosplit . map mvPointDir))
-- dosplit :: [Maybe ((Point2,Float),(Bool,Bool))] -> [[(Point2,Float)]]
-- dosplit (x:xs) = case x of
-- Nothing -> [] : dosplit xs
-- Just (pair,(True,True)) -> overHead (pair:) $ dosplit xs
-- Just (pair,(False,True)) -> [] : overHead (pair:) (dosplit xs)
-- Just (pair,(True,False)) -> [pair] : dosplit xs
-- Just (_,(False,False)) -> [] : dosplit xs
-- dosplit [] = [[]]
overHead :: (a -> a) -> [a] -> [a]
overHead f (x:xs) = f x: xs
src/Dodge/Item/Weapon/UseEffect.hs
+4 -3
View File
@@ -14,6 +14,7 @@ import LensHelp
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Streaming.Prelude as S
{- | Creates an outwardly increasing circle that draws creatures, even those behind walls. -}
aSonarPulse :: Creature -> World -> World
aSonarPulse = aRadarPulse crBlips (blipAt 8) (withAlpha 0.2 green)
@@ -122,9 +123,9 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems
f q = dist p q <= r && dist p q > r - 4
wallBlips :: Point2 -> Float -> World -> [Point2]
wallBlips p r w = mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
$ map (over wlLine swp) (IM.elems $ wallsAlongCirc p r w)
++ IM.elems (wallsAlongCirc p r w)
wallBlips p r w = runIdentity . S.toList_ $ S.mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine)
$ S.map (over wlLine swp) (wallsAlongCirc' p r w)
<> wallsAlongCirc' p r w
where
swp (a,b) = (b,a)
src/Dodge/Layout.hs
+1 -2
View File
@@ -21,7 +21,6 @@ import qualified IntMapHelp as IM
import Tile
import RandomHelp
import qualified Data.Set as S
import Data.List (nubBy)
import Data.Traversable
import Control.Lens
@@ -47,7 +46,7 @@ generateLevelFromRoomList gr' w = initWallZoning
}
where
path = pairsToGraph dist pairPath
pairPath = S.fromList $ concatMap _rmPath rs
pairPath = foldMap _rmPath rs
rs = map doRoomShift $ IM.elems rs'
rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w
src/Dodge/Path.hs
+2 -2
View File
@@ -27,7 +27,7 @@ makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w)
nb <- walkableNodeNear b
sp na nb (_pathGraph w)
where
nodesNear p = concat $ lookLookups (zoneAroundPoint p) (_pathPoints w)
nodesNear p = concat $ lookLookups (zoneNearPointIP p) (_pathPoints w)
walkableNodeNear p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear p
makePathBetweenPs :: Point2 -> Point2 -> World -> Maybe [Point2]
@@ -92,5 +92,5 @@ removePathsCrossing a b w = w
& pathPoints .~ foldr insertPoint IM.empty (labNodes newGraph)
where
pg' = S.filter (isNothing . uncurry (intersectSegSeg a b)) $ _pathGraphP w
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
insertPoint pp@(_,p) = uncurryV insertInZoneWith (wallZoneOfPoint p) (++) [pp]
newGraph = pairsToGraph dist pg'
src/Dodge/Placement/PlaceSpot/Block.hs
+4 -3
View File
@@ -43,13 +43,14 @@ addBlock (p:ps) wl bl w = w
}
) is lns
wallInZone wl'
| uncurry dist (_wlLine wl') <= 2*zoneSize
| uncurry dist (_wlLine wl') <= 2*wallZoneSize
= insertIMInZone x y wlid wl'
| otherwise = flip (foldl' $ flip (\(a,b) -> insertIMInZone a b wlid wl')) ips
where
(x,y) = zoneOfPoint $ uncurry midPoint (_wlLine wl)
V2 x y = wallZoneOfPoint $ uncurry midPoint (_wlLine wl)
wlid = _wlID wl
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
ips = map (unv2 . wallZoneOfPoint) $ uncurry (divideLine (2*wallZoneSize)) (_wlLine wl)
unv2 (V2 x y) = (x,y)
addBlock _ _ _ _ = error "Trying to add a block with incomplete polygon"
placeBlock :: [Point2] -> Block -> Wall -> World -> (Int,World)
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -108,7 +108,7 @@ drawInspectWalls w = foldMap (drawInspectWall w)
drawInspectWall :: World -> Wall -> Picture
drawInspectWall _ wl = setLayer DebugLayer $
color rose (thickLine 3 [a,b])
<> foldMap (drawZone zoneSize)
<> foldMap (drawZone wallZoneSize)
(runIdentity $ S.toList_ $ zoneOfWall wl)
where
(a,b) = _wlLine wl
src/Dodge/Render/Walls.hs
+6 -2
View File
@@ -10,6 +10,7 @@ import ShapePicture
import Control.Lens
--import Data.Maybe
import qualified Control.Foldl as L
import qualified Streaming.Prelude as S
--import Data.List
--import qualified Data.IntMap.Strict as IM
wallsToDrawStreams
@@ -20,11 +21,14 @@ wallsToDrawStreams cfig w
= ( wls, wins,spic)
where
f wl = (_wlLine wl, _wlColor wl)
(wls, wins, spic) = L.fold ((,,)
(wls, wins, spic) = runIdentity $ L.purely S.fold_
((,,)
<$> L.prefilter wlOpaqueDraw (L.premap f L.list)
<*> L.prefilter wlSeeThroughDraw (L.premap f L.list)
<*> L.premap getWallSPic L.mconcat
) (wallsDoubleScreen cfig w)
) (S.concat $ S.mapMaybe g $ zoneOfSight wallZoneSize w)
g (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
wlOpaqueDraw :: Wall -> Bool
wlOpaqueDraw wl = wlIsOpaque wl && _wlDraw wl
wlSeeThroughDraw :: Wall -> Bool
src/Dodge/Room/Airlock.hs
+5 -8
View File
@@ -24,7 +24,7 @@ airlock0 :: Room
airlock0 = defaultRoom
{ _rmPolys = [ rectNSWE 100 0 0 40 , switchcut]
, _rmLinks = muout lnks ++ muin [last lnks]
, _rmPath = [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPath = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ]
, _rmPmnts =
[pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red id id)
$ \btid -> Just $ putDoubleDoorThen thewall (not . cond' btid) 1 (V2 0 20) (V2 40 20) 2
@@ -49,7 +49,7 @@ airlockSimple = defaultRoom
{ _rmPolys =
[ rectNSWE 120 0 0 180 ]
, _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks]
, _rmPath = concatMap (doublePair. (V2 90 30,) . fst) lnks
, _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
, _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps)
@@ -72,7 +72,7 @@ airlockZ = defaultRoom
{ _rmPolys =
[ rectNSWE 120 0 0 180 ]
, _rmLinks = muout[(V2 0 30,pi/2)] ++ muin[(V2 180 30,1.5*pi) ]
, _rmPath = []
, _rmPath = mempty
-- [(V2 0 40,V2 40 0)
-- ,(V2 40 0,V2 0 40)
-- ]
@@ -109,10 +109,7 @@ airlock90 = defaultRoom
]
]
, _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(V2 40 0,pi) ]
, _rmPath =
[(V2 0 40,V2 40 0)
,(V2 40 0,V2 0 40)
]
, _rmPath = doublePairSet (V2 0 40,V2 40 0)
, _rmPmnts =
[ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss
@@ -137,7 +134,7 @@ airlockCrystal :: Room
airlockCrystal = defaultRoom
{ _rmPolys = [ rectNSWE 140 0 0 40 , switchcutout ]
, _rmLinks = muout[(V2 20 130,0) ] ++ muin[(V2 20 0 ,pi) ]
, _rmPath = [ ]
, _rmPath = mempty
, _rmPmnts =
[pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss
src/Dodge/Room/BlinkAcross.hs
+1 -1
View File
@@ -44,7 +44,7 @@ blinkAcrossChallenge = do
emptyCorridor :: Room
emptyCorridor = corridor & rmPolys .~ []
& rmPath .~ []
& rmPath .~ mempty
& rmPmnts .~ []
& rmRandPSs .~ [psRandRanges (10,30) (30,60) (0,2*pi)]
& rmName .~ "WalledCorridor"
src/Dodge/Room/Boss.hs
+3 -3
View File
@@ -92,7 +92,7 @@ roomCross x y = defaultRoom
] ++
[uncurry inLink (V2 (y-20) (-x),pi)
]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts =
[ spanLightI (V2 (x+5) x) (V2 (x+5) (-x))
, spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x))
@@ -118,7 +118,7 @@ roomShuriken x y =
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 (x-1) (y-20),negate $ pi/2)]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
, _rmBound = ps
}
@@ -143,7 +143,7 @@ roomTwistCross x y z =
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [toBothLnk (V2 z (y-20), pi/2)]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
, _rmBound = map (expandPolyCorners 10) ps
}
src/Dodge/Room/Corridor.hs
+7 -6
View File
@@ -20,7 +20,7 @@ corridor :: Room
corridor = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = lnks'
, _rmPath = concatMap (doublePair . (,) (V2 20 60) . fst) lnks
, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks
, _rmPmnts = [ spanLightI (V2 0 39.5) (V2 40 39.5) ]
, _rmBound = [ rectNSWE 50 30 (-5) 45 ]
, _rmFloor = Tiled [makeTileFromPoly poly 2]
@@ -43,7 +43,7 @@ corridor = defaultRoom
]
keyholeCorridor :: Room
keyholeCorridor = corridor
{ _rmPath = []
{ _rmPath = mempty
, _rmPmnts =
[ midWall $ rectNSWE top bot 15 0
, midWall $ rectNSWE top bot 40 25]
@@ -65,7 +65,7 @@ corridorN = defaultRoom
where lnks = [uncurry outLink (V2 20 70 ,0)
,uncurry inLink (V2 20 10 ,pi)
]
pth = doublePair (V2 20 70,V2 20 10)
pth = doublePairSet (V2 20 70,V2 20 10)
corridorWallN :: Room
corridorWallN = defaultRoom
{ _rmPolys = [rectNSWE 70 0 0 40
@@ -79,15 +79,16 @@ corridorWallN = defaultRoom
lnks = [uncurry outLink(V2 20 70 ,0)
,uncurry inLink(V2 20 10 ,pi)
]
pth = doublePair (V2 20 70,V2 20 10)
pth = doublePairSet (V2 20 70,V2 20 10)
-- this should be combined with tWest
tEast :: Room
tEast = defaultRoom
{ _rmPolys = [rectNSWE 80 0 (-20) 20
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks'
, _rmPath = concatMap (doublePair . (,) (V2 0 60) . fst) lnks
, _rmPath = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tEast"
@@ -109,7 +110,7 @@ tWest = defaultRoom
,rectNSWE 80 40 (-40) 40
]
, _rmLinks = lnks
, _rmPath = concatMap (doublePair . (V2 0 60 ,) . _rlPos) lnks
, _rmPath = foldMap (doublePairSet . (V2 0 60 ,) . _rlPos) lnks
, _rmPmnts = []
, _rmBound = [ rectNSWE 70 10 0 40 ]
, _rmName = "tWest"
src/Dodge/Room/Door.hs
+2 -2
View File
@@ -18,7 +18,7 @@ door :: Room
door = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = init lnks ++ [last lnks]
, _rmPath = [(V2 20 35,V2 20 5)]
, _rmPath = doublePairSet (V2 20 35,V2 20 5)
-- door extends into side walls (for shadows as rendered 12/03)
, _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
, _rmName = "autoDoor"
@@ -33,7 +33,7 @@ triggerDoorRoom :: Int -> Room
triggerDoorRoom inplid = defaultRoom
{ _rmPolys = [rectNSWE 40 0 0 40]
, _rmLinks = [uncurry outLink (V2 20 35,0) ,uncurry inLink(V2 20 5,pi) ]
, _rmPath = [(V2 20 35,V2 20 5)]
, _rmPath = doublePairSet (V2 20 35,V2 20 5)
, _rmInPmnt = [InPlacement f inplid]
, _rmName = "triggerDoorRoom"
-- door extends into side walls (for shadows as rendered 12/03/21)
src/Dodge/Room/Link.hs
+3 -3
View File
@@ -22,7 +22,7 @@ import Data.Tile
import Dodge.RoomLink
import Control.Lens
--import qualified Data.Set as S
import qualified Data.Set as S
restrictRMInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room
restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f
@@ -40,7 +40,7 @@ shiftRoomBy :: (Point2,Float) -> Room -> Room
shiftRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ map (shiftPathBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmShift %~ shiftPosDirBy shift
& rmFloor . tiles %~ map
@@ -54,7 +54,7 @@ moveRoomBy :: (Point2,Float) -> Room -> Room
moveRoomBy shift r = r
& rmPolys %~ fmap (map (shiftPointBy shift))
& rmLinks %~ fmap (shiftLinkBy shift)
& rmPath %~ map (shiftPathBy shift)
& rmPath %~ S.map (shiftPathBy shift)
& rmBound %~ fmap (map (shiftPointBy shift))
& rmPmnts %~ map (shiftPlacement shift)
& rmFloor . tiles %~ map
src/Dodge/Room/LongDoor.hs
+1 -1
View File
@@ -43,7 +43,7 @@ twinSlowDoorRoom w h x = defaultRoom
[ (V2 w (h/2) , negate $ pi/2)
, (V2 (-w) (h/2) , pi/2) ]
++ [uncurry inLink (V2 0 (-h), pi) ]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h))
src/Dodge/Room/Ngon.hs
+1 -1
View File
@@ -19,7 +19,7 @@ roomNgon :: Int -> Float -> Room
roomNgon n x = defaultRoom
{ _rmPolys = [poly]
, _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks]
, _rmPath = [] -- TODO
, _rmPath = mempty -- TODO
, _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk]
, _rmBound = [poly]
, _rmFloor = Tiled [makeTileFromPoly poly 9]
src/Dodge/Room/Path.hs
+5 -5
View File
@@ -19,6 +19,7 @@ import Data.Bifunctor
import Data.Maybe
import qualified Data.Tuple.Extra as Tup
import qualified Control.Foldl as L
import qualified Data.Set as S
createPathGrid :: Room -> Room
createPathGrid rm = rm
@@ -35,13 +36,12 @@ createPathGrid rm = rm
<*> L.premap sndV2 L.minimum
<*> L.premap sndV2 L.maximum
-- ?TODO? : make this minimumOn
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks
where
linkClosest (p,_) = doublePair (p, minimumBy (compare `on` dist p) $ map fst subpth)
linkClosest (p,_) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth)
linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> S.Set (Point2,Point2)
linksAndPath' = linksAndPath . map lnkPosDir
testCrossWalls
src/Dodge/Room/Procedural.hs
+6 -6
View File
@@ -49,7 +49,7 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmName = "rect"
, _rmPath = concatMap doublePair pth
, _rmPath = foldMap doublePairSet pth
--, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
-- ++ map (roomposat (RoomPosOffPath S.empty)) interposps
, _rmPos = map makeonpos posps'
@@ -86,7 +86,7 @@ roomRect x y xn yn = defaultRoom
++ m South (FromEdge West) (FromEdge East) slnks
m edge edgefrom1 edgefrom2 = zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0..]
. zipCountDown
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn)
makeonpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0
makerpedges (a,b) = S.fromList
[PathFromEdge South b
@@ -131,7 +131,7 @@ combineRooms :: Room -> Room -> Room
combineRooms r r' = defaultRoom
{ _rmPolys = _rmPolys r ++ _rmPolys r'
, _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmPath = map clampPath $ _rmPath r ++ _rmPath r'
, _rmPath = S.map clampPath $ _rmPath r <> _rmPath r'
, _rmPmnts = _rmPmnts r ++ _rmPmnts r'
, _rmBound = _rmBound r ++ _rmBound r'
, _rmPos = _rmPos r ++ _rmPos r'
@@ -163,7 +163,7 @@ quarterRoomTri w = do
pure $ defaultRoom
{ _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ]
, _rmLinks = [toBothLnk (V2 0 w, 0)]
, _rmPath = concatMap doublePair
, _rmPath = foldMap doublePairSet
[(V2 0 w,V2 0 (w-20))
,(V2 0 (w-20),V2 (w-20) (w-20))
,(V2 0 (w-20),V2 (55-w) (w-20))
@@ -199,7 +199,7 @@ quarterRoomSquare w = do
[ (V2 (w/2) (3*w/2), negate $ pi/4)
, (V2 (negate $ w/2) (3*w/2), pi/4)
]
, _rmPath = concatMap doublePair
, _rmPath = foldMap doublePairSet
[(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20))
,(V2 (-0.5*w) (1.5*w),V2 (-0.5*w+20) (1.5*w-20))
,(V2 0 (2*w-40),V2 (-0.5*w+20) (1.5*w-20))
@@ -249,7 +249,7 @@ centerVaultRoom w h d = return $ defaultRoom
,outLink (V2 w 0) (-pi/2)
,outLink (V2 (-w) 0) (pi/2)
, inLink (V2 0 (-h)) pi ]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts =
[sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d ) defaultWall
,sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (-d)) defaultWall
src/Dodge/Room/RoadBlock.hs
+1 -1
View File
@@ -35,7 +35,7 @@ litCorridor90 = do
, _rmLinks =
[ outLink (V2 40 (h - 80)) (-pi/2)
, inLink (V2 20 0 ) pi ]
, _rmPath = concatMap doublePair
, _rmPath = foldMap doublePairSet
[( V2 20 0 , V2 20 (h-40) )
,( V2 0 (h-40) , V2 20 (h-40) )
,( V2 40 (h-40) , V2 20 (h-40) )
src/Dodge/Room/Room.hs
+2 -2
View File
@@ -60,7 +60,7 @@ roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom
{ _rmPolys = [ps]
, _rmLinks = muout [(p,0)] ++ muin [(V2 0 0,pi)]
, _rmPath = [(V2 0 0,p)]
, _rmPath = doublePairSet (V2 0 0,p)
}
branchWith :: Room -> [Tree Room] -> Tree Room
@@ -220,7 +220,7 @@ deadEndRoom :: Room
deadEndRoom = defaultRoom
{ _rmPolys = [rectNSWE 40 (-20) (-20) 20 ]
, _rmLinks = muout (init lnks) ++ muin [last lnks]
, _rmPath = []
, _rmPath = mempty
, _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
, _rmName = "deadEndRoom"
src/Dodge/Room/Treasure.hs
+1 -1
View File
@@ -27,7 +27,7 @@ triLootRoom w h = pure $ defaultRoom
, base
]
, _rmLinks = [uncurry inLink(V2 0 (-80) , pi)]
, _rmPath = doublePair (V2 0 (-80) , V2 0 (h/2))
, _rmPath = doublePairSet (V2 0 (-80) , V2 0 (h/2))
, _rmPmnts =
[sPS (V2 (15-w) 15 ) 0 $ PutID 0
,sPS (V2 (w-15) 15 ) pi $ PutID 0
src/Dodge/Update.hs
+6 -6
View File
@@ -366,14 +366,14 @@ crSpring c w = IM.foldl' (flip $ crCrSpring c) w cs
cs = creaturesNearPoint (_crPos c) w
crCrSpring :: Creature -> Creature -> World -> World
crCrSpring c1 c2 w
| id1 == id2 = w
| vec == V2 0 0 = w
| diff >= comRad = w
| otherwise = over creatures
crCrSpring c1 c2
| id1 == id2 = id
| vec == V2 0 0 = id
| diff >= comRad = id
| otherwise = creatures %~
( over (ix id1 . crPos) (+.+ overlap1)
. over (ix id2 . crPos) (-.- overlap2)
) w
)
where
id1 = _crID c1
id2 = _crID c2
src/Dodge/Update/Camera.hs
-6
View File
@@ -221,12 +221,6 @@ gameRoomViewpoints p gr = S.each (_grViewpoints gr)
farWallDistDirection :: Point2 -> World -> Maybe (Float,Float,Float,Float)
farWallDistDirection p w = boundPoints
-- runIdentity $ L.purely S.fold_ ((,,,)
-- <$> L.premap (^?! _2) L.maximum
-- <*> L.premap (^?! _2) L.minimum
-- <*> L.premap (^?! _1) L.maximum
-- <*> L.premap (^?! _1) L.minimum
-- )
$ S.map f vps
where
f q = runIdentity (S.fold_ findPoint q (rotateV (negate $ _cameraRot w) . (-.- p)) (wls q))
src/Dodge/Wall/Zone.hs
+1 -5
View File
@@ -11,11 +11,7 @@ import Streaming
import qualified Streaming.Prelude as S
zoneOfWall :: Wall -> Stream (Of (V2 Int)) Identity ()
zoneOfWall = uncurry zoneOfLineStream . _wlLine
-- | uncurry dist wlline <= 2*zoneSize = [zoneOfPoint $ uncurry midPoint wlline ]
-- | otherwise = map zoneOfPoint $ uncurry (divideLine zoneSize) wlline
-- where
-- wlline = _wlLine wl
zoneOfWall = uncurry (zoneOfSeg wallZoneSize) . _wlLine
insertWallInZones :: Wall -> World -> World
insertWallInZones wl = wallsZone . znObjects
src/Dodge/WorldEvent/ThingsHit.hs
+16 -16
View File
@@ -4,7 +4,7 @@ Find which objects lie upon a line.
-}
module Dodge.WorldEvent.ThingsHit
( thingsHit
, wallsHit
-- , wallsHit
, thingHit
, thingsHitExceptCr
)
@@ -57,18 +57,18 @@ thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep
crNotCid (_,Left cr) = _crID cr /= cid
crNotCid _ = True
wallsHit
:: Point2 -- ^ Line start point
-> Point2 -- ^ Line end point
-> World
-> [(Point2, Wall)]
wallsHit sp ep w
| sp == ep = []
| otherwise = sortOn (dist sp . fst) wls
where
wls = IM.elems $ wallsOnLineHit sp ep
$ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
| a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- $ _walls w
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i = fromMaybe IM.empty . IM.lookup i
--wallsHit
-- :: Point2 -- ^ Line start point
-- -> Point2 -- ^ Line end point
-- -> World
-- -> [(Point2, Wall)]
--wallsHit sp ep w
-- | sp == ep = []
-- | otherwise = sortOn (dist sp . fst) wls
-- where
-- wls = IM.elems $ wallsOnLineHit sp ep
-- $ IM.unions [f b $ f a $ _znObjects $ _wallsZone w
-- | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- -- $ _walls w
-- V2 x y = wallZoneOfPoint (0.5 *.* (sp +.+ ep))
-- f i = fromMaybe IM.empty . IM.lookup i
src/Dodge/Zone.hs
+76 -106
View File
@@ -1,25 +1,19 @@
module Dodge.Zone
( crZoneOfPoint
, zoneOfLineIntMap
, wallsNearPoint
, wallsNearPoint'
, wallsAlongLine
, zoneSize
, zoneOfPoint
, wallsAlongCirc
, wallsAlongCirc'
, wallsOnScreen
, lookLookups
, zoneAroundPoint
, floorHun
, zoneOfLine
, zoneOfLineStream
, wallsDoubleScreen
, zoneOfSeg
, zoneNearPointIP
, cloudZoneOfPoint
, cloudsNearPoint
, wallsNearZones
, wallZoneSize
, zoneOfSight
, flattenIMIMIM
, wallZoneOfPoint
, creaturesNearPointI
, creaturesNearPoint
, creatureNearPoint
@@ -28,11 +22,12 @@ module Dodge.Zone
)
where
import Dodge.Data
import Dodge.Base.Window
--import Dodge.Base.Window
import Geometry
import Geometry.Zone
import qualified FoldlHelp as L
import qualified Data.Set as Set
import qualified Streaming.Prelude as S
import Streaming
import Data.Maybe
@@ -45,103 +40,93 @@ import Control.Lens
--flattenZones :: Zone (IM.IntMap a) -> IM.IntMap a
--flattenZones = flattenIMIMIM . _znObjects
zoneSize :: Float
zoneSize = 50
floorHun :: Float -> Int
floorHun x = floor $ x / zoneSize
wallZoneSize :: Float
wallZoneSize = 50
sizeZoneOfPoint :: Float -> Point2 -> (Int,Int)
sizeZoneOfPoint s (V2 x y) = (f x, f y)
where
f = floor . (/ s)
zoneOfPoint :: Point2 -> (Int,Int)
zoneOfPoint (V2 x y) = (floorHun x, floorHun y)
wallZoneOfPoint :: Point2 -> V2 Int
wallZoneOfPoint (V2 x y) = V2 (divTo wallZoneSize x) (divTo wallZoneSize y)
cloudZoneOfPoint :: Point2 -> (Int,Int)
cloudZoneOfPoint = sizeZoneOfPoint 20
creatureZoneSize :: Float
creatureZoneSize = 15
crZoneOfPoint :: Point2 -> (Int,Int)
crZoneOfPoint = sizeZoneOfPoint 15
crZoneOfPoint = sizeZoneOfPoint creatureZoneSize
zoneNearPoint :: Point2 -> [(Int,Int)]
zoneNearPoint (V2 x' y') = [(a,b) | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where
x = floorHun x'
y = floorHun y'
zoneAroundPoint :: Point2 -> [(Int,Int)]
zoneAroundPoint (V2 x' y') = [(a,b) | a<-[x-3..x+3] , b<-[y-3..y+3]]
where
x = floorHun x'
y = floorHun y'
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (V2 aa ab) (V2 ba bb)
= nub
. concatMap f
$ digitalLine (zoneOfPoint (V2 aa ab)) (zoneOfPoint (V2 ba bb))
where
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 :: Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
zoneOfSeg :: Float -> Point2 -> Point2 -> Stream (Of (V2 Int)) Identity ()
--zoneOfLineStream = ddaSqStream zoneSize
zoneOfLineStream = ddaStream zoneSize
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
--{-# INLINE zoneOfLineIntMap #-}
--zoneOfLineIntMap = ddaExt zoneSize
zoneOfLineIntMap = ddaSq zoneSize
zoneOfSeg = ddaStream
zoneOfCirc :: Monad m => Point2 -> Float -> Stream (Of (V2 Int)) m ()
zoneOfCirc p = S.map (uncurry V2) . S.each . zoneOfCircle p
zoneOfCirc p = S.each . zoneOfCircle p
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
zoneOfCircle :: Point2 -> Float -> Set.Set (V2 Int)
zoneOfCircle p r = foldMap zoneNearPointS $ divideCircle (1.5 * wallZoneSize) p r
zoneOfSight :: Configuration -> World -> [(Int,Int)]
zoneOfSight cfig w =
[(a,b)
zoneNearPointS :: Point2 -> Set.Set (V2 Int)
zoneNearPointS p = Set.fromList [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
where
V2 x y = wallZoneOfPoint p
zoneNearPointIP :: Point2 -> [(Int,Int)]
zoneNearPointIP p = [(a,b) | a <- [x-1..x+1] , b <- [y-1..y+1] ]
where
V2 x y = wallZoneOfPoint p
zoneNearPoint :: Point2 -> Stream (Of (V2 Int)) Identity ()
zoneNearPoint p = S.each [V2 a b | a <- [x-1..x+1] , b <- [y-1..y+1] ]
where
V2 x y = wallZoneOfPoint p
zoneOfSight :: Float -> World -> Stream (Of (V2 Int)) Identity () --(Int,Int)]
zoneOfSight x w = S.each
[V2 a b
| a <- [minimum xs .. maximum xs]
, b <- [minimum ys .. maximum ys]
]
where
(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w ++ [_cameraViewFrom w]
--(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w -- ++ [_cameraViewFrom w]
(xs,ys) = unzip $ map (sizeZoneOfPoint x) $ _boundBox w -- ++ [_cameraViewFrom w]
wallsDoubleScreen :: Configuration -> World -> IM.IntMap Wall
wallsDoubleScreen cfig w
-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-- for some reason (TODO diagnose) the foldl' version causes errors
= foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
where
innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
(x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
wh = max (_windowX cfig) (_windowY cfig)
xs = [x - n .. x + n]
ys = [y - n .. y + n]
--wallsDoubleScreen :: Configuration -> World -> IM.IntMap Wall
--wallsDoubleScreen cfig w
-- -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-- -- for some reason (TODO diagnose) the foldl' version causes errors
-- = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-- where
-- innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
-- f i m = case IM.lookup i m of
-- Just val -> val
-- _ -> IM.empty
-- (x,y) = zoneOfPoint $ _cameraCenter w
-- n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
-- wh = max (_windowX cfig) (_windowY cfig)
-- xs = [x - n .. x + n]
-- ys = [y - n .. y + n]
wallsOnScreen :: Configuration -> World -> IM.IntMap Wall
{-# INLINABLE wallsOnScreen #-}
wallsOnScreen cfig w
-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
= foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
where
--innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
innerFold m = foldr (IM.union . \ j -> f j m) IM.empty ys
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
(x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling (wh / (_cameraZoom w * zoneSize))
wh = max (_windowX cfig) (_windowY cfig)
xs = [x - n .. x + n]
ys = [y - n .. y + n]
--wallsOnScreen :: Configuration -> World -> IM.IntMap Wall
--{-# INLINABLE wallsOnScreen #-}
--wallsOnScreen cfig w
-- -- = foldl' (flip $ IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-- = foldr (IM.union . \i -> innerFold (f i (_znObjects $ _wallsZone w))) IM.empty xs
-- where
-- --innerFold m = foldl' (flip $ IM.union . \ j -> f j m) IM.empty ys
-- innerFold m = foldr (IM.union . \ j -> f j m) IM.empty ys
-- f i m = case IM.lookup i m of
-- Just val -> val
-- _ -> IM.empty
-- (x,y) = zoneOfPoint $ _cameraCenter w
-- n = ceiling (wh / (_cameraZoom w * zoneSize))
-- wh = max (_windowX cfig) (_windowY cfig)
-- xs = [x - n .. x + n]
-- ys = [y - n .. y + n]
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
@@ -168,17 +153,10 @@ cloudsNearPoint p w = S.each . f $ w ^? cloudsZone . znObjects . ix x . ix y
-- TODO check whether/when nubbing of walls is necessary
wallsAlongLine :: Point2 -> Point2 -> World -> Stream (Of Wall) Identity ()
wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfLineStream sp ep
wallsAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg wallZoneSize sp ep
where
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]
where
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
wallsAlongCirc' :: Point2 -> Float -> World -> Stream (Of Wall) Identity ()
wallsAlongCirc' p r w = S.concat $ S.mapMaybe f $ zoneOfCirc p r
where
@@ -190,7 +168,7 @@ wallsNearPoint' p = runIdentity . S.toList_ . wallsNearPoint p
wallsNearPoint :: Point2 -> World -> Stream (Of Wall) Identity ()
wallsNearPoint p w = S.concat $ S.mapMaybe f $ S.each [V2 a b | a <- [x-1,x,x+1], b <- [y-1,y,y+1]]
where
(x,y) = zoneOfPoint p
V2 x y = wallZoneOfPoint p
f (V2 i j) = w ^? wallsZone . znObjects . ix i . ix j
-- IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
-- where
@@ -218,15 +196,7 @@ creaturesNearPointI n p w = IM.unions
(x,y) = crZoneOfPoint p
f i m = fromMaybe IM.empty $ IM.lookup i m
-- possible BUG, occurs when used in thingsHitLongLine
creaturesAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Creature
--creaturesAlongLine a b w = IM.unions [f y $ f x $ _creaturesZone w | (x,y) <- zoneOfLine a b]
-- where f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty
creaturesAlongLine a b w = IM.foldrWithKey' g IM.empty (zoneOfLineIntMap a b)
where
g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
f i = fromMaybe IM.empty . IM.lookup i
-- f i m = case IM.lookup i m of Just val -> val
-- _ -> IM.empty
creaturesAlongLine :: Point2 -> Point2 -> World -> Stream (Of Creature) Identity ()
creaturesAlongLine sp ep w = S.concat $ S.mapMaybe f $ zoneOfSeg creatureZoneSize sp ep
where
f (V2 i j) = w ^? creaturesZone . znObjects . ix i . ix j
src/Geometry.hs
+5
View File
@@ -29,6 +29,7 @@ import Geometry.LHS
import ListHelp
--import Geometry.ConvexPoly
import qualified Data.Set as S
--import Data.Maybe
--import Data.List
-- | Return a point a distance away from a first point towards a second point.
@@ -122,6 +123,10 @@ angleBetween v1 v2 = argV v1 - argV v2
doublePair :: (a,a) -> [(a,a)]
doublePair (x,y) = [(x,y),(y,x)]
-- this shouldn't be here
doublePairSet :: Ord a => (a,a) -> S.Set (a,a)
doublePairSet (x,y) = S.fromList [(x,y),(y,x)]
doubleV2 :: V2 a -> [V2 a]
doubleV2 (V2 x y) = [V2 x y,V2 y x]
-- split a list into triples, forms triangles from a polygon
src/Geometry/Zone.hs
+1
View File
@@ -9,6 +9,7 @@ module Geometry.Zone
, ddaStreamY
, xIntercepts
, yIntercepts
, divTo
) where
import Geometry.Data
src/Loop.hs
+3 -12
View File
@@ -20,8 +20,6 @@ setupLoop
:: Int -- ^ Target seconds per frame
-> T.Text -- ^ Window title
-> WindowConfig
-- -> (Int,Int) -- ^ The window size.
-- -> Maybe (Int,Int) -- ^ The window position.
-> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop.
-> IO world -- ^ Initial simulation state.
-> (world -> IO world) -- ^ update, called once per frame. Allows for side effects such as rendering.
@@ -39,7 +37,7 @@ setupLoop spf title winconfig paramCleanup ioStartWorld sideEffects eventFn = do
$ \_ -> bracket
ioStartWorld
paramCleanup
$ doLoop spf window sideEffects eventFn
(doLoop spf window sideEffects eventFn)
-- | The internal loop.
doLoop
:: Int -- ^ target msec per frame
@@ -48,18 +46,11 @@ doLoop
-> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling.
-> world -- ^ Current simulation state.
-> IO ()
doLoop
spf
window
worldSideEffects
eventFn
startWorld
= do
doLoop spf window worldSideEffects eventFn startWorld = do
startTicks <- ticks
worldAfterSimStep <- worldSideEffects startWorld
glSwapWindow window
events <- pollEvents
maybeUpdatedWorld <- foldM (applyEventIO eventFn) (Just worldAfterSimStep) events
maybeUpdatedWorld <- pollEvents >>= foldM (applyEventIO eventFn) (Just worldAfterSimStep)
case maybeUpdatedWorld of
Just updatedWorld -> do
performGC