diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 63ee0c078..d28dc7967 100644 --- a/src/Dodge/Data.hs +++ b/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] diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index fa02bbfff..c6826e7ea 100644 --- a/src/Dodge/Default.hs +++ b/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 diff --git a/src/Dodge/Machine/Damage.hs b/src/Dodge/Machine/Damage.hs new file mode 100644 index 000000000..0485aa2e3 --- /dev/null +++ b/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 diff --git a/src/Dodge/Placement/Instance/Analyser.hs b/src/Dodge/Placement/Instance/Analyser.hs index 4e82cd563..d3349d1b2 100644 --- a/src/Dodge/Placement/Instance/Analyser.hs +++ b/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 - (\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 diff --git a/src/Dodge/Placement/Instance/Sensor.hs b/src/Dodge/Placement/Instance/Sensor.hs index bea4d98d8..252b44b67 100644 --- a/src/Dodge/Placement/Instance/Sensor.hs +++ b/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 - $ 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 diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index 2d184c832..3fabd6269 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/src/Dodge/Placement/Instance/Terminal.hs @@ -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 diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index 57b415678..d39ada016 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/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) diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index f8c3d0598..8478d6fc6 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/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 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'