384 lines
14 KiB
Haskell
384 lines
14 KiB
Haskell
module Dodge.Room.Tutorial where
|
|
|
|
import Dodge.Layout
|
|
import Dodge.Item.Held.Utility
|
|
import Control.Monad
|
|
import qualified Data.IntMap.Strict as IM
|
|
import qualified Data.IntSet as IS
|
|
import Data.Maybe (mapMaybe)
|
|
import qualified Data.Set as S
|
|
import Dodge.Cleat
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Data.MTRS
|
|
import Dodge.Default.Terminal
|
|
import Dodge.Item.Ammo
|
|
import Dodge.Item.Held.Cane
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.Placement.Instance
|
|
import Dodge.PlacementSpot
|
|
import Dodge.Room.Airlock
|
|
import Dodge.Room.Corridor
|
|
import Dodge.Room.Door
|
|
import Dodge.Room.LasTurret
|
|
import Dodge.Room.Link
|
|
import Dodge.Room.Ngon
|
|
import Dodge.Room.Procedural
|
|
import Dodge.Room.RezBox
|
|
import Dodge.Room.RoadBlock
|
|
import Dodge.Room.Room
|
|
import Dodge.Room.Warning
|
|
import Dodge.RoomLink
|
|
import Dodge.Terminal
|
|
import Dodge.Tree.Compose
|
|
import Geometry
|
|
import LensHelp
|
|
import Linear
|
|
import RandomHelp
|
|
import ShortShow
|
|
import TreeHelp
|
|
|
|
tutAnoTree :: State LayoutVars MTRS
|
|
tutAnoTree = do
|
|
foldMTRS
|
|
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
|
|
, corDoor
|
|
, tutHub
|
|
, tutLight
|
|
, tutDrop
|
|
, return $ tToBTree "cor" $ return $ cleatOnward corridor
|
|
---- , AnTree $ pickupTut
|
|
---- , AnTree $ weaponTut
|
|
]
|
|
|
|
foldMTRS ::
|
|
[State LayoutVars (MetaTree Room String)] ->
|
|
State LayoutVars (MetaTree Room String)
|
|
foldMTRS xs = do
|
|
ys <- sequence xs
|
|
return $ foldr1 attachOnward' ys
|
|
|
|
setRoomInt :: Room -> State LayoutVars (Int, Room)
|
|
setRoomInt x = do
|
|
i <- nextLayoutInt
|
|
return (i, x & rmPmnts .:~ sps0 (PutWorldUpdate (f i)))
|
|
where
|
|
f i rid _ gw = gw & genInts . at i ?~ (gw ^?! genRooms . ix rid . rmMID . _Just)
|
|
|
|
setTreeInts :: Tree Room -> State LayoutVars ([Int], Tree Room)
|
|
setTreeInts x = do
|
|
y <- traverse setRoomInt x
|
|
return (foldMap ((: []) . fst) y, fmap snd y)
|
|
|
|
tutDrop :: State LayoutVars (MetaTree Room String)
|
|
tutDrop = do
|
|
x <- shuffleLinks =<< roomNgon 6 100
|
|
i <- nextLayoutInt
|
|
--let y = decontamRoom i
|
|
(j, y) <- setRoomInt (decontamRoom i)
|
|
rm <- roomRectAutoLinks 40 100
|
|
return $
|
|
tToBTree "TutDrop" $
|
|
treePost
|
|
[x & rmInPmnt .:~ (0, t j), y, cleatOnward rm]
|
|
where
|
|
t j = \gw ->
|
|
let x = gw ^? genInts . ix j
|
|
in putMessageTerminal
|
|
terminalColor
|
|
(defaultTerminal & tmBootLines .~ ss <> tlSetStatus (TerminalPressTo $ show x <> "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
|
|
& plSpot
|
|
.~ rprBoolShift
|
|
isUnusedLnk
|
|
(\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
|
|
ss =
|
|
[ makeTermLine "--------------------------------------------"
|
|
, makeTermLine "YOU CAN ONLY CARRY A LIMITED AMOUNT OF ITEMS"
|
|
, makeTermLine "--------------------------------------------"
|
|
]
|
|
<> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
<> [ makeTermLine "USE [F] TO DROP SINGLE ITEMS"
|
|
, makeTermLine "--------------------------------------------"
|
|
]
|
|
<> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
<> [ makeTermLine "YOU CAN SELECT AND MOVE MULTIPLE ITEMS"
|
|
, makeTermLine " WITH THE MOUSE"
|
|
, makeTermLine "-------------------------------------------"
|
|
]
|
|
|
|
cChasm :: State LayoutVars Room
|
|
cChasm = do
|
|
x <- state $ randomR (150, 300)
|
|
y <- state $ randomR (150, 300)
|
|
roomRectAutoLinks x y
|
|
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
|
|
<&> rmLinks %~ setInLinks (isCornerLink SouthWest)
|
|
<&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y -50) 50 0 (x -50))]
|
|
|
|
lChasm :: State LayoutVars Room
|
|
lChasm = do
|
|
x <- state $ randomR (150, 300)
|
|
y <- state $ randomR (150, 300)
|
|
roomRectAutoLinks x y
|
|
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
|
|
<&> rmLinks %~ setInLinks (isCornerLink SouthEast)
|
|
<&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y -50) 0 0 (x -50))]
|
|
|
|
zChasm :: Float -> State LayoutVars Room
|
|
zChasm z = do
|
|
x <- state $ randomR (150, 300)
|
|
y <- state $ randomR (150, 300)
|
|
roomRectAutoLinks x y
|
|
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
|
|
<&> rmLinks %~ setInLinks (isCornerLink SouthEast)
|
|
<&> rmPmnts
|
|
<>~ [ sps0 $ PutChasm (rectNSWE (y / 2 - z) 0 0 (x -50))
|
|
, sps0 $ PutChasm (rectNSWE y (y / 2 + z) 50 x)
|
|
]
|
|
|
|
midChasm :: State LayoutVars Room
|
|
midChasm = do
|
|
x <- state $ randomR (200, 300)
|
|
y <- state $ randomR (200, 300)
|
|
r <- roomRectAutoLinks x y
|
|
cs <- join $ takeOne [cenoct x y, censquare x y]
|
|
shuffleLinks $
|
|
r
|
|
& rmLinks %~ setOutLinks (isMidEdgeLink r North)
|
|
& rmLinks %~ setInLinks (isMidEdgeLink r South)
|
|
& rmPmnts <>~ cs
|
|
where
|
|
censquare x y = do
|
|
z <- state $ randomR (40, 60)
|
|
return [sps0 $ PutChasm (rectNSWE (y - z) z z (x - z))]
|
|
cenoct x y =
|
|
return
|
|
[sps0 $ PutChasm $ (V2 (x / 2) (y / 2) +) <$> polyOrthDist 8 (min x y / 2 - 25)]
|
|
|
|
-- dia x y = [sps0 $ PutChasm [V2 ]
|
|
|
|
polyChasm :: Int -> Float -> State LayoutVars Room
|
|
polyChasm n x =
|
|
shuffleLinks
|
|
=<< ( roomNgon n x
|
|
<&> rmPmnts <>~ [sps0 $ PutChasm $ polyOrthDist n (x -30)]
|
|
<&> rmLinks %~ setOutLinks (\rl -> rl ^. rlPos . _y > 0)
|
|
<&> rmLinks %~ setInLinks (\rl -> rl ^. rlPos . _y < (5 - x))
|
|
)
|
|
|
|
polyChasmC :: Int -> Float -> State LayoutVars Room
|
|
polyChasmC n x =
|
|
roomNgon n x
|
|
<&> rmPmnts <>~ [sps0 $ PutChasm $ rectNSWE x (60 - x) (-40) 40]
|
|
<&> rmLinks %~ setInLinks (\rl -> PolyEdge 1 `S.member` (rl ^. rlType))
|
|
<&> rmLinks %~ setOutLinks (\rl -> PolyEdge (n -1) `S.member` (rl ^. rlType))
|
|
|
|
chasmSimpleMaze :: State LayoutVars Room
|
|
chasmSimpleMaze =
|
|
join $
|
|
takeOne
|
|
[ midChasm
|
|
, zChasm 25
|
|
, lChasm
|
|
, cChasm
|
|
, pc1
|
|
, pc2
|
|
]
|
|
where
|
|
pc1 = do
|
|
i <- takeOne [6, 8]
|
|
x <- state $ randomR (100, 150)
|
|
polyChasm i x
|
|
pc2 = do
|
|
i <- takeOne [6, 8]
|
|
x <- state $ randomR (100, 150)
|
|
polyChasmC i x
|
|
|
|
tutLight :: State LayoutVars (MetaTree Room String)
|
|
tutLight = do
|
|
x <- shuffleRoomPos =<< chasmSimpleMaze
|
|
y <- chasmSimpleMaze
|
|
return $
|
|
tToBTree "TutLight" $
|
|
treePost
|
|
[ x & rmPmnts <>~
|
|
[sps g (PutFlIt led)
|
|
,sps g (PutFlIt battery)
|
|
]
|
|
, corridor & rmPmnts .~ mempty
|
|
, removeLights y
|
|
, corridor & rmPmnts .~ mempty
|
|
, removeLights y
|
|
, cleatOnward corridor & rmPmnts .~ mempty
|
|
]
|
|
where
|
|
g = PSPos (\x _ -> f x) (\_ -> id) Nothing
|
|
where
|
|
f x = case _rpType x of
|
|
NotLink{} | null (x ^. rpPlacementUse . at UsedPosFloor)
|
|
-> Just (PS (_rpPos x) (_rpDir x)
|
|
, x & rpPlacementUse . at UsedPosFloor ?~ ())
|
|
_ -> Nothing
|
|
|
|
removeLights :: Room -> Room
|
|
removeLights = rmPmnts %~ mapMaybe f
|
|
where
|
|
f x = case x ^. plType of
|
|
PutLabel "light" -> Nothing
|
|
_ -> Just x
|
|
|
|
tutHub :: State LayoutVars (MetaTree Room String)
|
|
tutHub = do
|
|
(is, wbp) <- setTreeInts =<< critsRoom 2
|
|
i <- nextLayoutInt
|
|
j <- nextLayoutInt
|
|
k <- nextLayoutInt
|
|
let a gw =
|
|
analyserByNthLinkWithPrompt
|
|
3 --(makeTermPara $ show is <> show (getRoomsFromInts is gw)
|
|
-- <> getCrsFromRooms' is gw)
|
|
[]
|
|
(RequireDeadCreatures $ getCrsFromRooms is gw)
|
|
k
|
|
x <-
|
|
shuffleLinks
|
|
. analyserByDoorWithPrompt [] (RequireEquipment (AMMOMAG DRUMMAG)) i
|
|
. (rmInPmnt .:~ (0, a))
|
|
. addDoorAtNthLinkToggleTerminal 1 ss j
|
|
=<< roomNgon 6 100
|
|
bcor <- treeAttachDeep (return door) <$> blockedCorridor
|
|
r1 <- r burstRifle <&> rmPmnts .:~ t
|
|
r2 <- r (drumMag & itConsumables ?~ 90)
|
|
--r2 <- r (tinMag & itConsumables ?~ 500)
|
|
return $
|
|
tToBTree "DoorTest" $
|
|
Node
|
|
x
|
|
[ treeFromPost [triggerDoorRoom i] r1
|
|
, treeFromPost [triggerDoorRoom j] r2
|
|
, (rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
|
|
<$> treeAttachDeep wbp bcor
|
|
, treeFromPost [] (cleatOnward $ triggerDoorRoom k & rmInPmnt . ix 0 . _1 .~ 1)
|
|
]
|
|
where
|
|
ss =
|
|
[ makeTermLine "---------------------------------------------"
|
|
, makeTermLine "YOU CAN INTERACT WITH SOME TERMINALS DIRECTLY"
|
|
, makeTermLine " THESE WILL DISPLAY A PROMPT SYMBOL"
|
|
, makeTermLine " *****"
|
|
, makeTermLine " * * TYPE OR SCROLL TO ENTER COMMANDS"
|
|
, makeTermLine " * > *"
|
|
, makeTermLine " * * CLICK OR USE [RETURN] TO CONFIRM"
|
|
, makeTermLine " ***** "
|
|
, makeTermLine "---------------------------------------------"
|
|
, makeTermLine ""
|
|
]
|
|
r x = roomRectAutoLinks 100 100 <&> rmPmnts .:~ sps (PS 50 0) (PutFlIt x)
|
|
t =
|
|
putMessageTerminal
|
|
terminalColor
|
|
(defaultTerminal & tmBootLines .~ ss' <> tlSetStatus (TerminalPressTo "QUIT") <> tlDoEffect TmWdWdPowerDownTerminal)
|
|
& plSpot
|
|
.~ rprBoolShift
|
|
isUnusedLnk
|
|
(\(p, a) -> ((p + 10 *.* unitVectorAtAngle (a - pi / 2), a), S.singleton UsedPosLow))
|
|
ss' =
|
|
[ makeTermLine "---------------------------------------------"
|
|
, makeTermLine "HOLD [CAPS] AND SCROLL"
|
|
, makeTermLine " OR CLICK AND DRAG"
|
|
, makeTermLine " TO REARRANGE INVENTORY ITEMS"
|
|
, makeTermLine "---------------------------------------------"
|
|
]
|
|
<> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
<> [ makeTermLine "AMMO MAGS ARE NORMALLY LOADED BENEATH WEAPONS"
|
|
, makeTermLine " .-------."
|
|
, makeTermLine " BURSTRIFLE |DRUMMAG|"
|
|
, makeTermLine " <------^-------^"
|
|
, makeTermLine "---------------------------------------------"
|
|
]
|
|
<> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
<> [ makeTermLine "HOLD [RMB] TO AIM"
|
|
, makeTermLine " THEN CLICK [LMB] TO FIRE LOADED WEAPONS"
|
|
, makeTermLine "---------------------------------------------"
|
|
]
|
|
|
|
getRoomsFromInts :: [Int] -> GenWorld -> IS.IntSet
|
|
getRoomsFromInts is gw =
|
|
foldMap IS.singleton $ IM.restrictKeys (gw ^. genInts) (IS.fromList is)
|
|
|
|
getCrsFromRooms' :: [Int] -> GenWorld -> String
|
|
getCrsFromRooms' is gw = fmap h $ show $ foldMap f (IM.restrictKeys (gw ^. genRooms) js)
|
|
where
|
|
h ',' = ' '
|
|
h x = x
|
|
js = getRoomsFromInts is gw
|
|
f rm = shortShow <$> rm ^.. rmPmnts . each . plType
|
|
|
|
--f rm = foldMap g $ rm ^. rmPmnts
|
|
--g x = case x ^. plType of
|
|
-- PutCrit _ -> [x ^?! plMID . _Just]
|
|
-- _ -> []
|
|
|
|
getCrsFromRooms :: [Int] -> GenWorld -> [Int]
|
|
getCrsFromRooms is gw = foldMap f (IM.restrictKeys (gw ^. genRooms) js)
|
|
where
|
|
js = getRoomsFromInts is gw
|
|
f rm = foldMap g $ rm ^. rmPmnts
|
|
g x = case x ^. plType of
|
|
PutCrit _ -> [x ^?! plMID . _Just]
|
|
_ -> []
|
|
|
|
sensorTut :: [TerminalLine]
|
|
sensorTut =
|
|
[ makeTermLine "--------------------------------------------"
|
|
, makeTermLine "SOME TERMINALS DETECT EXTERNAL CONDITIONS"
|
|
, makeTermLine "WHILE ACTIVE THESE DISPLAY A SPINNING SYMBOL"
|
|
, makeTermLine " | / - \\"
|
|
, makeTermLine "--------------------------------------------"
|
|
]
|
|
|
|
-- <> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
|
|
tutRezBox :: RandomGen g => State g Room
|
|
tutRezBox = do
|
|
ls <- rezColor
|
|
return $
|
|
roomRect 40 60 1 1
|
|
& rmPmnts
|
|
.~ [ sPS (V2 20 1) 0 $ PutLS ls
|
|
, Placement (PS 0 0) PutNothing Nothing Nothing $ \w _ ->
|
|
Just $
|
|
putImmediateMessageTerminal
|
|
terminalColor
|
|
( defaultTerminal & tmBootLines .~ s w
|
|
<> tlSetStatus (TerminalPressTo "QUIT")
|
|
<> tlDoEffect TmWdWdPowerDownTerminal
|
|
-- <> tlDoEffect (TmWdWdLeaveTerminal "QUIT")
|
|
)
|
|
& plSpot .~ PS (V2 20 0) 0
|
|
]
|
|
& restrictInLinks (\(V2 _ h, _) -> h < 1)
|
|
& restrictOutLinks (\(V2 _ h, _) -> h > 59)
|
|
& rmName .~ "tutRezBox"
|
|
where
|
|
s w = tutorialMessage1 (w ^. gwWorld . cWorld . cwGen . cwgSeed)
|
|
|
|
tutorialMessage1 :: Int -> [TerminalLine]
|
|
tutorialMessage1 i =
|
|
[ makeTermLine "--------------------------------------------"
|
|
, makeTermLine $ "WELCOME TO ENVIRONMENT " ++ show i
|
|
, makeTermLine ""
|
|
, makeTermLine "USE [SPACE] TO INTERACT WITH NEARBY OBJECTS"
|
|
, makeTermLine "--------------------------------------------"
|
|
]
|
|
<> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
<> [ makeTermLine "USE [W]"
|
|
, makeTermLine " [A] [S]"
|
|
, makeTermLine " [D] TO MOVE"
|
|
, makeTermLine "--------------------------------------------"
|
|
]
|
|
<> tlSetStatus (TerminalPressTo "CONTINUE")
|
|
<> [ makeTermLine "AFTER EXITING THIS TERMINAL YOUR INVENTORY"
|
|
, makeTermLine " AND NEARBY OBJECTS WILL BE DISPLAYED"
|
|
, makeTermLine "--------------------------------------------"
|
|
]
|