76 lines
2.5 KiB
Haskell
76 lines
2.5 KiB
Haskell
module Dodge.Placement.Instance.Terminal (
|
|
putMessageTerminal,
|
|
putImmediateMessageTerminal,
|
|
putTerminal,
|
|
terminalColor,
|
|
) where
|
|
|
|
import Color
|
|
import Data.Maybe
|
|
import Dodge.Data.GenWorld
|
|
import Dodge.Default
|
|
import Dodge.LevelGen.PlacementHelper
|
|
import Dodge.WorldEffect
|
|
import Geometry
|
|
import LensHelp
|
|
|
|
putTerminalImediateAccess :: Color -> Machine -> Terminal -> Placement
|
|
putTerminalImediateAccess = putTerminalFull f
|
|
where
|
|
f tmpl _ _ = Just $ sps0 $ PutWorldUpdate $ const $ accessTerminal (tmpl ^?! plMID . _Just)
|
|
|
|
putTerminalFull ::
|
|
(Placement -> Placement -> Placement -> Maybe Placement) ->
|
|
Color ->
|
|
Machine ->
|
|
Terminal ->
|
|
Placement
|
|
putTerminalFull f col mc tm =
|
|
ps0PushPS (PutTerminal (tm & tmExternalColor .~ col)) $
|
|
\tmpl -> Just $
|
|
ps0PushPS (PutButton defaultButton) $
|
|
\btpl -> Just $
|
|
pt0
|
|
( PutMachine
|
|
(reverse $ square 10)
|
|
( mc & mcMounts . at OTButton ?~ fromJust (_plMID btpl)
|
|
& mcMounts . at OTTerminal .~ _plMID tmpl
|
|
)
|
|
defaultSensorWall
|
|
Nothing
|
|
)
|
|
$ \mcpl -> Just $ pt0 (PutWorldUpdate $ const (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 :: Color -> Machine -> Terminal -> Placement
|
|
putTerminal = putTerminalFull (\_ _ _ -> Nothing)
|
|
|
|
putMessageTerminal :: Color -> Terminal -> Placement
|
|
putMessageTerminal col =
|
|
putTerminal col $
|
|
defaultMachine
|
|
& mcColor .~ col
|
|
& mcType .~ McTerminal
|
|
& mcHP .~ 100
|
|
|
|
putImmediateMessageTerminal :: Color -> Terminal -> Placement
|
|
putImmediateMessageTerminal col =
|
|
putTerminalImediateAccess col $
|
|
defaultMachine
|
|
& mcColor .~ col
|
|
& mcType .~ McTerminal
|
|
& mcHP .~ 100
|
|
|
|
terminalColor :: Color
|
|
terminalColor = dark magenta
|