diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index ed93e5393..4269e558f 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -613,19 +613,10 @@ data PlacementSpot = PS , _psRot :: Float , _psType :: PSType } -data Room = Room - { _rmPolys :: [Poly] - , _rmLinks :: [(Point2,Float)] - , _rmPath :: [(Point2, Point2)] - , _rmPS :: [PlacementSpot] - , _rmBound :: Poly - } data SubNode a = SN a | InLink | OutLink -data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float} -makeLenses ''RoomLink makeLenses ''World makeLenses ''Cloud makeLenses ''Creature @@ -652,7 +643,6 @@ makeLenses ''PressPlate makeLenses ''Button makeLenses ''PSType makeLenses ''PlacementSpot -makeLenses ''Room numColor :: Int -> Color numColor 0 = (1,0,0,1) diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 2fe3f6133..8c3df61de 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -6,6 +6,7 @@ import Dodge.Data import Dodge.Base import Dodge.CreatureAction import Dodge.LoadConfig +import Dodge.Event.Test import SDL import Data.Maybe @@ -46,9 +47,6 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of Just (Right but) -> _btEvent but but w Nothing -> w -testEvent :: World -> World -testEvent w = w - pauseGame :: World -> World pauseGame w = w {_menuState = PauseMenu} diff --git a/src/Dodge/Event/Test.hs b/src/Dodge/Event/Test.hs new file mode 100644 index 000000000..251d19fb6 --- /dev/null +++ b/src/Dodge/Event/Test.hs @@ -0,0 +1,98 @@ +module Dodge.Event.Test + ( testEvent + ) + where +import Dodge.Data +import Dodge.Base +import Dodge.Default + +import Picture +import Geometry + +import qualified Data.IntMap as IM +import Control.Lens + +testEvent :: World -> World +testEvent w = over walls (IM.union testWalls) w + where + k = newKey $ _walls w + setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..] + + testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls) + + polyPairs = makeLoopPairs + $ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)] +-- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)] + polyWalls = map (wallWithCol red . flat2) polyPairs + + errorWallPair = + (9,[(-340.0,60.0),(-320.0,60.0)]) +-- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)]) + errorWall = wallWithCol green $ snd errorWallPair + + errorWallPairs = + [(1,[(-400.0,59.999996),(-340.0,60.0)]) + ,(12,[(-340.0,60.0),(-340.0,59.999996)]) + ] +-- [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)]) +-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)]) +-- ] + errorWalls = map (wallWithCol blue . snd) errorWallPairs + + startWallPairs = + [(0,[(-320.0,60.0),(-320.0,100.0)]) + ,(1,[(-400.0,59.999996),(-320.0,60.0)]) + ,(2,[(-400.0,100.0),(-400.0,59.999996)]) + ,(3,[(-320.0,100.0),(-400.0,100.0)]) + ,(4,[(-260.0,60.0),(-225.35898,80.0)]) + ,(5,[(-260.0,100.0),(-260.0,60.0)]) + ,(6,[(-225.35898,80.0),(-260.0,100.0)]) + ] +-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)]) +-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)]) +-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)]) +-- ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)]) +-- ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)]) +-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)]) +-- ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)]) +-- ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)]) +-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)]) +-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)]) +-- ] + startWalls = map (wallWithCol yellow . snd) startWallPairs + + endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs + endWallPairs = + [(0,[(-320.0,60.0),(-320.0,100.0)]) + ,(1,[(-400.0,59.999996),(-340.0,60.0)]) + ,(2,[(-400.0,100.0),(-400.0,59.999996)]) + ,(3,[(-320.0,100.0),(-340.0,100.0)]) + ,(4,[(-260.0,60.0),(-225.35898,80.0)]) + ,(5,[(-260.0,100.0),(-260.0,60.0)]) + ,(6,[(-225.35898,80.0),(-260.0,100.0)]) + ,(9,[(-340.0,60.0),(-320.0,60.0)]) + ,(11,[(-340.0,100.0),(-400.0,100.0)]) + ,(12,[(-340.0,60.0),(-340.0,59.999996)]) + ] +-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)]) +-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)]) +-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)]) +-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)]) +-- ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)]) +-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)]) +-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)]) +-- ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)]) +-- ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)]) +-- ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)]) +-- ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)]) +-- ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)]) +-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)]) +-- ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)]) +-- ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)]) +-- ] + +--flat2 :: (a,a) -> [a] +--flat2 (x,y) = [x,y] + +wallWithCol :: Color -> [Point2] -> Wall +wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 17c34ac08..920bcd929 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -8,6 +8,7 @@ import Picture import Dodge.Data import Dodge.Rooms +import Dodge.Room.Data import Dodge.Base import Dodge.Layout import Dodge.Creature @@ -32,44 +33,44 @@ lev1 = do ( [return $ return $ Right deadEndRoom ] - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,glassSwitchBack >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [miniRoom3] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [roomCCrits] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++[roomMiniIntro] - ++ [longRoom >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door +-- ,glassSwitchBack >>= randomiseLinks] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [miniRoom3] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [roomCCrits] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++[roomMiniIntro] +-- ++ [longRoom >>= randomiseLinks] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] ++ firstWeapon - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [randomiseLinks =<< pistolerRoom] - ++ [return $ connectRoom door] - ++ [randomiseLinks =<< shooterRoom] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] - ++ [return $ connectRoom corridor] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor] - ++[return $ connectRoom corridor,return $ connectRoom door] - ++ [shootingRange] - ++ (replicate 3 $ randomiseLinks corridor) - ++[roomMiniIntro] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,slowDoorRoom] - ++ [return $ connectRoom corridor - ,spawnerRoom - ,return $ connectRoom corridor - ] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [randomiseLinks =<< pistolerRoom] +-- ++ [return $ connectRoom door] +-- ++ [randomiseLinks =<< shooterRoom] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] +-- ++ [return $ connectRoom corridor] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom corridor] +-- ++[return $ connectRoom corridor,return $ connectRoom door] +-- ++ [shootingRange] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++[roomMiniIntro] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door +-- ,slowDoorRoom] +-- ++ [return $ connectRoom corridor +-- ,spawnerRoom +-- ,return $ connectRoom corridor +-- ] ) $ randomiseLinks corridor diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 997ad5613..e80e45f6d 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -10,6 +10,7 @@ import Dodge.Base import Dodge.RandomHelp import Dodge.Path import Dodge.Layout.Tree +import Dodge.Room.Data import Geometry diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 12d0347a0..259f581fb 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -4,7 +4,7 @@ module Dodge.LevelGen ( module Dodge.LevelGen , cutWalls , createInnerWalls - , checkWalls +-- , checkWalls , nubWalls , pairsToGraph , makeButton @@ -14,6 +14,7 @@ module Dodge.LevelGen import Dodge.Data import Dodge.Base +import Dodge.Room.Data import Dodge.LevelGen.Block import Dodge.LevelGen.LineBlock diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 4d2594ce7..c46ed66b1 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -18,14 +18,18 @@ import qualified Data.Set as S -- given a polygon of points and collection of walls, cuts out the polygon -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points -cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall -cutWalls qs walls = createPolyWalls rs - . IM.filter (not.wallIsZeroLength) - . removeWallsInPolygon ps - $ fuseWallsWith zs cwals - where (zs,cwals) = cutWallsWithPoints ps walls - ps = orderPolygon qs - rs = orderPolygon $ nub $ zs ++ qs +cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls' qs walls = + IM.filter (not.wallIsZeroLength) + . fuseWallsWith zs + .createPolyWalls rs + . IM.filter (not.wallIsZeroLength) + . removeWallsInPolygon ps + $ fuseWallsWith zs cwals + where + (zs,cwals) = cutWallsWithPoints ps walls + ps = orderPolygon qs + rs = orderPolygon $ nub $ zs ++ qs -- the overall procedure is: -- split walls that intersect with the polygon into two -- (possibly three if the wall extends across the polygon) @@ -34,6 +38,30 @@ cutWalls qs walls = createPolyWalls rs -- also remove any walls that ended up zero length -- draw the required new walls along the polygon boundary +cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of + [] -> newWalls + errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n" + ++ unlines (map (show . f) errs) + ++ "\nStart walls:\n" + ++ unlines (map (show . g) (IM.elems wls)) + ++ "\nEnd walls:\n" + ++ unlines (map (show . g) (IM.elems newWalls)) + where + newWalls = cutWalls' ps wls + newWallsList = IM.elems newWalls + g v = (_wlID v, _wlLine v) + f (v,vs) = (g v, map g vs) + +checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall]) +checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of + [w] -> Nothing + wls -> Just (wl, wls) +checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall]) +checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of + [w] -> Nothing + wls -> Just (wl,wls) + createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) @@ -154,21 +182,20 @@ finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith [] nubWalls :: IM.IntMap Wall -> IM.IntMap Wall nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls -checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall -checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of - Just wl -> error $ show $ _wlLine wl - _ -> wls - -checkWalls wls | (nub $ map _wlLine $ IM.elems wls) - == (map _wlLine $ IM.elems wls) = wls - | otherwise = error "hasdup" +--checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall +--checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of +-- Just wl -> error $ show $ _wlLine wl +-- _ -> wls +-- +--checkWalls wls | (nub $ map _wlLine $ IM.elems wls) +-- == (map _wlLine $ IM.elems wls) = wls +-- | otherwise = error "hasdup" -- idea: create inner walls to draw and to cast shadows createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall createInnerWalls wls = IM.map (createInnerWall wls) wls createInnerWall :: IM.IntMap Wall -> Wall -> Wall ---createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)] createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR] where wl0 = _wlLine wl !! 0 wl1 = _wlLine wl !! 1 @@ -183,14 +210,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR] findWallLeft :: Wall -> IM.IntMap Wall -> Wall findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of [w] -> w - wls -> error $ "findWallLeft: is there a standalone wall? wlIDs: " ++ show (map _wlID wls) + wls -> error $ "findWallLeft: " ++ show (map _wlID wls) ++ " wlLines: "++ show (map _wlLine wls) findWallRight :: Wall -> IM.IntMap Wall -> Wall findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of [w] -> w - wls -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls) - ++ " wlLines: "++ show (map _wlLine wls) + wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++ + show (_wlLine wl) ++ "\nhas a right corner with and only with the walls " + ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls) + ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem" findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls diff --git a/src/Dodge/Rendering/HUD.hs b/src/Dodge/Rendering/HUD.hs index 0b70a324f..3ec96ef85 100644 --- a/src/Dodge/Rendering/HUD.hs +++ b/src/Dodge/Rendering/HUD.hs @@ -102,6 +102,7 @@ mapWall w wl = else Nothing where t = normalizeV (y -.- x) +-- n2 = 2 *.* vNormal t n2 = 20 *.* vNormal t (x:y:_) = (_wlLine wl) c = _wlColor wl diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs new file mode 100644 index 000000000..17aa51aeb --- /dev/null +++ b/src/Dodge/Room/Data.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +module Dodge.Room.Data + where + +import Dodge.Data +import Control.Lens + +data Room = Room + { _rmPolys :: [Poly] + , _rmLinks :: [(Point2,Float)] + , _rmPath :: [(Point2, Point2)] + , _rmPS :: [PlacementSpot] + , _rmBound :: Poly + } +data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float} + +makeLenses ''Room +makeLenses ''RoomLink diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index eae5c6180..a9ca27ae9 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -1,4 +1,8 @@ -module Dodge.Rooms where +module Dodge.Rooms +-- ( module Dodge.Rooms +-- , module Dodge.Rooms.Data +-- ) + where -- imports {{{ import Dodge.Data import Dodge.Item.Weapon @@ -12,6 +16,7 @@ import Dodge.Path import Dodge.Layout import Dodge.LightSources import Dodge.SoundLogic +import Dodge.Room.Data import Dodge.Room.Placement