62 lines
2.2 KiB
Haskell
62 lines
2.2 KiB
Haskell
module Dodge.Placement.Instance.Terminal (
|
|
putMessageTerminal,
|
|
putImmediateMessageTerminal,
|
|
putTerminal,
|
|
) where
|
|
|
|
import Data.Maybe
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.WorldEffect
|
|
import Geometry
|
|
import LensHelp
|
|
|
|
putTerminalImediateAccess :: Machine -> Terminal -> Placement
|
|
putTerminalImediateAccess = putTerminalFull f
|
|
where
|
|
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ const $ over gwWorld $ accessTerminal (tmpl ^?! plMID . _Just)
|
|
|
|
putTerminalFull ::
|
|
(Placement -> Placement -> Placement -> Maybe Placement) ->
|
|
Machine ->
|
|
Terminal ->
|
|
Placement
|
|
putTerminalFull f mc tm =
|
|
ps0PushPS (PutTerminal tm) $
|
|
\tmpl -> Just $
|
|
ps0PushPS (PutButton defaultButton) $
|
|
\btpl -> Just $
|
|
pt0
|
|
( PutMachine
|
|
(reverse $ square 10)
|
|
( mc & mcMounts . at OTButton ?~ fromJust (_plMID btpl)
|
|
& mcMounts . at OTTerminal .~ _plMID tmpl
|
|
)
|
|
Nothing
|
|
)
|
|
$ \mcpl -> Just $ pt0 (PutWorldUpdate $ const $ const $ over gwWorld (setids tmpl btpl mcpl)) (\_ -> f tmpl btpl mcpl)
|
|
where
|
|
setids tmpl btpl mcpl w =
|
|
w
|
|
& cWorld . lWorld . terminals . ix tmid . tmButtonID .~ btid
|
|
& cWorld . lWorld . terminals . ix tmid . tmMachineID .~ mcid
|
|
& cWorld . lWorld . machines . ix mcid . mcMounts . at OTTerminal ?~ tmid
|
|
& cWorld . lWorld . buttons . ix btid . btEvent .~ ButtonAccessTerminal tmid
|
|
where
|
|
tmid = fromJust (_plMID tmpl)
|
|
btid = fromJust (_plMID btpl)
|
|
mcid = fromJust (_plMID mcpl)
|
|
|
|
putTerminal :: Machine -> Terminal -> Placement
|
|
putTerminal = putTerminalFull (\_ _ _ -> Nothing)
|
|
|
|
tmMachine :: Machine
|
|
tmMachine = defaultMachine & mcType .~ McTerminal & mcHP .~ 100
|
|
|
|
putMessageTerminal :: Terminal -> Placement
|
|
putMessageTerminal = putTerminal tmMachine
|
|
|
|
putImmediateMessageTerminal :: Terminal -> Placement
|
|
putImmediateMessageTerminal = putTerminalImediateAccess tmMachine
|