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

Make analyser into one machine

Browse Source
This commit is contained in:
justin
2022-03-22 09:35:17 +00:00
parent 9c46027711
commit c0383dbd8a
8 changed files with 95 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1
View File
@@ -329,6 +329,7 @@ data TerminalParams = NoTerminalParams | TerminalParams
{ _termDisplayedLines :: [World -> (String,Color)]
, _termFutureLines :: [TerminalLine]
, _termMaxLines :: Int
, _termTitle :: String
}
data TerminalLine
= TerminalLineDisplay
src/Dodge/LevelGen/Data.hs
+3 -2
View File
@@ -20,7 +20,7 @@ import qualified Data.IntMap.Strict as IM
data PSType = PutCrit {_unPutCrit :: Creature}
| PutMachine { _putMachineColor :: Color, _putMachinePoly :: [Point2], _unPutMachine :: Machine }
| PutLS LightSource
| PutButton {_pstPutButton :: Button}
| PutButton {_putButton :: Button}
| PutProp Prop
| PutFlIt Item
| PutPPlate PressPlate
@@ -28,7 +28,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutCoord Point2
| PutMod Modification
| PutTrigger (World -> Bool)
| PutLineBlock Wall BlockMaterial Float Float Point2 Point2
| PutLineBlock {_putWall :: Wall, _putBlockMaterial :: BlockMaterial
, _putWidth :: Float, _putDepth :: Float, _putStartPoint :: Point2, _putEndPoint :: Point2}
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDr Bool Color (World -> Bool) Float Point2 Point2 Float
| PutDoor Color (World -> Bool) [(Point2,Point2)]
src/Dodge/Machine.hs
+13
View File
@@ -9,6 +9,19 @@ import Dodge.Base
import qualified Data.IntMap.Strict as IM
machineUpdateLiveDieEff
:: (Machine -> World -> World) -- | effect when hp >= 1
-> (Machine -> World -> World) -- | effect (once) when hp < 1
-> Machine -> World -> World
machineUpdateLiveDieEff livef dief mc
| _mcHP mc < 1 = dief mc
. (machines %~ IM.delete mcid)
. deleteWallIDs (_mcWallIDs mc)
| otherwise = livef mc . (machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) ))
where
dams = sum $ map _dmAmount $ _mcDamage mc
mcid = _mcID mc
machineUpdateDeathEff :: (Machine -> World -> World)
-> Machine -> World -> World
machineUpdateDeathEff f mc
src/Dodge/Placement/Instance/Analyser.hs
+44 -1
View File
@@ -34,6 +34,47 @@ 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
-> String -- | fail text
-> [String] -- | after text
-> (Machine -> World -> World)
-> PlacementSpot
-> PlacementSpot
-> Placement
analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \tp ->
Just $ updatebuttonname $ plSpot .~ psmc $ putTerminal' aquamarine (termupdate tp)
where
termupdate tp btid = initMCUpdate
(\mc -> buttons . ix btid . btTerminalParams .~
TerminalParams
{ _termDisplayedLines = []
, _termFutureLines = map simpleline starts
++ [testline' (_mcID mc)]
++ map simpleline afters
, _termMaxLines = 7
, _termTitle = "ANALYSER"
}
)
(\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_mcSensorToggle mc))
)
simpleline str = TerminalLineDisplay {_tlPause = 0, _tlString = const (str,white)}
testline' mcid = TerminalLineDisplay 0 (testline mcid)
testline mcid w = case w ^? machines . ix mcid . mcSensorToggle of
Just True -> (sucs,green)
_ -> (fails,red)
updatebuttonname = plType . putButton . btText .~ "ANALYSER"
analyser
:: [String] -- | initial text
-> String -- | succeed text
@@ -52,12 +93,13 @@ analyser starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \tp
}
) $ \anmc -> Just
$ plSpot .~ shiftRelativeToPS (V2 20 0) (_plSpot anmc)
$ putTerminal $ const $ TerminalParams
$ updatebuttontext $ putTerminal $ const $ TerminalParams
{ _termDisplayedLines = []
, _termFutureLines = map simpleline starts
++ [testline' (fromJust $ _plMID anmc)]
++ map simpleline afters
, _termMaxLines = 7
, _termTitle = "ANALYSER"
}
where
simpleline str = TerminalLineDisplay {_tlPause = 0, _tlString = const (str,white)}
@@ -65,6 +107,7 @@ analyser starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \tp
testline mcid w = case w ^? machines . ix mcid . mcSensorToggle of
Just True -> (sucs,green)
_ -> (fails,red)
updatebuttontext = plType . putButton . btText .~ "ANALYSER"
testYourHealth :: Int -> Machine -> World -> World
testYourHealth hp mc w
src/Dodge/Placement/Instance/Terminal.hs
+31 -5
View File
@@ -1,6 +1,7 @@
--{-# LANGUAGE TupleSections #-}
module Dodge.Placement.Instance.Terminal
( putTerminal
, putTerminal'
, simpleTermMessage
, genTermMessage
) where
@@ -19,10 +20,33 @@ import Sound.Data
import Data.Maybe
putTerminal'
:: Color
-> (Int -> Machine -> World -> World) -- | machine update, takes button id as input
-> Placement
putTerminal' col mcf = ps0PushPS (PutButton thebutton)
$ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
{ _mcDraw = noPic . colorSH col . terminalShape
, _mcHP = 100
, _mcUpdate = mcf (fromJust $ _plMID pl)
})
$ const Nothing
where
thebutton = Button
{ _btPict = const mempty
, _btPos = 0
, _btRot = 0
, _btEvent = displayTerminalMessage . _btID
, _btID = 0
, _btText = "TERMINAL"
, _btState = BtOff
, _btTerminalParams = TerminalParams [] [] 10 "TERMINAL"
}
putTerminal :: (GenParams -> TerminalParams) -> Placement
putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
$ \pl -> Just $ pt0 (PutMachine terminalColor (reverse $ square 10) defaultMachine
{ _mcDraw = drawTerminal
{ _mcDraw = noPic . colorSH terminalColor . terminalShape
, _mcHP = 100
, _mcUpdate = machineAddSound fridgeHumS
$ machineUpdateDeathEff $ \mc -> (buttons . at (fromJust (_plMID pl)) .~ Nothing)
@@ -31,7 +55,7 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
$ const Nothing
where
g gp pl = (gp,
pl & plType . pstPutButton . btTerminalParams .~ f gp
pl & plType . putButton . btTerminalParams .~ f gp
& plGenUpdate .~ Nothing
)
thebutton = Button
@@ -42,14 +66,14 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
, _btID = 0
, _btText = "TERMINAL"
, _btState = BtOff
, _btTerminalParams = TerminalParams [] [] 10
, _btTerminalParams = TerminalParams [] [] 10 "TERMINAL"
}
terminalColor :: Color
terminalColor = dark magenta
drawTerminal :: Machine -> SPic
drawTerminal _ = noPic $ colorSH terminalColor $ upperPrismPoly 15 $ square 10
terminalShape :: Machine -> Shape
terminalShape _ = upperPrismPoly 15 $ square 10
displayTerminalMessage :: Int -> World -> World
displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory DisplayTerminal
@@ -63,6 +87,7 @@ simpleTermMessage ss = const $ TerminalParams
,_termFutureLines = TerminalLineEffect 0 termsound
: map totermline (topflush ++ ss)
,_termMaxLines = 7
,_termTitle = "TERMINAL"
}
where
topflush = [replicate i ' ' ++ "*" | i <- [0,2 .. maximum (map length ss)]]
@@ -77,6 +102,7 @@ genTermMessage f = \gp -> TerminalParams
,_termFutureLines = termSoundLine computerBeepingS
: map totermline (topflush (f gp) ++ f gp)
,_termMaxLines = 7
,_termTitle = "TERMINAL"
}
where
topflush ss = [replicate i ' ' ++ "*" | i <- [0,2 .. maximum (map length ss)]]
src/Dodge/Render/HUD.hs
+1 -1
View File
@@ -83,7 +83,7 @@ subInventoryDisplay subinv cfig w = case subinv of
, listTextPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it)
]
DisplayTerminal {_termParams = tp} -> pictures
[ invHead cfig "TERMINAL"
[ invHead cfig (_termTitle tp)
, renderListAt subInvX 60 cfig
. reverse
. take (_termMaxLines tp)
src/Dodge/Room/LasTurret.hs
+1 -1
View File
@@ -92,7 +92,7 @@ analyserByDoor sa sb sc sd mcf outplid rm = rm
]
& rmOutPmnt .~
[OutPlacement
(analyser sa sb sc sd
(analyser' sa sb sc sd
mcf
(atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
(atFstLnkOutShiftBy sensorshift)
src/Dodge/Room/Procedural.hs
+1 -1
View File
@@ -149,7 +149,7 @@ quarterRoomTri w = do
]
, [ blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))]
, [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2))
, blockLine (V2 (-29) w) (V2 0 (w/2))
, blockLine (V2 (-29) w) (V2 0 (w/2)) & plType . putWall . wlRotateTo .~ False
]
]
pure $ defaultRoom