justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Work on terminals and machines

Browse Source
This commit is contained in:
justin
2022-06-06 00:14:46 +01:00
parent a6141fd79a
commit b0173c3778
8 changed files with 81 additions and 66 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+4 -1
View File
@@ -405,6 +405,7 @@ data Button = Button
, _btText :: String
, _btState :: ButtonState
, _btTerminalParams :: World -> TerminalParams
, _btTerminal :: Maybe Int
, _btName :: String
}
data TerminalParams = NoTerminalParams | TerminalParams
@@ -962,6 +963,7 @@ data Machine = Machine
, _mcDraw :: Machine -> SPic
, _mcPos :: Point2
, _mcDir :: Float
, _mcColor :: Color
, _mcHP :: Int
, _mcSensor :: Sensor
, _mcDamage :: [Damage]
@@ -1378,10 +1380,11 @@ data TerminalCommand = TerminalCommand
---- ROOM DATATYPES
data PSType = PutCrit {_unPutCrit :: Creature}
| PutMachine { _putMachineColor :: Color, _putMachinePoly :: [Point2], _unPutMachine :: Machine }
| PutMachine { _putMachinePoly :: [Point2], _unPutMachine :: Machine }
| PutLS LightSource
| PutButton {_putButton :: Button}
| PutProp Prop
| PutTerminal {_unputTerminal :: Terminal}
| PutFlIt Item
| PutPPlate PressPlate
| PutBlock BlockMaterial Int [Int] Wall [Point2]
src/Dodge/Default.hs
+5
View File
@@ -211,6 +211,7 @@ defaultMachine = Machine
, _mcDeath = \_ -> id
, _mcApplyDamage = \_ _ -> id
, _mcDraw = const mempty
, _mcColor = white
, _mcPos = V2 0 0
, _mcDir = 0
, _mcHP = 1000
@@ -239,6 +240,9 @@ defaultDrawButton col bt =
| _btState bt == BtOff = rectNSEW 10 (-1) width (-width)
| otherwise = rectNSEW 2 (-1) width (-width)
width = 8
defaultTerminal :: Terminal
defaultTerminal = Terminal 0 (\_ _ -> NoTerminalParams) 0 0 "TESTTERMINAL"
defaultButton :: Button
defaultButton = Button
{ _btPict = defaultDrawButton (dark red)
@@ -250,6 +254,7 @@ defaultButton = Button
, _btText = "Button"
, _btState = BtOff
, _btTerminalParams = const NoTerminalParams
, _btTerminal = Nothing
, _btName = ""
}
defaultPT :: Prop
src/Dodge/Machine/Damage.hs
+9
View File
@@ -0,0 +1,9 @@
module Dodge.Machine.Damage where
import Dodge.Data
import LensHelp
basicMachineApplyDamage :: Machine -> World -> World
basicMachineApplyDamage mc = machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) )
where
dams = sum $ map _dmAmount $ _mcDamage mc
mcid = _mcID mc
src/Dodge/Placement/Instance/Analyser.hs
+6 -36
View File
@@ -7,7 +7,8 @@ module Dodge.Placement.Instance.Analyser
--import Dodge.PlacementSpot
import Dodge.Data
import Dodge.Base.You
--import Dodge.Default
import Dodge.Default
import Dodge.Terminal
--import Dodge.Tree
--import Dodge.RoomLink
--import Dodge.Room.Door
@@ -39,15 +40,6 @@ import Data.Maybe
--import Control.Monad.State
--import System.Random
initMCUpdate
:: (Machine -> World -> World)
-> (Machine -> World -> World)
-> Machine -> World -> World
initMCUpdate initup f mc
= (machines . ix (_mcID mc) . mcUpdate .~ f)
. initup mc
analyser
:: [String] -- | initial text
-> String -- | succeed text
@@ -58,35 +50,13 @@ analyser
-> PlacementSpot
-> Placement
analyser starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \tp ->
Just $ updatebuttonname $ plSpot .~ psmc $ putTerminal' aquamarine (termupdate tp)
Just $ plSpot .~ psmc $ putTerminal' aquamarine tparams (termupdate tp)
where
termupdate tp btid = initMCUpdate
(\mc -> buttons . ix btid . btTerminalParams .~
const (TerminalParams
{ _termDisplayedLines = []
, _termFutureLines =
map simpleline (topFlushStrings allstrings)
++ map simpleline starts
++ [testline' (_mcID mc)]
++ map simpleline afters
, _termMaxLines = 7
, _termTitle = "ANALYSER"
, _termSel = Nothing
-- , _termOptions = []
, _termInput = Nothing
, _termScrollCommands = []
, _termWriteCommands = []
})
)
tparams = const $ defaultTermParams & termFutureLines ++.~
(map makeTermLine starts ++ [makeTermLine sucs] ++ map makeTermLine afters)
termupdate tp btid =
(\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
)
allstrings = sucs : fails : afters ++ starts
simpleline str = TerminalLineDisplay {_tlPause = 0, _tlString = const (str,white)}
testline' mcid = TerminalLineDisplay 0 (testline mcid)
testline mcid w = case w ^? machines . ix mcid . mcSensor . sensToggle of
Just True -> (sucs,green)
_ -> (fails,red)
updatebuttonname = plType . putButton . btText .~ "ANALYSER"
analyserTest :: (World -> Bool) -> Machine -> World -> World
analyserTest t mc w = case
src/Dodge/Placement/Instance/Sensor.hs
+3 -3
View File
@@ -23,7 +23,7 @@ damageSensor
-> PlacementSpot -> Placement
damageSensor dt wdth upf ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1)
$ \lsid -> Just $ spNoID ps $ PutUsingGenParams
$ \gw -> (,) gw $ PutMachine yellow (reverse $ square wdth) defaultMachine
$ \gw -> (,) gw $ PutMachine (reverse $ square wdth) (defaultMachine & mcColor .~ yellow)
{ _mcDraw = sensorSPic wdth $ _sensorCoding (_genParams gw) M.! dt
, _mcUpdate = \mc -> upf mc . sensorUpdate dt mc
, _mcSensor = SensorToggleAmount False 0
@@ -54,8 +54,8 @@ damageUsing dt dm
| otherwise = Right 0
sensorSPic :: Float -> (PaletteColor,DecorationShape) -> Machine -> SPic
sensorSPic wdth (pc,ds) _ = noPic
$ colorSH yellow (upperPrismPoly 25 (square wdth))
sensorSPic wdth (pc,ds) mc = noPic
$ colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
<> decorationToShape ds wdth wdth 25 col col
where
col = paletteToColor pc
src/Dodge/Placement/Instance/Terminal.hs
+47 -21
View File
@@ -23,40 +23,58 @@ import Shape
import Data.Maybe
putTerminal'
:: Color
putTerminal''
:: Machine
-> (World -> TerminalParams)
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
-> Placement
putTerminal' col mcf = ps0PushPS (PutButton termButton)
$ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
{ _mcDraw = noPic . terminalShape col
, _mcHP = 100
, _mcUpdate = mcf (fromJust $ _plMID pl)
, _mcSensor = SensorCloseToggle NotClose False
})
putTerminal'' mc f mcf = ps0PushPSw (PutTerminal theterminal) $ \_ tmpl -> Just $
ps0PushPS (PutButton $ termButton & btTerminal .~ _plMID tmpl)
$ \pl -> Just $ pt0 (PutMachine (reverse $ square 10)
(mc & mcUpdate .~ machineAddSound fridgeHumS (mcf (fromJust $ _plMID pl))
& mcDeath %~ (\fd mc' -> (buttons . at (fromJust (_plMID pl)) .~ Nothing) . fd mc')
)
)
$ const Nothing
where
theterminal = defaultTerminal & tmProgram .~ const f
putTerminal'
:: Color
-> (World -> TerminalParams)
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
-> Placement
putTerminal' col = putTerminal'' (defaultMachine & mcColor .~ col)
{ _mcDraw = noPic . terminalShape
, _mcHP = 100
, _mcSensor = SensorCloseToggle NotClose False
}
putTerminal :: Color -> (World -> TerminalParams) -> Placement
putTerminal col f = ps0PushPSw PutNothing $ \_ _ -> Just $
ps0PushPS (PutButton $ termButton & btTerminalParams .~ f)
$ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
{ _mcDraw = noPic . terminalShape col
putTerminal col f = ps0PushPSw (PutTerminal theterminal) $ \_ tmpl -> Just $
ps0PushPS (PutButton $ termButton & btTerminal .~ _plMID tmpl)
$ \pl -> Just $ pt0 (PutMachine (reverse $ square 10) (defaultMachine & mcColor .~ col)
{ _mcDraw = noPic . terminalShape
, _mcHP = 100
, _mcUpdate = basicMachineUpdate $ machineAddSound fridgeHumS (const id)
, _mcDeath = \mc -> (buttons . at (fromJust (_plMID pl)) .~ Nothing)
. makeExplosionAt (_mcPos mc)
})
$ const Nothing
where
theterminal = defaultTerminal & tmProgram .~ const f
termButton :: Button
termButton = Button
{ _btPict = const mempty
, _btPos = 0
, _btRot = 0
, _btEvent = displayTerminalMessage . _btID
, _btEvent = displayTerminalMessage . _btTerminal
, _btID = 0
, _btText = "TERMINAL"
, _btState = BtOff
, _btTerminalParams = const $ TerminalParams [] [] 10 "TERMINAL" Nothing Nothing [] []
, _btTerminal = Nothing
, _btName = ""
}
@@ -64,9 +82,9 @@ termButton = Button
terminalColor :: Color
terminalColor = dark magenta
terminalShape :: Color -> Machine -> Shape
terminalShape :: Machine -> Shape
--terminalShape _ = upperPrismPoly 15 $ square 10
terminalShape col _ = colorSH col (prismPoly
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]
)
@@ -76,12 +94,20 @@ terminalShape col _ = colorSH col (prismPoly
--[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
displayTerminalMessage :: Int -> World -> World
displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory DisplayTerminal
{ _termID = btid
, _termParams = fromMaybe NoTerminalParams $ (w ^? buttons . ix btid . btTerminalParams) <&> ($ w)
}
displayTerminalMessage :: Maybe Int -> World -> World
displayTerminalMessage mtmid w = case mtmid of
Nothing -> w
Just tmid -> w & hud . hudElement .~ DisplayInventory DisplayTerminal
{ _termID = tmid
, _termParams = message tmid
}
where
message tmid = fromMaybe NoTerminalParams $ do
tm <- w ^? terminals . ix tmid
return $ _tmProgram tm tm w
simpleTermMessage :: [String] -> World -> TerminalParams
simpleTermMessage = genTermMessage . const
src/Dodge/Placement/Instance/Turret.hs
+2 -2
View File
@@ -29,7 +29,7 @@ import Data.List
import Data.Maybe
putLasTurret :: Float -> Placement
putLasTurret rotSpeed = sps0 $ PutMachine blue (reverse $ square wdth) defaultMachine
putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth) (defaultMachine & mcColor .~ blue)
{ _mcDraw = drawTurret
, _mcUpdate = updateTurret rotSpeed
, _mcType = lasTurret
@@ -113,7 +113,7 @@ updateTurret rotSpeed mc w
drawTurret :: Machine -> SPic
drawTurret mc = (rotateSH (-_mcDir mc) . colorSH blue $ upperPrismPoly 20 (square wdth)
drawTurret mc = (rotateSH (-_mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth)
, mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc )
)
-- <> translateSPz 20 (itSPic it)
src/Dodge/Placement/PlaceSpot.hs
+5 -3
View File
@@ -92,9 +92,10 @@ placeSpotID ps pt w = case pt of
PutMod mdi -> plNewUpID modifications mdID mdi w
PutProp prp -> plNewUpID props pjID (mvProp p rot prp) w
PutButton bt -> plNewUpID buttons btID (mvButton p rot bt) w
PutTerminal tm -> plNewUpID terminals tmID tm w
PutFlIt itm -> plNewUpID floorItems flItID (createFlIt p rot itm) w
PutCrit cr -> plNewUpID creatures crID (mvCr p rot cr) w
PutMachine col pps mc -> plMachine col (map doShift pps) mc p rot w
PutMachine pps mc -> plMachine (map doShift pps) mc p rot w
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
RandPS rgn -> evaluateRandPS rgn ps w
@@ -169,12 +170,13 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
plMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
plMachine color wallpoly mc p rot gw = (mcid
plMachine :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
plMachine wallpoly mc p rot gw = (mcid
, gw & machines %~ addMc
& walls %~ placeMachineWalls color wallpoly mcid wlid
)
where
color = _mcColor mc
w' = gw
mcid = IM.newKey $ _machines w'
wlid = IM.newKey $ _walls w'