diff --git a/data/sound/seagullChatter.CHUGUGUG.10000.wav b/data/sound/seagullChatter.CHUGUGUG.10000.wav index 8fcb5ab1b..bb1437637 100644 Binary files a/data/sound/seagullChatter.CHUGUGUG.10000.wav and b/data/sound/seagullChatter.CHUGUGUG.10000.wav differ diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 5eceec7f9..41faa3678 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -163,7 +163,7 @@ startCr = defaultCreature {- | Items you start with. -} startInvList :: [Item] startInvList = - [ lasDrones + [ ] startInventory :: IM.IntMap Item startInventory = IM.fromList $ zip [0..defaultInvSize -1] $ startInvList ++ repeat NoItem @@ -191,6 +191,7 @@ stackedInventory = IM.fromList (zip [0..25] ,flamer ,poisonSprayer ,launcher + ,lasDrones --,lasGun --,grenade --,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 9d84d15bd..60d74d718 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -7,6 +7,7 @@ import Geometry.Data import Dodge.Data import Dodge.Creature.State.Data import Dodge.Room +import Dodge.Room import Dodge.Placement.Instance.Button import Dodge.Tree import Dodge.Annotation @@ -34,6 +35,7 @@ import qualified Data.IntMap.Strict as IM initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree = padSucWithCorridors $ treeFromTrunk [[AnoApplyInt 0 startRoom] + , [AnoApplyInt 2 room2] , [AnoApplyInt 1 lasSensorTurretTest] -- ,[ChainAnos -- [[SetLabel 0 $ return $ roomRectAutoLinks 200 200 diff --git a/src/Dodge/Item/Data.hs b/src/Dodge/Item/Data.hs index 275cf59c1..801028e9f 100644 --- a/src/Dodge/Item/Data.hs +++ b/src/Dodge/Item/Data.hs @@ -38,6 +38,7 @@ data ItemIdentity | RemoteLauncher | LightningGun | PoisonSprayer + | FlatShield deriving (Eq,Show,Ord,Enum) data AimStance diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index cbddf029f..ba0b88d06 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -54,6 +54,7 @@ flatShield = defaultEquipment , _itAimStance = TwoHandFlat , _itEffect = effectOnOffEquip createShieldWall removeShieldWall , _itName = "SHIELD" + , _itIdentity = FlatShield } flatShieldEquipSPic :: Item -> SPic flatShieldEquipSPic _ = diff --git a/src/Dodge/Item/Weapon/Drone.hs b/src/Dodge/Item/Weapon/Drone.hs index 31602e7f4..e36ab9253 100644 --- a/src/Dodge/Item/Weapon/Drone.hs +++ b/src/Dodge/Item/Weapon/Drone.hs @@ -73,5 +73,5 @@ aDroneWithItemParams it cr w = over props (IM.insert i theShell) w , _pjVel = rotateV dir (V2 1 0) , _prDraw = _amPjDraw am , _pjID = i - , _pjUpdate = \_ -> id + , _pjUpdate = const id } diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 3270beae5..d90964383 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -69,9 +69,10 @@ placeRoomWires rm w = IM.foldr ($) w placeWire :: Room -> RoomWire -> RoomWire -> World -> World placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape - %~ (col ( (thinHighBarChain h2 $ map (shiftPointBy rs) doOrdering) <> - (barPP 1.5 (addZ h1 p) (addZ h2 p)) - ) <> + %~ (col ( thinHighBarChain h2 (map (shiftPointBy rs) doOrdering) + <> barPP 1.5 (addZ h1 p) (addZ h2 p) + ) + <> ) where --TODO use rmWalls for non convex rooms diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index a73707331..174c05b78 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -113,6 +113,9 @@ psPt ps pt = Placement ps pt Nothing (const Nothing) sPS :: Point2 -> Float -> PSType -> Placement sPS p a pt = Placement (PS p a) pt Nothing (const Nothing) +sps :: PlacementSpot -> PSType -> Placement +sps ps pt = Placement ps pt Nothing (const Nothing) + plRRpt :: Int -> PSType -> Placement plRRpt i pt = Placement (PSRoomRand i) pt Nothing (const Nothing) @@ -153,6 +156,9 @@ jps0PushPS pst f = Just . Placement (PS (V2 0 0) 0) pst Nothing ps0j :: PSType -> Placement -> Placement ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (const $ Just plmnt) +psj :: PlacementSpot -> PSType -> Placement -> Placement +psj ps pst plmnt = Placement ps pst Nothing (const $ Just plmnt) + ps0jPushPS :: PSType -> Placement -> Placement ps0jPushPS pst plmnt = Placement (PS (V2 0 0) 0) pst Nothing (\p -> Just $ plmnt & plSpot .~ _plSpot p) diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs new file mode 100644 index 000000000..9ff36904b --- /dev/null +++ b/src/Dodge/LockAndKey.hs @@ -0,0 +1,18 @@ +module Dodge.LockAndKey where +import Dodge.Data +import Dodge.Tree +import Dodge.LevelGen.Data +import Dodge.Room +--import Dodge.Item.Equipment + +import System.Random +import Control.Monad.State + +lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , [ItemIdentity] ) ] +lockRoomKeyItems = + [ (const $ return $ chainUses $ map singleUseAll [door,lasTunnel,door] , [FlatShield] ) + , (lasCenSensEdge, [FlatShield,Launcher,TeslaGun] ) + ] + +itemRooms :: [(ItemIdentity, Room)] +itemRooms = [] diff --git a/src/Dodge/Placement/Instance/Sensor.hs b/src/Dodge/Placement/Instance/Sensor.hs index a7aaa7d01..83be85628 100644 --- a/src/Dodge/Placement/Instance/Sensor.hs +++ b/src/Dodge/Placement/Instance/Sensor.hs @@ -14,18 +14,19 @@ import Data.Either damageSensor :: (DamageType -> Either Int Int) -- Left gets sensed, Right does damage + -> Float -> (Machine -> World -> World) -> PlacementSpot -> Placement -damageSensor damF upf ps = pContID ps ( PutLS theLS) +damageSensor damF wdth upf ps = pContID ps ( PutLS theLS) $ \lsid -> Just $ spNoID ps $ PutMachine yellow (reverse $ square wdth) defaultMachine - { _mcDraw = sensorSPic + { _mcDraw = sensorSPic wdth , _mcUpdate = \mc w -> upf mc $ sensorUpdate damF mc w , _mcLSs = [lsid] } where theLS = defaultLS { _lsPos = V3 0 0 30 , _lsIntensity = 0.1 } -lightSensor :: (Machine -> World -> World) -> PlacementSpot -> Placement +lightSensor :: Float -> (Machine -> World -> World) -> PlacementSpot -> Placement lightSensor = damageSensor senseLasering senseLasering :: DamageType -> Either Int Int @@ -47,9 +48,6 @@ sensorUpdate damF mc w = w & machines . ix mcid %~ upmc ni = fromIntegral x / 1000 upls = lsIntensity .~ V3 ni ni ni -sensorSPic :: Machine -> SPic -sensorSPic _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth) +sensorSPic :: Float -> Machine -> SPic +sensorSPic wdth _ = ( colorSH yellow $ upperPrismPoly 25 (square wdth) , mempty ) - -wdth :: Float -wdth = 10 diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index d2955de7c..71db3d0ef 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -10,6 +10,17 @@ import Color import Data.List import Control.Lens +heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement +heightWallPS spot h ps = psj spot (PutForeground . colorSH col $ upperPrismPoly h ps) + $ sps spot $ PutWall ps theWall + where + col = _wlColor defaultWall + theWall = defaultWall + { _wlOpacity = SeeAbove + , _wlDraw = False + , _wlHeight = h + } + heightWall :: Float -> [Point2] -> Placement heightWall h ps = ps0j (PutForeground . colorSH col $ upperPrismPoly h ps) $ sps0 $ PutWall ps theWall diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index b196fa1ec..8171cbb10 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -62,7 +62,7 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r Nothing -> ((w,rm),[plmnt]) Just plmnt' -> placeSpot (w,rm) plmnt' where - searchedPoss [] = error "no correct pos type for lnk placement" + searchedPoss [] = Nothing searchedPoss (pos:poss) = case extract pos of Nothing -> second (pos:) <$> searchedPoss poss Just (ps,rmpos) -> Just ( ps,rmpos:poss) diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index c8993dd76..3b761353c 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -18,17 +18,22 @@ atFstLnkOut = PSPos f (const id) Nothing f (OutLink 0 p a) = Just (PS p a, OutLink 0 p a) f _ = Nothing -atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) - -> PlacementSpot -atFstLnkOutShiftBy theshift = PSPos f (const id) Nothing +atNthLnkOutShiftBy :: Int -> ((Point2,Float) -> (Point2,Float)) -> PlacementSpot +atNthLnkOutShiftBy n theshift = PSPos f (const id) Nothing where - f (OutLink 0 p a) = Just (PS p' a', OutLink 0 p a) + f (OutLink i p a) | n == i = Just (PS p' a', OutLink n p a) where (p',a') = theshift (p,a) f _ = Nothing +atFstLnkOutShiftBy :: ((Point2,Float) -> (Point2,Float)) -> PlacementSpot +atFstLnkOutShiftBy = atNthLnkOutShiftBy 0 + atFstLnkOutShiftInward :: Float -> PlacementSpot -atFstLnkOutShiftInward x = atFstLnkOutShiftBy f +atFstLnkOutShiftInward = atNthLnkOutShiftInward 0 + +atNthLnkOutShiftInward ::Int -> Float -> PlacementSpot +atNthLnkOutShiftInward n x = atNthLnkOutShiftBy n f where f (p,a) = (p +.+ rotateV a (V2 0 (negate x)),a) diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index a028afe83..51f0beca8 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -1,8 +1,8 @@ -{- -Specification of individual rooms. --} +{- Specification of individual rooms. -} module Dodge.Room ( module Dodge.Room.Room + , module Dodge.Room.RoadBlock + , module Dodge.Room.LasTurret , module Dodge.Room.Foreground , module Dodge.LevelGen.Data , module Dodge.Room.Procedural @@ -12,17 +12,17 @@ module Dodge.Room , module Dodge.Room.Airlock , module Dodge.Room.LongDoor , module Dodge.Room.Branch - , module Dodge.Room.RoadBlock , module Dodge.Room.Teleport , module Dodge.Room.Start , module Dodge.Room.Boss , module Dodge.Room.Treasure ) where import Dodge.Room.Room +import Dodge.Room.RoadBlock +import Dodge.Room.LasTurret import Dodge.Room.Treasure import Dodge.Room.Boss import Dodge.Room.Start -import Dodge.Room.RoadBlock import Dodge.Room.Teleport import Dodge.Room.Branch import Dodge.Room.Foreground diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index e44da9729..b65cf0d44 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -22,6 +22,7 @@ corridor = defaultRoom , _rmBound = [ rectNSWE 50 30 0 40 ] , _rmFloor = [makeTileFromPoly poly 2] , _rmRandPSs = [psRandRanges (10,30) (30,60) (0,2*pi)] + , _rmName = "Corridor" } where poly = rectNSWE 80 0 0 40 diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs new file mode 100644 index 000000000..58d98c906 --- /dev/null +++ b/src/Dodge/Room/LasTurret.hs @@ -0,0 +1,81 @@ +module Dodge.Room.LasTurret where +import Dodge.LevelGen.Data +import Dodge.PlacementSpot +import Dodge.Data +import Dodge.Tree +import Dodge.Room.Door +import Dodge.Room.Room +import Dodge.Room.Corridor +import Dodge.Room.Link +--import Dodge.Room.Procedural +import Dodge.Room.Foreground +--import Dodge.Room.RoadBlock +import Dodge.Placement.Instance +--import Dodge.Item.Random +--import Dodge.Item.Weapon.BulletGuns +--import Dodge.Item.Weapon.Utility +--import Dodge.LevelGen.Data +--import Geometry.Data +import Geometry +--import Padding +import Color +import Shape + +import Data.Maybe +import Data.Tree +import Control.Monad.State +import Control.Lens +import System.Random + +cenLasTur :: Room +cenLasTur = roomNgon 8 200 & rmPmnts .~ + [ putLasTurret 0.02 + , heightWall 30 (rectNSEW (-90) (-110) 20 (-20)) + , mntLightLnkCond unusedLnkToPS + ] + +lightSensInsideDoor :: Room -> Room +lightSensInsideDoor rm = rm + & rmPmnts %~ ( (psPt atFstLnkOut $ PutForeground $ colorSH yellow $ + thinHighBar 0 (V2 20 (-1)) (V2 20 (-100)) + <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100)) + <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)) : ) + & rmExtPmnt ?~ + extTrigLitPos (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) + ( \tp -> Just $ lightSensor 10 (upf $ fromJust $ _plMID tp) (atFstLnkOutShiftInward 100) + ) + where + upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True + | otherwise = w + +lightSensByDoor :: Room -> Room +lightSensByDoor rm = rm + & rmPmnts %~ ( + [ psPt atFstLnkOut $ PutForeground $ colorSH yellow + $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80) + , heightWallPS (atNthLnkOutShiftInward 1 50) 30 (rectNSEW (10) (-10) 20 (-20)) + , heightWallPS (atFstLnkOutShiftInward 100) 30 (rectNSEW (10) (-10) 20 (-20)) + ] ++ ) + & rmExtPmnt ?~ + extTrigLitPos (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) + ( \tp -> Just $ lightSensor 20 (upf $ fromJust $ _plMID tp) (atFstLnkOutShiftBy sensorshift) + ) + where + sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a) + upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True + | otherwise = w + +lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room) +lasSensorTurretTest n = do + cenroom <- randomiseOutLinks $ (lightSensInsideDoor cenLasTur) {_rmLabel = Just n} + let doorroom = switchDoorRoom {_rmTakeFrom = Just n} + return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) + +lasCenSensEdge :: RandomGen g => Int -> State g (SubCompTree Room) +lasCenSensEdge n = do + cenroom <- randomiseOutLinks $ (lightSensByDoor cenLasTur) {_rmLabel = Just n} + let doorroom = switchDoorRoom {_rmTakeFrom = Just n} + return $ treeFromTrunk [PassDown door] (Node (PassDown cenroom) + [treeFromPost [PassDown doorroom] (UseAll door), treeFromPost [UseNone door] (UseNone corridor) + ] + ) diff --git a/src/Dodge/Room/LockAndKeyList.hs b/src/Dodge/Room/LockAndKeyList.hs deleted file mode 100644 index 33cef4b8b..000000000 --- a/src/Dodge/Room/LockAndKeyList.hs +++ /dev/null @@ -1,19 +0,0 @@ -module Dodge.Room.LockAndKeyList - where -import Dodge.LevelGen.Data -import Dodge.Room.RoadBlock -import Dodge.Room.Boss - -import Control.Monad.State -import System.Random -import Data.Tree - -lockAndKeyRoomList :: RandomGen g => - [ (State g (Tree (Either Room Room)) - ,State g (Tree (Either Room Room)) - ) ] -lockAndKeyRoomList = - [ ( fmap (pure . Right) armouredCorridor - , fmap (fmap Left) armouredChasers - ) - ] diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index f1598d7bb..7326e764b 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -181,7 +181,7 @@ rot90Around cen p = cen +.+ vNormal (p -.- cen) roomMiniIntro :: RandomGen g => State g (SubCompTree Room) roomMiniIntro = do midroom <- join $ takeOne [miniTree2,glassLesson] - return $ chainUses $ [return $ UseAll door, midroom,return $ UseAll corridor] + return $ chainUses [return $ UseAll door, midroom,return $ UseAll corridor] roomCenterPillar :: RandomGen g => State g Room roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst) @@ -226,6 +226,7 @@ roomNgon n x = defaultRoom , _rmPmnts = [] , _rmBound = [poly] , _rmFloor = [makeTileFromPoly poly 9] + , _rmName = show n ++ "gon" } where rot = 2*pi / fromIntegral n diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 587de0867..feb5c094b 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -1,8 +1,8 @@ -module Dodge.Room.Start - where +module Dodge.Room.Start where import Dodge.LevelGen.Data import Dodge.PlacementSpot import Dodge.Room.RunPast +import Dodge.Room.LasTurret import Dodge.Data import Dodge.Default import Dodge.Tree @@ -49,44 +49,23 @@ minigunfakeout = do ,PassDown keyholeCorridor,PassDown corridor]) `treeFromPost` UseAll door -centralLasTurret :: Room -centralLasTurret = roomNgon 8 200 & rmPmnts .~ - [ putLasTurret 0.02 - , heightWall 30 (rectNSEW (-90) (-110) 20 (-20)) - , mntLightLnkCond unusedLnkToPS - --, spanColLightI 0.5 98 (V2 0 (-5)) (V2 0 5) - , psPt atFstLnkOut $ PutForeground $ colorSH yellow $ - thinHighBar 0 (V2 20 (-1)) (V2 20 (-100)) - <> thinHighBar 0 (V2 0 (-100)) (V2 20 (-100)) - <> barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80) - ] - & rmExtPmnt ?~ - extTrigLitPos (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) - ( \tp -> Just $ lightSensor (upf $ fromJust $ _plMID tp) (atFstLnkOutShiftInward 100) - ) - where - upf trid mc w | _mcSensor mc > 900 = w & triggers . ix trid .~ const True - | otherwise = w - -lasSensorTurretTest :: RandomGen g => Int -> State g (SubCompTree Room) -lasSensorTurretTest n = do - cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just n} - let doorroom = switchDoorRoom {_rmTakeFrom = Just n} - return $ treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door) rezThenLasTurret :: RandomGen g => State g (SubCompTree Room) rezThenLasTurret = do rbox <- rezBoxStart - cenroom <- randomiseOutLinks $ centralLasTurret {_rmLabel = Just 0} + cenroom <- randomiseOutLinks $ (lightSensInsideDoor cenLasTur) {_rmLabel = Just 0} let doorroom = switchDoorRoom {_rmTakeFrom = Just 0} contTree = treeFromPost [PassDown cenroom,PassDown doorroom] (UseAll door) return $ rbox `passUntilUseAll` [contTree] +room2 :: RandomGen g => Int -> State g (SubCompTree Room) +room2 = lasCenSensEdge + startRoom :: RandomGen g => Int -> State g (SubCompTree Room) startRoom i = join $ takeOne [-- roomMiniIntro - minigunfakeout - , rezBoxesWp + --minigunfakeout + rezBoxesWp , rezBoxesThenWeaponRoom , rezBoxThenWeaponRoom , rezBoxesWpCrit @@ -220,7 +199,7 @@ startRoom' = do , tankSquareEmboss4 (dim orange) 50 (h-60) , tankSquare (dim orange) 50 50 , tankSquare (dim orange) 50 120 - , lightSensor (const id) (PS (V2 (0.8*w) (0.25*h)) 0) + , lightSensor 10 (const id) (PS (V2 (0.8*w) (0.25*h)) 0) , putLasTurret 0.005 & plSpot .~ PS (V2 (0.8*w) (0.8*h)) 0 , sps0 $ PutForeground $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) ] diff --git a/src/Dodge/RoomComplex.hs b/src/Dodge/RoomComplex.hs new file mode 100644 index 000000000..8e0a76296 --- /dev/null +++ b/src/Dodge/RoomComplex.hs @@ -0,0 +1 @@ +module Dodge.RoomComplex where diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index b51946313..e675dc3d5 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -14,9 +14,9 @@ import Data.Tree expandTree :: CompTree a -> Tree a expandTree (Node root extChildren) = case root of Node (UseAll x) _ -> Node x (map expandTree extChildren) - Node (UseSome is x) _ -> Node x (map expandTree $ map (\i -> extChildren !! i) is) + Node (UseSome is x) _ -> Node x (map (expandTree . \i -> extChildren !! i) is) Node (UseNone _) _ -> fmap _unCompose root - Node (PassDown x) xs -> Node x $ map (expandTree . (\ct -> Node ct extChildren)) xs + Node (PassDown x) xs -> Node x $ map (expandTree . (`Node` extChildren)) xs Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs $ map (:[]) extChildren ++ repeat [] diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index d669679bd..4f2eeaa8b 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -9,6 +9,7 @@ import Dodge.Room.Link import Dodge.Tree.Polymorphic import Geometry.ConvexPoly import Geometry.Data +import Padding import Data.Tree import Data.Sequence hiding (zipWith) @@ -19,35 +20,40 @@ import Control.Lens hiding (Empty, (<|) , (|>)) type RoomInt = (Room,Int) positionRoomsFromTree :: Tree RoomInt -> IO (Maybe [Room]) -positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) ts Empty +positionRoomsFromTree (Node (r,i) ts) = posRms (map pointsToPoly $ _rmBound r) (r,i) 0 ts Empty posRms :: [ConvexPoly] -> RoomInt + -> Int -- ^ the number of children already placed -> [Tree RoomInt] -> Seq (Tree RoomInt) -> IO (Maybe [Room]) -posRms bounds (parent,_) [] st = case st of +posRms bounds (parent,_) _ [] st = case st of Empty -> return $ Just [] Node childi ts :<| tseq - -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi ts tseq -posRms bounds parenti (t@(Node (_,i') _):ts) tseq = do - putStr $ "Trying to place room " ++ show i' ++ ": " - tryLinks 0 (_rmLinks parent) + -> fmap (finalLinksUpdate parent:) <$> posRms bounds childi 0 ts tseq +posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do + putStr $ (rpns 20 (_rmName cr ++ "-" ++ show i')) + ++ (rpns 9 (" child " ++ show numChild )) + ++ (rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i )) + tryLinks (0::Int) (_rmLinks parent) where + rpns x s = rightPadNoSquash x ' ' s parent = fst parenti tryLinks _ [] = putStrLn "all links tried" >> return Nothing tryLinks j (l:ls) | clipping = tryLinks (j+1) ls | otherwise = do - putStrLn $ "placing at link " ++ show j - mayrs <- posRms (convexBounds ++ bounds) (first upr parenti) ts (tseq |> shiftedt) + putStrLn $ "placed at link " ++ show j + mayrs <- posRms (convexBounds ++ bounds) + (first upr parenti) (numChild + 1) ts (tseq |> shiftedt) case mayrs of Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls Just rs -> return (Just rs) where convexBounds = map pointsToPoly $ _rmBound r' clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) - upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink j) l :) + upr rm = doLnkEff l $ rm & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink numChild) l :) l' = shiftLinkBy (_rmShift parent) l r' = doRoomShift . fst $ rootLabel shiftedt shiftedt = applyToRoot (first $ shiftRoomShiftToLink l') t diff --git a/src/Padding.hs b/src/Padding.hs index 81b6110d3..16bd84bbf 100644 --- a/src/Padding.hs +++ b/src/Padding.hs @@ -2,6 +2,7 @@ module Padding ( leftPad , rightPad + , rightPadNoSquash , midPad , midPadL , rotU @@ -18,6 +19,10 @@ rightPad :: Int -> a -> [a] -> [a] {-# INLINE rightPad #-} rightPad i x xs = take i $ xs ++ repeat x +rightPadNoSquash :: Int -> a -> [a] -> [a] +{-# INLINE rightPadNoSquash #-} +rightPadNoSquash i x xs = take (max i $ length xs) $ xs ++ repeat x + midPad :: Int -> a -> [a] -> [a] -> [a] {-# INLINE midPad #-} midPad i x xs ys = xs ++ replicate j x ++ ys