Work on terminals and machines

src/Dodge/Data.hs

@@ -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

@@ -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

@@ -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

@@ -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
+    tparams = const $ defaultTermParams & termFutureLines ++.~ 
-        (\mc -> buttons . ix btid . btTerminalParams .~
+        (map makeTermLine starts ++ [makeTermLine sucs] ++ map makeTermLine afters)
-            const (TerminalParams
+    termupdate tp btid = 
-                { _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 = []
-                })
-        )
         (\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

@@ -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 
+sensorSPic wdth (pc,ds) mc = noPic 
-    $ colorSH yellow (upperPrismPoly 25 (square wdth))
+    $ colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth))
         <> decorationToShape ds wdth wdth 25 col col
   where
     col = paletteToColor pc

src/Dodge/Placement/Instance/Terminal.hs

@@ -23,40 +23,58 @@ import Shape
 
 import Data.Maybe
 
-putTerminal' 
+putTerminal''
-    :: Color
+    :: Machine
+    -> (World -> TerminalParams)
     -> (Int -> Machine -> World -> World)  -- | machine update, takes button id as input
     -> Placement
-putTerminal' col mcf = ps0PushPS (PutButton termButton)
+putTerminal'' mc f mcf = ps0PushPSw (PutTerminal theterminal) $ \_ tmpl -> Just $
-    $ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
+    ps0PushPS (PutButton $ termButton & btTerminal .~ _plMID tmpl)
-    { _mcDraw = noPic . terminalShape col
+    $ \pl -> Just $ pt0 (PutMachine (reverse $ square 10) 
-    , _mcHP = 100
+        (mc & mcUpdate .~ machineAddSound fridgeHumS (mcf (fromJust $ _plMID pl))
-    , _mcUpdate = mcf (fromJust $ _plMID pl)
+            & mcDeath %~ (\fd mc' -> (buttons . at (fromJust (_plMID pl)) .~ Nothing) . fd mc')
-    , _mcSensor = SensorCloseToggle NotClose False
+        )
-    })
+    )
     $ 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 $
+putTerminal col f = ps0PushPSw (PutTerminal theterminal) $ \_ tmpl -> Just $
-     ps0PushPS (PutButton $ termButton & btTerminalParams .~ f)
+     ps0PushPS (PutButton $ termButton & btTerminal .~ _plMID tmpl)
-    $ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
+    $ \pl -> Just $ pt0 (PutMachine (reverse $ square 10) (defaultMachine & mcColor .~ col)
-    { _mcDraw = noPic . terminalShape 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 :: Maybe Int -> World -> World
-displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory DisplayTerminal
+displayTerminalMessage mtmid w = case mtmid of
-    { _termID = btid
+    Nothing -> w
-    , _termParams = fromMaybe NoTerminalParams $ (w ^? buttons . ix btid . btTerminalParams) <&> ($ 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

@@ -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

@@ -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 :: [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World)
-plMachine color wallpoly mc p rot gw = (mcid
+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'