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

Cleanup, move towards unifying zones

Browse Source
This commit is contained in:
justin
2021-09-11 15:52:43 +01:00
parent 27e4f16dd9
commit aa7413a29f
57 changed files with 157 additions and 331 deletions
Download Patch File Download Diff File Expand all files Collapse all files
appHetris/Hetris.hs
-21
View File
@@ -1,21 +0,0 @@
module Main where
import Loop
import Hetris.Base
import Control.Lens
--import Foreign (Word32)
import Control.Monad
--import System.Random
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate)
import qualified SDL
import qualified SDL.Mixer as Mix
main :: IO ()
main = setupMiniLoop
(600,600)
initWorld
(const $ return ())
(\w _ -> return w)
return
package.yaml
-17
View File
@@ -83,23 +83,6 @@ executables:
# - -hiedir=.hie
dependencies:
- loop
hetris:
main: Hetris.hs
source-dirs: appHetris
ghc-options:
- -threaded
- -O2
- -rtsopts
- -with-rtsopts=-N
- -flate-dmd-anal
- -fno-liberate-case
- -fno-state-hack
- -funfolding-use-threshold1000
- -funfolding-keeness-factor1000
- -fllvm
- -optlo-O3
dependencies:
- loop
tests:
loop-test:
src/Dodge/Base.hs
+6 -12
View File
@@ -6,7 +6,8 @@ Consider splitting. -}
module Dodge.Base
where
import Dodge.Data
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Zone.Data
import Dodge.Base.Window
import Geometry
--import Picture
@@ -68,10 +69,10 @@ wallsOnCirc p r = IM.filter f
f wl = uncurry circOnSeg (_wlLine wl) p r
allWalls :: World -> IM.IntMap Wall
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _wallsZone w
allWalls w = IM.unions $ concatMap IM.elems $ IM.elems $ _znObjects $ _wallsZone w
creaturesNearPoint :: Point2 -> World -> IM.IntMap Creature
creaturesNearPoint p w = IM.unions [f b $ f a $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
creaturesNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where
(x,y) = crZoneOfPoint p
f i m = case IM.lookup i m of
@@ -79,27 +80,20 @@ creaturesNearPoint p w = IM.unions [f b $ f a $ _creaturesZone w | a<-[x-1,x,x+
_ -> IM.empty
creaturesNearPointI :: Int -> Point2 -> World -> IM.IntMap Creature
creaturesNearPointI n p w = IM.unions [f b $ f a $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]]
creaturesNearPointI n p w = IM.unions [f b $ f a $ _znObjects $ _creaturesZone w | a<-[x-n..x+n] , b<-[y-n..y+n]]
where
(x,y) = crZoneOfPoint p
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
cloudsNearPoint :: Point2 -> World -> [Cloud]
--cloudsNearPoint p w = IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
cloudsNearPoint p w = f (IM.lookup x (_cloudsZone w) >>= IM.lookup y)
where
(x,y) = cloudZoneOfPoint p
f Nothing = []
f (Just l) = l
-- 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 kps
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _creaturesZone w) s))
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _creaturesZone w) s))
kps = zoneOfLineIntMap a b
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
src/Dodge/Base/Collide.hs
+1 -1
View File
@@ -3,7 +3,7 @@
module Dodge.Base.Collide
where
import Dodge.Data
import Dodge.Base.Zone
import Dodge.Zone
import Geometry
import FoldableHelp
src/Dodge/Creature/Action.hs
+2 -1
View File
@@ -14,8 +14,9 @@ import Dodge.Path
import Dodge.Creature.Stance.Data
import Dodge.WorldEvent.Shockwave
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base.Collide
import Dodge.SoundLogic
import Dodge.SoundLogic.Synonyms
src/Dodge/Creature/Impulse.hs
+2
View File
@@ -3,8 +3,10 @@ module Dodge.Creature.Impulse
)
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Creature.Impulse.Movement
import Dodge.Creature.Impulse.UseItem
import Dodge.Data.DamageType
--import Dodge.Creature.Action.UseItem
import Dodge.Creature.State.Data
import Dodge.Creature.Stance.Data
src/Dodge/Creature/Perception.hs
+1
View File
@@ -10,6 +10,7 @@ import Dodge.Creature.Memory.Data
import Dodge.Base.Collide
import Geometry.Vector
--import Geometry.Data
import Geometry.Data
import Sound.Data
--import StrictHelp
src/Dodge/Creature/Picture.hs
+1
View File
@@ -8,6 +8,7 @@ module Dodge.Creature.Picture
, picAtCrPosNoRot
) where
import Dodge.Data
import Dodge.Data.DamageType
--import Dodge.Base
--import Dodge.Creature.Stance.Data
import Dodge.Creature.Perception.Data
src/Dodge/Creature/State.hs
+2
View File
@@ -1,5 +1,7 @@
module Dodge.Creature.State where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Data.SoundOrigin
import Dodge.Item.Data
import Dodge.Creature.State.Data
import Dodge.Creature.State.WalkCycle
src/Dodge/Creature/State/WalkCycle.hs
+2
View File
@@ -1,8 +1,10 @@
module Dodge.Creature.State.WalkCycle
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Creature.Stance.Data
import Dodge.SoundLogic
import Geometry.Data
import Control.Lens
src/Dodge/Data.hs
+7 -15
View File
@@ -4,17 +4,11 @@ different modules because they are interdependent;
circular imports are probably not a good idea.
-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
module Dodge.Data
( module Dodge.Data
, module Dodge.Data.DamageType
, module Dodge.Data.SoundOrigin
, Point2
, Sound (..)
, soundTime
) where
where
import Dodge.Creature.State.Data
import Dodge.Creature.Stance.Data
import Dodge.Creature.Perception.Data
@@ -22,6 +16,7 @@ import Dodge.Creature.Memory.Data
import Dodge.Debug.Flag.Data
import Dodge.Data.SoundOrigin
import Dodge.Data.DamageType
import Dodge.Zone.Data
import Dodge.Config.Data
import Dodge.Config.KeyConfig
import Dodge.Item.Attachment.Data
@@ -55,17 +50,15 @@ data World = World
, _cameraZoom :: !Float
, _cameraViewFrom :: !Point2
, _creatures :: IM.IntMap Creature
, _creaturesZone :: IM.IntMap (IM.IntMap (IM.IntMap Creature))
, _creaturesZone :: Zone (IM.IntMap Creature)
, _creatureGroups :: IM.IntMap CrGroupParams
, _itemPositions :: IM.IntMap ItemPos
, _clouds :: [Cloud]
, _cloudsZone :: IM.IntMap (IM.IntMap [Cloud])
, _cloudsZone :: Zone [Cloud]
, _projectiles :: IM.IntMap Projectile
, _particles :: ![Particle]
, _staticWalls :: IM.IntMap (IM.IntMap [Wall'])
, _seenStaticWalls :: IM.IntMap (IM.IntMap [Wall'])
, _walls :: !(IM.IntMap Wall)
, _wallsZone :: IM.IntMap (IM.IntMap (IM.IntMap Wall))
, _wallsZone :: Zone (IM.IntMap Wall)
, _forceFields :: IM.IntMap ForceField
, _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)]
@@ -81,12 +74,11 @@ data World = World
, _decorations :: IM.IntMap Picture
, _foregroundDecorations :: [Polyhedra]
, _foregroundEdgeVerx :: [Point3]
, _corpses :: IM.IntMap (IM.IntMap [Corpse])
, _corpses :: Zone [Corpse]
, _clickMousePos :: !Point2
, _pathGraph :: ~(Gr Point2 Float)
, _pathGraph' :: ~[(Point2,Point2)]
, _pathPoints :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
, _pathInc :: ~(M.Map Point2 [Point2])
, _storedLevel :: Maybe World
, _menuLayers :: [ScreenLayer]
, _worldState :: M.Map WorldState Bool
src/Dodge/Debug.hs
+1 -1
View File
@@ -2,7 +2,7 @@ module Dodge.Debug where
import Dodge.Data
import Dodge.Picture
import Dodge.Picture.Layer
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base
import Geometry.Zone
import Geometry.Data
src/Dodge/Debug/LinkDecoration.hs
+1
View File
@@ -8,6 +8,7 @@ import Dodge.Room.Data
import Dodge.Picture.Layer
import Picture
import qualified IntMapHelp as IM
import Geometry.Data
import Geometry.Vector
import Control.Lens
src/Dodge/Default.hs
+2
View File
@@ -7,6 +7,8 @@ This module contains prototypical data structures.
module Dodge.Default where
import Dodge.Item.Weapon.ExtraEffect
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Data.SoundOrigin
import Dodge.Item.Data
import Dodge.Creature.Stance.Data
import Dodge.Creature.State.Data
src/Dodge/Default/World.hs
+5 -7
View File
@@ -2,6 +2,7 @@ module Dodge.Default.World
where
import Dodge.Data
import Dodge.Base
import Dodge.Zone.Data
import Dodge.Debug.Flag.Data
import Dodge.Config.Data
import Dodge.Config.KeyConfig
@@ -28,17 +29,15 @@ defaultWorld = World
, _cameraZoom = 1
, _cameraViewFrom = V2 0 0
, _creatures = IM.empty
, _creaturesZone = IM.empty
, _creaturesZone = Zone IM.empty 15
, _creatureGroups = IM.empty
, _clouds = []
, _cloudsZone = IM.empty
, _cloudsZone = Zone IM.empty 20
, _itemPositions = IM.empty
, _projectiles = IM.empty
, _particles = []
, _staticWalls = IM.empty
, _seenStaticWalls = IM.empty
, _walls = IM.empty
, _wallsZone = IM.empty
, _wallsZone = Zone IM.empty 50
, _forceFields = IM.empty
, _floorItems = IM.empty
, _floorTiles = []
@@ -51,7 +50,7 @@ defaultWorld = World
, _buttons = IM.empty
, _sounds = M.empty
, _playingSounds = M.empty
, _corpses = IM.empty
, _corpses = Zone IM.empty 50
, _decorations = IM.empty
, _storedLevel = Nothing
, _menuLayers = []
@@ -61,7 +60,6 @@ defaultWorld = World
, _pathGraph = Data.Graph.Inductive.Graph.empty
, _pathGraph' = []
, _pathPoints = IM.empty
, _pathInc = M.empty
, _carteDisplay = False
, _carteCenter = V2 0 0
, _carteZoom = 0.5
src/Dodge/Event.hs
+1
View File
@@ -16,6 +16,7 @@ module Dodge.Event
import Dodge.Event.Keyboard
--import Dodge.Event.Menu
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Base
import Dodge.Base.Window
--import Dodge.Creature.Action
src/Dodge/Initialisation.hs
+2 -1
View File
@@ -1,8 +1,9 @@
module Dodge.Initialisation where
import Dodge.Default.World
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Creature
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Floor
import Dodge.Layout
import Dodge.Story
src/Dodge/Item/Consumable.hs
+1
View File
@@ -1,6 +1,7 @@
module Dodge.Item.Consumable
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Item.Data
import Dodge.Picture.Layer
import Dodge.Default
src/Dodge/Item/Weapon.hs
+2 -1
View File
@@ -3,8 +3,9 @@ In progress: move out effects into other modules. -}
module Dodge.Item.Weapon
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Picture.Layer
import Dodge.SoundLogic
import Dodge.SoundLogic.Synonyms
src/Dodge/Item/Weapon/Booster.hs
+1 -1
View File
@@ -2,7 +2,7 @@ module Dodge.Item.Weapon.Booster
where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base.Collide
import Geometry
import qualified IntMapHelp as IM
src/Dodge/Item/Weapon/Decoration.hs
+1 -1
View File
@@ -6,7 +6,7 @@ module Dodge.Item.Weapon.Decoration
import Dodge.Data
import Dodge.Picture.Layer
import Dodge.Picture
--import Geometry.Data
import Geometry.Data
import Picture
import Control.Lens
src/Dodge/Item/Weapon/Grenade.hs
+2 -1
View File
@@ -1,9 +1,10 @@
module Dodge.Item.Weapon.Grenade
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Item.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Picture.Layer
import Dodge.SoundLogic
import Dodge.SoundLogic.Synonyms
src/Dodge/Item/Weapon/Laser.hs
+1
View File
@@ -2,6 +2,7 @@
module Dodge.Item.Weapon.Laser
where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Picture
--import Dodge.Picture.Layer
import Dodge.Item.Attachment.Data
src/Dodge/Item/Weapon/Launcher.hs
+2 -1
View File
@@ -1,6 +1,7 @@
module Dodge.Item.Weapon.Launcher
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Default.Weapon
import Dodge.Default.Shell
import Dodge.SoundLogic.Synonyms
@@ -11,7 +12,7 @@ import Dodge.Item.Draw
import Dodge.Item.Weapon.Shell
import Dodge.Item.Weapon.TriggerType
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.SoundLogic
import Dodge.WorldEvent.SpawnParticle
import Dodge.WorldEvent.Cloud
src/Dodge/Item/Weapon/Targeting.hs
+1
View File
@@ -1,6 +1,7 @@
module Dodge.Item.Weapon.Targeting
where
import Dodge.Data
import Geometry.Data
import Control.Lens
--import qualified Data.IntMap.Strict as IM
src/Dodge/Item/Weapon/TriggerType.hs
+1
View File
@@ -35,6 +35,7 @@ module Dodge.Item.Weapon.TriggerType
)
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.SoundLogic
import Dodge.Creature.Action (startReloadingWeapon)
import Dodge.WorldEvent (tempLightForAt)
src/Dodge/Item/Weapon/UseEffect.hs
+1 -1
View File
@@ -5,7 +5,7 @@ module Dodge.Item.Weapon.UseEffect
where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base.Collide
import Dodge.Picture.Layer
--import Dodge.Item.Weapon.Decoration
src/Dodge/Layout.hs
+8 -15
View File
@@ -5,11 +5,12 @@ import Dodge.LevelGen
import Dodge.LevelGen.StaticWalls
--import Dodge.LevelGen.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Zone.Data
import Dodge.GameRoom
import Dodge.Bounds
--import Dodge.RandomHelp
import Dodge.Graph
--import Dodge.Graph
import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data
import Dodge.Room.AddTile
@@ -31,13 +32,14 @@ import System.Random
--import Data.Maybe
import Data.Tree
import Data.Graph.Inductive.Graph (labNodes)
import qualified Data.Map as M
--import qualified Data.Map as M
import Data.Foldable
import qualified Control.Foldl as L
import Data.Maybe
generateLevelFromRoomList :: State StdGen [Room] -> World -> World
generateLevelFromRoomList gr w = updateWallZoning
generateLevelFromRoomList gr w
= updateWallZoning
. setupWorldBounds
-- . initializeStaticWalls
. setupForegroundEdgeVerxs
@@ -87,7 +89,6 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
,_pathGraph = path
,_pathGraph' = pairGraph
,_pathPoints = foldl' (flip insertPoint) IM.empty (labNodes path)
,_pathInc = pinc
}
where
tr = evalState t $ _randGen w
@@ -95,15 +96,7 @@ generateFromTree t w = updateWallZoning $ placeSpots plmnts
path = pairsToGraph dist pairGraph
pairGraph = makePath tr
insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp]
pinc = M.fromList $ pairsToIncidence pairGraph
initializeStaticWalls :: World -> World
initializeStaticWalls w = w & staticWalls %~ (\wls' -> foldl' (flip wallToWall) wls' wls)
& walls %~ IM.filter (not . wlIsWall)
where
wls = [wl | wl@Wall{} <- IM.elems $ _walls w]
wlIsWall Wall{} = True
wlIsWall _ = False
--pinc = M.fromList $ pairsToIncidence pairGraph
wallToWall :: Wall -> IM.IntMap (IM.IntMap [Wall']) -> IM.IntMap (IM.IntMap [Wall'])
wallToWall wl wls = foldl' (flip f) wls is
@@ -113,7 +106,7 @@ wallToWall wl wls = foldl' (flip f) wls is
f (x,y) = insertInZoneWith x y (++) [wl']
updateWallZoning :: World -> World
updateWallZoning w = set wallsZone (foldl' (flip wallInZone) IM.empty (_walls w)) w
updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w
where
wallInZone wl
| uncurry dist (_wlLine wl) <= 2*zoneSize = insertIMInZone x y wlid wl
src/Dodge/LevelGen/AutoDoor.hs
+1
View File
@@ -12,6 +12,7 @@ import Dodge.Creature.Property
import Dodge.LevelGen.DoorPane
--import Geometry
import Picture
import Geometry.Data
--import qualified DoubleStack as DS
import qualified IntMapHelp as IM
src/Dodge/LevelGen/Block.hs
+6 -4
View File
@@ -1,8 +1,10 @@
{- | Creation, update and destruction of destructible walls. -}
module Dodge.LevelGen.Block where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Zone.Data
import Dodge.SoundLogic
import Dodge.WorldEvent.Sound
import Dodge.LevelGen.Pathing
@@ -24,7 +26,7 @@ updateBlocks w = (\w' -> seq (_wallsZone w') w') $ flip (foldr removeFromZone) d
where
degradeBlocks = deadBlocks `seq` foldr killBlock w deadBlocks
removeFromZone :: Wall -> World -> World
removeFromZone bl = over (wallsZone . ix x . ix y) (IM.delete (_wlID bl))
removeFromZone bl = over (wallsZone . znObjects . ix x . ix y) (IM.delete (_wlID bl))
where
(x,y) = zoneOfPoint $ uncurry pHalf (_wlLine bl)
deadPanes = filter blockIsDead (IM.elems $ _walls w)
@@ -54,7 +56,7 @@ killBlock bl w = f bl . flip (foldr unshadow) (_blShadows bl) $ w
unshadow bid w' = case w' ^? walls . ix bid of
Just b ->
let (x,y) = zoneOfPoint $ uncurry pHalf (_wlLine b)
in w & wallsZone . ix x . ix y . ix bid . blVisible %~ const True
in w & wallsZone . znObjects . ix x . ix y . ix bid . blVisible %~ const True
& walls . ix bid . blVisible %~ const True
Nothing -> w
@@ -100,7 +102,7 @@ addBlock (p:ps) hp col isSeeThrough degradability w
| hp <= 0 && null degradability = w
| hp <= 0 = addBlock (p:ps) (head degradability + hp) col isSeeThrough (tail degradability) w
| otherwise = w
& wallsZone %~ flip (IM.foldr wallInZone) panes
& wallsZone . znObjects %~ flip (IM.foldr wallInZone) panes
& walls %~ IM.union panes
where
lns = zip (p:ps) (ps ++ [p])
src/Dodge/LevelGen/Data.hs
+1
View File
@@ -20,6 +20,7 @@ module Dodge.LevelGen.Data
import Dodge.Data
import Picture
import Polyhedra.Data
import Geometry.Data
import Control.Lens
import Control.Monad.State
src/Dodge/LevelGen/DoorPane.hs
+1
View File
@@ -8,6 +8,7 @@ import Dodge.LevelGen.MoveDoor
import Picture
import qualified DoubleStack as DS
import Geometry.Vector
import Geometry.Data
import Data.Bifunctor
src/Dodge/LevelGen/MoveDoor.hs
+4 -2
View File
@@ -6,8 +6,10 @@ module Dodge.LevelGen.MoveDoor
, addSoundToDoor
) where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Zone.Data
import Dodge.SoundLogic
import Dodge.SoundLogic.Synonyms
import Geometry
@@ -58,7 +60,7 @@ changeZonedWall
-> (Int,Int)
-> World
-> World
changeZonedWall eff n (x,y) = over wallsZone $ adjustIMZone eff x y n
changeZonedWall eff n (x,y) = over (wallsZone . znObjects) $ adjustIMZone eff x y n
addSoundToDoor :: Int -> Point2 -> Point2 -> [Wall] -> [Wall]
addSoundToDoor _ _ _ [] = error "When creating door tried to add sound to nothing"
src/Dodge/LevelGen/Pathing.hs
+1 -1
View File
@@ -2,7 +2,7 @@ module Dodge.LevelGen.Pathing
where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Geometry
import Control.Lens
src/Dodge/LevelGen/StaticWalls.hs
-95
View File
@@ -1,20 +1,15 @@
--{-# LANGUAGE TupleSections #-}
{-|
Module : Dodge.LevelGen.StaticWalls
Description : Concerns carving out of static walls to create the general room plan of the level.
-}
module Dodge.LevelGen.StaticWalls
where
import Dodge.Data
import Geometry
import Geometry.ConvexPoly
--import Geometry.Data
import FoldableHelp
--import Control.Lens
import Data.List.Extra
import Data.Maybe
import Data.Bifunctor
-- | Describe a wall as two points.
-- Order is important: the wall face is to the left of the line going from
-- 'fst' to 'snd'.
@@ -43,20 +38,14 @@ cutWalls :: [Point2] -> [WallP] -> [WallP]
cutWalls ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
_ -> cutWallsRetry 0 ps wls
-- _ -> wls
-- _ -> error $ show ps
where
newWalls = cutPoly ps wls
cutWallsRetry :: Int -> [Point2] -> [WallP] -> [WallP]
--cutWallsRetry 200 ps wls = error $ show ps ++ show wls
cutWallsRetry i ps wls = case mapMaybe (`checkWallRight` newWalls) newWalls of
[] -> newWalls
_ -> cutWallsRetry (i+1) ps wls
-- _ -> wls
-- _ -> error $ show ps
where
newWalls = cutPoly ps' wls
--ps' = map (rotateV a) $ expandPolyBy 0.1 ps
ps' = map (rotateV a) $ expandPolyBy x ps
x = fromIntegral i / 100
a | even i = 0.001
@@ -137,7 +126,6 @@ cutPoly qs wls =
expandPolyBy :: Float -> [Point2] -> [Point2]
expandPolyBy x ps = map f ps
where
--cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps
cp = centroid ps
f p = p +.+ x *.* (p -.- cp)
-- | Given a value and a poly, pushes the poly points out from the center by the
@@ -145,7 +133,6 @@ expandPolyBy x ps = map f ps
expandPolyByFixed :: Float -> [Point2] -> [Point2]
expandPolyByFixed x ps = map f ps
where
--cp = 1/fromIntegral (length ps) *.* foldl' (+.+) (V2 0 0) ps
cp = centroid ps
f p = p +.+ x *.* safeNormalizeV (p -.- cp)
-- | Given a polygon expressed as a list of points and a collection of walls,
@@ -189,13 +176,10 @@ addPolyWall wls (p1,p2) =
else (p1,p2) : wls
Nothing -> (p1,p2) : wls
where
--maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
--maybeWs = fmap fst $ safeMinimumOn (dist p3 . snd) $ mapMaybe (\x -> (x,) <$> f x) wls
maybeWs = safeMinimumOnMaybe (fmap (dist p3) . f) wls
p3 = 0.5 *.* (p1 +.+ p2)
p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
f = uncurry $ myIntersectSegSeg p3 p4
--g = uncurry $ intersectSegSegTest p3 p4
-- | Given a list of points and a point, returns a point in the list if any is close
-- to the point.
findClosePoint :: [Point2] -> Point2 -> Maybe Point2
@@ -243,88 +227,9 @@ findWallsInPolygon ps = filter cond
where
cond wall = pointInOrOnPolygon (0.5 *.* uncurry (+.+) wall) ps
brokenWalls :: [(Point2,Point2)]
brokenWalls = map (bimap toV2 toV2)
[((330.12192,3032.2456),(190.52365,2995.8352)),((190.52365,2995.8352),(203.94716,2945.9377)),((214.33855,2907.311),(230.12193,2859.0405)),((230.12193,2859.0405),(366.7245,2895.643)),((366.7245,2895.643),(330.12192,3032.2456)),((366.7245,2895.643),(230.12193,2859.0405)),((230.12193,2859.0405),(266.7245,2722.438)),((266.7245,2722.438),(403.32703,2759.0405)),((403.32703,2759.0405),(503.32703,2932.2456)),((466.72446,3068.8481),(330.12192,3032.2456)),((330.12192,3032.2456),(366.7245,2895.643)),((503.32703,2932.2456),(466.72446,3068.8481)),((203.94716,2945.9377),(145.99155,2930.4084)),((156.38292,2891.7817),(214.33855,2907.311)),((107.47222,2920.979),(34.06077,2901.2295)),((34.06077,2901.2295),(52.571453,2832.4224)),((70.17772,2796.55),(174.45558,2824.6025)),((174.45558,2824.6025),(156.38292,2891.7817)),((100.76944,2955.4202),(107.47222,2920.979)),((145.99155,2930.4084),(140.79587,2949.722)),((52.571453,2832.4224),(35.882084,2827.9504)),((31.745949,2785.4312),(70.17772,2796.55)),((88.14497,3002.5354),(100.76944,2955.4202)),((140.79587,2949.722),(120.21855,3027.0303)),((35.882084,2827.9504),(-22.07344,2812.4214)),((-31.039248,2768.608),(31.745949,2785.4312)),((-261.32483,3408.5737),(-303.9881,3451.237)),((-303.9881,3451.237),(-332.27234,3422.9526)),((-332.27234,3422.9526),(-289.84595,3380.5264)),((-261.56174,3352.242),(88.14497,3002.5354)),((120.21855,3027.0303),(-233.27742,3380.5264)),((-289.84595,3380.5264),(-332.2724,3338.0999)),((-332.2724,3338.0999),(-303.9881,3309.8157)),((-303.9881,3309.8157),(-261.56174,3352.242)),((-22.07344,2812.4214),(-89.68823,2794.304)),((-79.335526,2755.667),(-31.039248,2768.608)),((-210.16953,3456.4133),(-261.32483,3408.5737)),((-233.27742,3380.5264),(-194.64026,3419.1633)),((-128.32533,2783.9514),(-200.79468,3054.4106)),((-200.79468,3054.4106),(-780.35016,2899.1191)),((-780.35016,2899.1191),(-625.05865,2319.5635)),((-625.05865,2319.5635),(-45.503174,2474.855)),((-45.503174,2474.855),(-117.97253,2745.3142)),((-89.68823,2794.304),(-128.32533,2783.9514)),((-117.97253,2745.3142),(-79.335526,2755.667)),((-178.49438,3590.2566),(-241.50847,3573.372)),((-241.50847,3573.372),(-210.16953,3456.4133)),((-194.64026,3419.1633),(-136.80266,3434.6611)),((-98.165634,3445.014),(-139.85736,3600.6094)),((-92.98925,3425.6953),(-98.165634,3445.014)),((-136.80266,3434.6611),(-127.74397,3400.8535)),((-187.553,3624.064),(-178.49438,3590.2566)),((-139.85736,3600.6094),(-148.91603,3634.4167)),((-127.74397,3400.8535),(-111.20285,3339.121)),((-78.55679,3371.8325),(-92.98925,3425.6953)),((-349.5008,4383.0093),(-388.13782,4372.6563)),((-388.13782,4372.6563),(-485.18823,3653.0168)),((-485.18823,3653.0168),(-477.42368,3624.039)),((-477.42368,3624.039),(-206.96445,3696.5085)),((-168.32744,3706.861),(102.131805,3779.3306)),((102.131805,3779.3306),(94.36725,3808.308)),((94.36725,3808.308),(-349.5008,4383.0093)),((-206.96445,3696.5085),(-187.553,3624.064)),((-148.91603,3634.4167),(-168.32744,3706.861)),((299.35522,3346.2668),(97.2383,3547.9797)),((97.2383,3547.9797),(-78.55679,3371.8325)),((-111.20285,3339.121),(116.74672,3110.6904)),((116.74672,3110.6904),(320.08704,3314.438)),((352.084,3395.578),(299.35522,3346.2668)),((320.08704,3314.438),(367.6133,3358.328)),((495.06226,3666.979),(293.8115,3613.054)),((293.8115,3613.054),(352.084,3395.578)),((367.6133,3358.328),(563.6875,3410.866)),((563.6875,3410.866),(495.06226,3666.979))]
--intersectingBrokenWalls :: [(Point2,Point2)]
--intersectingBrokenWalls = filter (uncurry test) brokenWalls
-- where
-- polyPairs = zip brokenPoly (tail brokenPoly ++ [head brokenPoly])
-- test a b = any (isJust . uncurry (myIntersectSegSeg a b)) polyPairs
--brokenPoly :: [Point2]
--brokenPoly = [(434.66675,2833.3225),(503.9488,2793.3225),(523.9488,2827.9636),(454.66675,2867.9636)]
--iBWall :: (Point2,Point2)
--iBWall = ((403.32703,2759.0405),(503.32703,2932.2456))
expandToSquare :: (Point2,Point2) -> [(Point2,Point2)]
expandToSquare (a,b) = [(a,b),(b,c),(c,d),(d,a)]
where
v = a -.- b
c = b +.+ vNormal v
d = a +.+ vNormal v
--minWalls :: [(Point2,Point2)]
--minWalls = expandToSquare iBWall
--brokenZs :: [Point2]
--brokenCwals :: [WallP]
--(brokenZs,brokenCwals) = cutWallsWithPoints brokenPoly brokenWalls
--minZs :: [Point2]
--minCwals :: [WallP]
--(minZs,minCwals) = cutWallsWithPoints brokenPoly minWalls
--
--brokenRs :: [Point2]
--brokenRs = orderPolygon $ nub $ minZs ++ brokenPoly
--
--brokenAfterRemovedWalls :: [WallP]
--brokenAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) brokenCwals
--minAfterRemovedWalls :: [WallP]
--minAfterRemovedWalls = removeWallsInPolygon (orderPolygon brokenPoly) minCwals
--
--brokenRemovedWalls :: [WallP]
--brokenRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) brokenCwals
--minRemovedWalls :: [WallP]
--minRemovedWalls = findWallsInPolygon (orderPolygon brokenPoly) minCwals
--
--addedPolyWalls :: [Point2] -> [WallP] -> [WallP]
--addedPolyWalls ps wls = addPolyWalls ps wls \\ wls
--
--brokenAddedWalls :: [WallP]
--brokenAddedWalls = addedPolyWalls brokenRs brokenAfterRemovedWalls
--minAddedWalls :: [WallP]
--minAddedWalls = addedPolyWalls brokenRs minAfterRemovedWalls
--
--brokenAdd :: WallP
--brokenAdd = head brokenAddedWalls
--
--findShadowWall :: WallP -> [WallP] -> Maybe WallP
--findShadowWall (p1,p2) wls = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- where
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* rotateV (negate $ pi/4) (vNormal (p2 -.- p1))
-- f = uncurry $ myIntersectSegSeg p3 p4
--
--findShadowWalls :: WallP -> [WallP] -> [WallP]
--findShadowWalls (p1,p2) wls = hitWls
-- where
-- hitWls = sortOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-- f = uncurry $ myIntersectSegSeg p3 p4
--
--addWallDebug :: WallP -> [WallP] -> [WallP]
--addWallDebug (p1,p2) wls =
-- case maybeWs of
-- Just ws -> if uncurry isLHS ws p3
-- then wls
-- else (p1,p2) : wls
-- Nothing -> (p1,p2) : wls
-- where
-- maybeWs = safeMinimumOn (dist p3 . fromJust . f) $ filter (isJust . f) wls
-- p3 = 0.5 *.* (p1 +.+ p2)
-- p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1)
-- f = uncurry $ myIntersectSegSeg p3 p4
src/Dodge/LevelGen/SwarmPlacement.hs
+1
View File
@@ -7,6 +7,7 @@ import Dodge.LevelGen.Data
import Dodge.Creature.State.Data
--import Geometry
import Geometry.ConvexPoly
import Geometry.Data
import qualified IntMapHelp as IM
import Data.List
src/Dodge/LevelGen/Switch.hs
+1
View File
@@ -1,6 +1,7 @@
module Dodge.LevelGen.Switch
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.SoundLogic
import Dodge.Picture.Layer
import Picture
src/Dodge/LevelGen/TriggerDoor.hs
+1 -1
View File
@@ -8,7 +8,7 @@ module Dodge.LevelGen.TriggerDoor
) where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.LevelGen.Switch
import Dodge.LevelGen.Pathing
import Dodge.LevelGen.MoveDoor
src/Dodge/Particle/Bullet/HitEffect.hs
+2
View File
@@ -4,6 +4,8 @@ Effects of bullets upon impact with walls or creatures, and possibly force field
module Dodge.Particle.Bullet.HitEffect
where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Data.SoundOrigin
--import Dodge.Base
import Dodge.WorldEvent
import Dodge.Particle.Bullet.Spawn
src/Dodge/Path.hs
+2 -1
View File
@@ -7,7 +7,8 @@ module Dodge.Path
where
import Dodge.Data
import Dodge.Base.Collide
import Dodge.Base.Zone
import Dodge.Zone
import Geometry.Data
import Data.List
import Data.Maybe
src/Dodge/Render/Picture.hs
+2 -2
View File
@@ -4,13 +4,13 @@ module Dodge.Render.Picture
import Dodge.Data
import Dodge.Base
import Dodge.Base.Window
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Picture
import Dodge.Picture.SizeInvariant
import Dodge.Picture.Layer
import Dodge.Render.HUD
import Dodge.Render.MenuScreen
--import Dodge.Graph
import Sound.Data
import Geometry
import Picture
import Polyhedra.Data
src/Dodge/Room.hs
-1
View File
@@ -5,7 +5,6 @@ module Dodge.Room
( module Dodge.Room
, module Dodge.Room.Corridor
) where
import Dodge.Data
import Dodge.Default.Room
import Dodge.Item.Weapon
import Dodge.Item.Weapon.AutoGun
src/Dodge/Room/Path.hs
-1
View File
@@ -5,7 +5,6 @@ module Dodge.Room.Path
, createPathGrid
)
where
import Dodge.Data
import Dodge.Room.Data
import Dodge.LevelGen.StaticWalls
import Geometry
src/Dodge/SoundLogic.hs
+3 -1
View File
@@ -18,7 +18,9 @@ module Dodge.SoundLogic (
, pauseSound
) where
import Dodge.Data
import Sound.Data (SoundStatus (..))
import Dodge.Data.SoundOrigin
import Sound.Data
import Geometry.Data
import Geometry.Vector
import Dodge.SoundLogic.Synonyms
src/Dodge/Update.hs
+5 -3
View File
@@ -7,10 +7,11 @@ module Dodge.Update
) where
import Dodge.Data
import Dodge.Menu
import Dodge.Zone.Data
import Dodge.World.Trigger.Data
--import Dodge.Config.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.WallCreatureCollisions
import Dodge.LevelGen.Block
import Dodge.Update.Camera
@@ -76,12 +77,13 @@ functionalUpdate w = case _menuLayers w of
. updateSoundQueue
$ updateCloseObjects w
where
zoneCreatures = set creaturesZone (IM.foldl' (flip creatureInZone) IM.empty (_creatures w))
zoneCreatures = set (creaturesZone . znObjects)
(IM.foldl' (flip creatureInZone) IM.empty (_creatures w))
creatureInZone cr = insertIMInZone x y cid cr
where
(x,y) = crZoneOfPoint $ _crPos cr
cid = _crID cr
zoneClouds = set cloudsZone (foldl' (flip cloudInZone) IM.empty (_clouds w))
zoneClouds = set (cloudsZone . znObjects) (foldl' (flip cloudInZone) IM.empty (_clouds w))
cloudInZone cl = insertInZoneWith x y (++) [cl]
where
(x,y) = cloudZoneOfPoint $ stripZ $ _clPos cl
src/Dodge/Update/Camera.hs
+1 -1
View File
@@ -8,7 +8,7 @@ module Dodge.Update.Camera
where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base.Window
import Dodge.Base.Collide
import Dodge.Config.KeyConfig
src/Dodge/WallCreatureCollisions.hs
+2 -13
View File
@@ -1,9 +1,10 @@
{- | Deals with moving creature wall collisions. -}
module Dodge.WallCreatureCollisions where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Creature.State.Data
import Dodge.Debug.Flag.Data
import Dodge.Base.Zone
import Dodge.Zone
import Geometry
import Data.List
@@ -31,14 +32,6 @@ colCrWall w c
wallPoints = nub $ concatMap (\(x,y) -> [x,y]) ls
noclipIsOn = _noClip $ _debugFlags w
-- colCrPushThrough :: World -> Creature -> Creature
-- colCrPushThrough w cr = set crPos (checkPushThroughs rad p1 p2 ls) cr
-- where rad = _crRad cr + wallBuffer
-- p1 = _crOldPos cr
-- p2 = _crPos cr
-- ls = IM.elems $ fmap _wlLine $ wallsNearPoint p2 w
-- -- probably best to push check pushing through walls before creature springs
-- the amount to push creatures out from walls, extra to their radius
wallBuffer :: Float
wallBuffer = 0
@@ -108,8 +101,4 @@ checkPushThrough cp1 cp2 (wp1,wp2)
| isPushedThrough = intersectSegSeg cp1 cp2 wp1 wp2
| otherwise = Nothing
where
--norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2)
--wp1' = (rad *.* norm) +.+ wp1
--wp2' = (rad *.* norm) +.+ wp2
--newP = errorClosestPointOnLine 5 wp1' wp2' cp2
isPushedThrough = isRHS wp1 wp2 cp2 && isJust (intersectSegSeg cp1 cp2 wp1 wp2)
src/Dodge/WorldEvent.hs
+1
View File
@@ -21,6 +21,7 @@ import Dodge.WorldEvent.SpawnParticle
import Dodge.LightSources
import Dodge.Creature.State.Data
import Dodge.Data
import Dodge.Data.DamageType
--import Dodge.Base
import Geometry
--import Picture
src/Dodge/WorldEvent/Explosion.hs
+2 -1
View File
@@ -4,8 +4,9 @@ Explosions: creation of shockwave and particles at a given point.
module Dodge.WorldEvent.Explosion
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Default
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base.Collide
import Dodge.WorldEvent.SpawnParticle
--import Dodge.WorldEvent.Flash
src/Dodge/WorldEvent/HitEffect.hs
+1
View File
@@ -1,6 +1,7 @@
module Dodge.WorldEvent.HitEffect
where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Creature.State.Data
import Geometry
src/Dodge/WorldEvent/Shockwave.hs
+2 -1
View File
@@ -4,10 +4,11 @@ module Dodge.WorldEvent.Shockwave
)
where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.WorldEvent.DamageBlock
import Dodge.Creature.State.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Picture.Layer
import Geometry
import Picture
src/Dodge/WorldEvent/Sound.hs
+2
View File
@@ -1,8 +1,10 @@
module Dodge.WorldEvent.Sound
where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.SoundLogic
import System.Random
import Geometry.Data
import Control.Lens
src/Dodge/WorldEvent/SpawnParticle.hs
+3 -1
View File
@@ -4,10 +4,12 @@ Creation of particles in the world.
module Dodge.WorldEvent.SpawnParticle
where
import Dodge.Data
import Dodge.Data.DamageType
import Dodge.Data.SoundOrigin
import Dodge.Default
import Dodge.Creature.State.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Base.Collide
import Dodge.Picture
--import Dodge.Picture.Layer
src/Dodge/WorldEvent/ThingsHit.hs
+3 -2
View File
@@ -5,7 +5,8 @@ module Dodge.WorldEvent.ThingsHit
where
import Dodge.Data
import Dodge.Base
import Dodge.Base.Zone
import Dodge.Zone
import Dodge.Zone.Data
import Geometry
import qualified Data.IntMap.Strict as IM
@@ -27,7 +28,7 @@ thingsHit sp ep w
-- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map E3x1 hitCrs)
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1]
hitWls = wallsOnLine sp ep (IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1]
, b<-[y-1,y,y+1]])
(x,y) = zoneOfPoint (0.5 *.* (sp +.+ ep))
f i m = case IM.lookup i m of
src/Dodge/Base/Zone.hs → src/Dodge/Zone.hs
+39 -79
View File
@@ -1,10 +1,8 @@
{- | Deals with the specific implementations of zoning for Dodge.
- These are not yet fixed down. -}
module Dodge.Base.Zone
module Dodge.Zone
where
import Dodge.Data
import Dodge.Zone.Data
import Dodge.Base.Window
import Dodge.Bounds
import Geometry
import Geometry.Zone
@@ -13,29 +11,9 @@ import Data.List
import Data.Bifunctor
import qualified Data.IntMap.Strict as IM
import qualified Data.IntSet as IS
import qualified Data.Vector as V
zoneSize :: Float
zoneSize = 50
--zoneSize = 100
data Zoning a = Zoning
{ _znObjects :: V.Vector (V.Vector a)
, _znSize :: Int
, _znBounds :: Bounds
}
setupZoning :: Int -> Bounds -> a -> Zoning a
setupZoning size bounds x = Zoning
{ _znObjects = V.replicate xsize (V.replicate ysize x)
, _znSize = size
, _znBounds = bounds
}
where
toInt y = (ceiling y `div` size) + 1
xFloatSize = _bdMaxX bounds - _bdMinX bounds
yFloatSize = _bdMaxX bounds - _bdMinX bounds
xsize = toInt xFloatSize
ysize = toInt yFloatSize
floorHun :: Float -> Int
floorHun x = floor $ x / zoneSize
@@ -74,18 +52,6 @@ zoneAroundPoint' i (V2 x' y') = IM.fromSet (const ys) xs
xs = IS.fromAscList [x-i..x+i]
ys = IS.fromAscList [y-i..y+i]
-- the laser seemed to be occasionally missing creatures,
-- if this reoccurs, maybe change
-- divide line factor from 2 to 1.5
bres :: Point2 -> Point2 -> [(Int,Int)]
bres a b = digitalLine (zoneOfPoint a) (zoneOfPoint b)
bresx :: Point2 -> Point2 -> [(Int,Int)]
bresx a b = digitalLine (x-1,y-1) (x'-1,y'-1)
where
(x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (V2 aa ab) (V2 ba bb)
= nub
@@ -97,11 +63,6 @@ zoneOfLine (V2 aa ab) (V2 ba bb)
zoneOfLineIntMap :: Point2 -> Point2 -> IM.IntMap IS.IntSet
--{-# INLINE zoneOfLineIntMap #-}
zoneOfLineIntMap = ddaExt zoneSize
--zoneOfLineIntMap a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
-- where
-- (x,y) = zoneOfPoint a
-- (x',y') = zoneOfPoint b
expandLine :: [(Int,Int)] -> IM.IntMap IS.IntSet
--{-# INLINE expandLine #-}
@@ -115,19 +76,17 @@ expandLine xs = IM.map expandSet
where
mk = IS.findMax s
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
zoneOfCircle :: Point2 -> Float -> [(Int,Int)]
zoneOfCircle p r = concatMap zoneNearPoint $ divideCircle (1.5 * zoneSize) p r
-- looking at this again, I am not convinced it deals correctly with the
-- rotation of the world
zoneOfScreen :: World -> [(Int,Int)]
zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
zoneOfScreen w =
[(a,b)
| a <- [x - n .. x + n]
, b <- [y - n .. y + n]
]
where
(x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling $ wh / (_cameraZoom w * zoneSize)
@@ -135,9 +94,6 @@ zoneOfScreen w = [(a,b) | a <- [x - n .. x + n]
zoneOfDoubleScreen :: World -> [(Int,Int)]
zoneOfDoubleScreen w = (,) <$> xs <*> ys
-- [(a,b) | a <- xs
-- , b <- ys
-- ]
where
(x,y) = zoneOfPoint $ _cameraCenter w
n = ceiling (wh / (_cameraZoom w * zoneSize)) * 2
@@ -154,28 +110,25 @@ zoneOfSight w =
where
(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon w ++ [_cameraViewFrom w]
-- TODO sort out zoning of walls properly
wallsDoubleScreen :: World -> IM.IntMap Wall
wallsDoubleScreen w = _walls w
-- = foldl' (flip $ IM.union . \i -> innerFold (f i (_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 (getWindowX w) (getWindowY w)
-- xs = [x - n .. x + n]
-- ys = [y - n .. y + n]
wallsOnScreen :: World -> IM.IntMap Wall
wallsOnScreen w -- = wallsNearZones (zoneOfScreen w) w
= foldl' (flip $ IM.union . \i -> innerFold (f i (_wallsZone w))) IM.empty xs
wallsDoubleScreen w
= foldl' (flip $ 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 (getWindowX w) (getWindowY w)
xs = [x - n .. x + n]
ys = [y - n .. y + n]
wallsOnScreen :: World -> IM.IntMap Wall
wallsOnScreen w
= foldl' (flip $ 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
@@ -188,7 +141,7 @@ wallsOnScreen w -- = wallsNearZones (zoneOfScreen w) w
wallsNearZones :: [(Int,Int)] -> World -> IM.IntMap Wall
wallsNearZones is w -- = IM.unions [f b $ f a $ _wallsZone w | (a,b) <- is]
= foldl' (flip $ IM.union . \(a,b) -> f b (f a (_wallsZone w))) IM.empty is
= foldl' (flip $ IM.union . \(a,b) -> f b (f a (_znObjects $ _wallsZone w))) IM.empty is
where
f i m = case IM.lookup i m of
Just val -> val
@@ -208,6 +161,14 @@ lookLookup i j z = case IM.lookup i z of
lookLookups :: [(Int,Int)] -> IM.IntMap (IM.IntMap a) -> [a]
lookLookups xs z = mapMaybe (flip (uncurry lookLookup) z) xs
cloudsNearPoint :: Point2 -> World -> [Cloud]
--cloudsNearPoint p w = IM.unions [f b $ f a $ _cloudsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
cloudsNearPoint p w = f (IM.lookup x (_znObjects $ _cloudsZone w) >>= IM.lookup y)
where
(x,y) = cloudZoneOfPoint p
f Nothing = []
f (Just l) = l
-- possible BUG, was associated with thingsHitLongLine
-- assumes _wallsZone is correct level generation
-- there is certainly a problem somewhere here: it may be in the zoning, or
@@ -216,27 +177,26 @@ wallsAlongLine :: Point2 -> Point2 -> World -> IM.IntMap Wall
--{-# INLINE wallsAlongLine #-}
wallsAlongLine a b w = IM.foldlWithKey' g IM.empty kps
where
g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s)) m
g m x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s)) m
kps = zoneOfLineIntMap a b
f i m = case IM.lookup i m of
Just val -> val
_ -> IM.empty
wallsNearZone' :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
{-# INLINE wallsNearZone' #-}
wallsNearZone' im w = IM.foldrWithKey' g IM.empty im
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _wallsZone w) s))
wallsNearZone :: IM.IntMap IS.IntSet -> World -> IM.IntMap Wall
{-# INLINE wallsNearZone #-}
wallsNearZone im w = IM.foldrWithKey' g IM.empty im
where g x s = IM.union (IM.unions (IM.restrictKeys (f x $ _znObjects $ _wallsZone w) s))
f i m = case IM.lookup i m of Just val -> val
_ -> IM.empty
wallsAlongCirc :: Point2 -> Float -> World -> IM.IntMap Wall
wallsAlongCirc p r w = IM.unions [f y $ f x $ _wallsZone w | (x,y) <- zoneOfCircle p r]
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
wallsNearPoint :: Point2 -> World -> IM.IntMap Wall
wallsNearPoint p w = IM.unions [f b $ f a $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
wallsNearPoint p w = IM.unions [f b $ f a $ _znObjects $ _wallsZone w | a<-[x-1,x,x+1] , b<-[y-1,y,y+1]]
where
(x,y) = zoneOfPoint p
f i m = case IM.lookup i m of
src/Dodge/Zone/Data.hs
+13
View File
@@ -0,0 +1,13 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StrictData #-}
module Dodge.Zone.Data
where
import Control.Lens
import qualified Data.IntMap.Strict as IM
data Zone a = Zone
{ _znObjects :: IM.IntMap (IM.IntMap a)
, _znSize :: Float
}
makeLenses ''Zone
src/Hetris/Base.hs
-24
View File
@@ -1,24 +0,0 @@
module Hetris.Base
where
import Shader.Data
import Shader.Compile
--import qualified Data.Vector.Unboxed.Mutable as MV
--import Control.Monad.Primitive
--import qualified Data.Array.Repa as R
import Linear.V2
data World = World
{ _placedBlocks :: [[V2 Float]]
, _polyShader :: FullShader
}
initWorld :: IO World
initWorld = do
let pb = replicate 20 [0,0,0,0,0,1,1,1,1,1]
theShader <- makeShader "twoD/basic" [vert,frag] [3,4] ETriangles
return $ World
{_placedBlocks = pb
,_polyShader = theShader
}