130 lines
3.9 KiB
Haskell
130 lines
3.9 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Placement.Instance.Terminal
|
|
( putTerminal
|
|
, putTerminal'
|
|
, putTerminal''
|
|
, simpleTermMessage
|
|
, terminalColor
|
|
, terminalSPic
|
|
) where
|
|
import Dodge.Data
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.Default
|
|
import Dodge.Machine
|
|
import Dodge.SoundLogic
|
|
import Dodge.Terminal
|
|
import Dodge.WorldEvent.Explosion
|
|
import Color
|
|
import Geometry
|
|
import ShapePicture
|
|
import LensHelp
|
|
import Shape
|
|
--import ShapePicture
|
|
--import Sound.Data
|
|
|
|
import Data.Maybe
|
|
|
|
putTerminal''
|
|
:: Machine
|
|
-> Terminal
|
|
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
|
|
-> Placement
|
|
putTerminal'' mc tm mcf = ps0PushPS (PutTerminal tm)
|
|
$ \tmpl -> Just $ ps0PushPS (PutButton termButton)
|
|
$ \btpl -> Just $ pt0 (PutMachine (reverse $ square 10)
|
|
(mc & mcUpdate %~ (\fmu mc' -> mcf (fromJust $ _plMID btpl) mc' . fmu mc') . machineAddSound fridgeHumS
|
|
& mcDeath %~ (\fd mc' -> mcKillTerm mc' . (buttons . at (fromJust (_plMID btpl)) .~ Nothing) . fd mc')
|
|
) )
|
|
$ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl)
|
|
where
|
|
setids tmpl btpl mcpl w = w
|
|
& terminals . ix tmid . tmButtonID .~ btid
|
|
& terminals . ix tmid . tmMachineID .~ mcid
|
|
& machines . ix mcid . mcTermMID ?~ tmid
|
|
& buttons . ix btid . btTermMID ?~ tmid
|
|
where
|
|
tmid = fromJust (_plMID tmpl)
|
|
btid = fromJust (_plMID btpl)
|
|
mcid = fromJust (_plMID mcpl)
|
|
|
|
mcKillTerm :: Machine -> World -> World
|
|
mcKillTerm mc w = fromMaybe w $ do
|
|
tmid <- _mcTermMID mc
|
|
tm <- w ^? terminals . ix tmid
|
|
return $ w
|
|
& _tmDeathEffect tm tm
|
|
|
|
putTerminal'
|
|
:: Color
|
|
-> Terminal
|
|
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
|
|
-> Placement
|
|
putTerminal' col = putTerminal'' (defaultMachine
|
|
& mcColor .~ col)
|
|
{ _mcDraw = noPic . terminalShape
|
|
, _mcHP = 100
|
|
, _mcSensor = defaultProximitySensor
|
|
}
|
|
|
|
putTerminal :: Color -> Terminal -> Placement
|
|
putTerminal col f = putTerminal'' (mc & mcColor .~ col) f (\_ -> basicMachineUpdate $ const id)
|
|
where
|
|
mc = defaultMachine
|
|
{ _mcDraw = terminalSPic
|
|
, _mcHP = 100
|
|
, _mcDeath = makeExplosionAt . _mcPos
|
|
}
|
|
|
|
termButton :: Button
|
|
termButton = Button
|
|
{ _btPict = const mempty
|
|
, _btPos = 0
|
|
, _btRot = 0
|
|
, _btEvent = accessTerminal . _btTermMID
|
|
, _btID = 0
|
|
, _btText = "TERMINAL"
|
|
, _btState = BtOff
|
|
, _btTermMID = Nothing
|
|
, _btName = ""
|
|
, _btColor = dark magenta
|
|
}
|
|
|
|
terminalColor :: Color
|
|
terminalColor = dark magenta
|
|
|
|
terminalSPic :: Machine -> SPic
|
|
--terminalShape _ = upperPrismPoly 15 $ square 10
|
|
terminalSPic = noPic . terminalShape
|
|
|
|
terminalShape :: Machine -> Shape
|
|
--terminalShape _ = upperPrismPoly 15 $ square 10
|
|
terminalShape mc = colorSH col (prismPoly
|
|
[V3 10 10 20, V3 (-10) 10 20, V3 (-10) (-10) 10, V3 10 (-10) 10]
|
|
[V3 10 10 0, V3 (-10) 10 0, V3 (-10) (-10) 0, V3 10 (-10) 0]
|
|
)
|
|
<> colorSH black (prismPoly
|
|
[V3 8 8 20, V3 (-8) 8 20, V3 0 (-8) 10]
|
|
[V3 8 8 19, V3 (-8) 8 19, V3 0 (-8) 9]
|
|
--[V3 8 8 20, V3 (-8) 8 20, V3 (-8) (-8) 10, V3 8 (-8) 10]
|
|
--[V3 8 8 19, V3 (-8) 8 19, V3 (-8) (-8) 9, V3 8 (-8) 9]
|
|
)
|
|
where
|
|
col = _mcColor mc
|
|
|
|
accessTerminal :: Maybe Int -> World -> World
|
|
accessTerminal mtmid w = case mtmid of
|
|
Nothing -> w
|
|
Just tmid -> w & hud . hudElement .~ DisplayInventory (DisplayTerminal tmid)
|
|
& terminals . ix tmid . tmInput . tiFocus .~ True
|
|
& terminals . ix tmid %~ tryToBoot
|
|
where
|
|
tryToBoot tm = case _tmStatus tm of
|
|
TerminalReady -> tm
|
|
TerminalBusy -> tm
|
|
TerminalOff -> tm
|
|
& tmFutureLines .~ _tmProgram tm tm w
|
|
& tmStatus .~ TerminalBusy
|
|
|
|
simpleTermMessage :: [String] -> Terminal
|
|
simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs
|