Work on more complicated terminals

src/Dodge/Data.hs

@@ -385,12 +385,18 @@ data TerminalParams = NoTerminalParams | TerminalParams
     , _termFutureLines :: [TerminalLine]
     , _termMaxLines :: Int
     , _termTitle :: String
+    , _termSel :: Maybe Int
+    , _termOptions :: [(String, World -> World)]
     }
 data TerminalLine
     = TerminalLineDisplay
         {_tlPause :: Int
         ,_tlString :: World -> (String, Color)
         }
+    | TerminalLineChoice
+        {_tlPause :: Int
+        ,_tlOptions :: [(String,World -> World)]
+        }
     | TerminalLineEffect
         {_tlPause :: Int
         ,_tlEffect :: SubInventory -> World -> World

src/Dodge/Event.hs

@@ -92,6 +92,13 @@ handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe
 handlePressedMouseButton but w = case (_hudElement (_hud $ _uvWorld w), but) of
     (DisplayCarte,_) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
     (_,ButtonMiddle) -> Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w)
+    ( DisplayInventory (DisplayTerminal tp _) , ButtonLeft)
+                -> Just $ fromMaybe w
+                    $ do -- ugly
+            i <- _termSel tp
+            f <- _termOptions tp !? i
+            return $ w & uvWorld %~ snd f
+                & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory
     ( DisplayInventory (CombineInventory mi) , ButtonLeft)
                 -> Just $ fromMaybe (w & uvWorld . hud . hudElement .~ DisplayInventory NoSubInventory) 
                     $ do -- ugly
@@ -140,6 +147,9 @@ wheelEvent y w = case _hudElement $ _hud w of
         | otherwise ->  w & moveTweakSel yi
     DisplayInventory (CombineInventory _) -> w
         & hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
+    DisplayInventory (DisplayTerminal tp _) -> w
+        & hud . hudElement . subInventory . termParams . termSel . _Just 
+            %~ ((`mod` length (_termOptions tp)) . subtract yi)
     _ -> w
   where
     numcombs = length $ combineItemListYou w

src/Dodge/Floor.hs

@@ -16,6 +16,7 @@ import Dodge.PlacementSpot
 import Dodge.Annotation
 --import Dodge.Placement.Instance.Sensor
 import Dodge.Creature
+import Dodge.Room.Warning
 --import Dodge.LevelGen.Data
 --import Dodge.LevelGen.Switch
 --import Dodge.Item.Weapon.Launcher
@@ -39,6 +40,7 @@ import System.Random
 initialAnoTree :: Tree [Annotation]
 initialAnoTree = padSucWithDoors $ treeFromPost 
     [[AnoApplyInt 0 startRoom]
+    , [SpecificRoom $ warningRooms 7]
     , [SpecificRoom $ return (return . UseAll $ roomRectAutoLinks 400 400
         & rmPmnts .++~ [spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
                 , spNoID anyUnusedSpot (PutCrit armourChaseCrit)

src/Dodge/Inventory.hs

@@ -164,6 +164,10 @@ updateTerminalLine w = case w ^? hud . hudElement . subInventory . termParams .
     Just (TerminalLineEffect _ eff) -> w
         & hud . hudElement . subInventory . termParams . termFutureLines %~ tail
         & eff (_subInventory . _hudElement $ _hud w)
+    Just (TerminalLineChoice _ ops) -> w
+        & hud . hudElement . subInventory . termParams . termFutureLines %~ tail
+        & hud . hudElement . subInventory . termParams . termOptions .~ ops
+        & hud . hudElement . subInventory . termParams . termSel ?~ 0
 
 -- this looks ugly...
 updateCloseObjects :: World -> World

src/Dodge/Machine.hs

@@ -35,8 +35,7 @@ machineUpdateDeathEff f mc
 
 machineAddSound :: SoundID -> (Machine -> World -> World) -> Machine -> World -> World
 machineAddSound sid f mc w
-    | d < 200 
+    | d < 200   = soundContinueVol (1-0.005*d) (MachineSound mid) (_mcPos mc) sid (Just 2) $ f mc w
-        = soundContinueVol (1-0.005*d) (MachineSound mid) (_mcPos mc) sid (Just 2) $ f mc w
     | otherwise = f mc w
   where
     d = dist (_crPos $ you w) (_mcPos mc)

src/Dodge/Placement/Instance/Analyser.hs

@@ -1,9 +1,13 @@
-module Dodge.Placement.Instance.Analyser where
+module Dodge.Placement.Instance.Analyser 
+    ( analyser'
+    , testYouHave
+    , testYourHealth
+    ) where
 import Dodge.LevelGen.Data
 --import Dodge.PlacementSpot
 import Dodge.Data
 import Dodge.Base.You
-import Dodge.Default
+--import Dodge.Default
 --import Dodge.Tree
 --import Dodge.RoomLink
 --import Dodge.Room.Door
@@ -14,7 +18,7 @@ import Dodge.Default
 --import Dodge.Room.Foreground
 --import Dodge.Room.RoadBlock
 import Dodge.Placement.Instance
-import Dodge.Placement.Shift
+--import Dodge.Placement.Shift
 import Dodge.SoundLogic
 --import Dodge.Default.Room
 --import Dodge.Item.Weapon.BulletGuns
@@ -24,8 +28,8 @@ import Dodge.SoundLogic
 import Geometry
 --import Padding
 import Color
-import Shape
+--import Shape
-import ShapePicture
+--import ShapePicture
 import LensHelp
 --import Dodge.RandomHelp
 
@@ -67,6 +71,8 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t
                     ++ map simpleline afters
                 , _termMaxLines = 7
                 , _termTitle = "ANALYSER"
+                , _termSel = Nothing
+                , _termOptions = []
                 }
         )
         (\mc -> upf mc . (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
@@ -79,41 +85,6 @@ analyser' starts sucs fails afters upf pslight psmc = extTrigLitPos pslight $ \t
         _ -> (fails,red)
     updatebuttonname = plType . putButton . btText .~ "ANALYSER"
 
-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 $ psPtCont psmc
-    (PutMachine aquamarine (reverse $ square 10) defaultMachine
-        { _mcDraw = const . noPic . colorSH aquamarine . upperPrismPoly 25 $ square 10
-        , _mcUpdate = \mc -> (triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc))
-                        . upf mc
-        , _mcSensor = SensorCloseToggle NotClose False
-        }
-    ) $ \anmc -> Just
-    $ plSpot .~ shiftRelativeToPS (V2 20 0) (_plSpot anmc)
-    $ 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)}
-    testline' mcid = TerminalLineDisplay 0 (testline mcid)
-    testline mcid w = case w ^? machines . ix mcid . mcSensor . sensToggle of
-        Just True -> (sucs,green)
-        _ -> (fails,red)
-    updatebuttontext = plType . putButton . btText .~ "ANALYSER"
-
 analyserTest :: (World -> Bool) -> Machine -> World -> World
 analyserTest t mc w = case 
         (_sensCloseToggle sens

src/Dodge/Placement/Instance/Terminal.hs

@@ -27,7 +27,7 @@ putTerminal'
     -> Placement
 putTerminal' col mcf = ps0PushPS (PutButton thebutton)
     $ \pl -> Just $ pt0 (PutMachine col (reverse $ square 10) defaultMachine
-    { _mcDraw = noPic . colorSH col . terminalShape
+    { _mcDraw = noPic . terminalShape col
     , _mcHP = 100
     , _mcUpdate = mcf (fromJust $ _plMID pl)
     , _mcSensor = SensorCloseToggle NotClose False
@@ -42,13 +42,13 @@ putTerminal' col mcf = ps0PushPS (PutButton thebutton)
         , _btID = 0
         , _btText = "TERMINAL"
         , _btState = BtOff
-        , _btTerminalParams = TerminalParams [] [] 10 "TERMINAL"
+        , _btTerminalParams = TerminalParams [] [] 10 "TERMINAL" Nothing []
         }
 
 putTerminal :: (GenParams -> TerminalParams) -> Placement
 putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
     $ \pl -> Just $ pt0 (PutMachine terminalColor (reverse $ square 10) defaultMachine
-    { _mcDraw = noPic . colorSH terminalColor . terminalShape
+    { _mcDraw = noPic . terminalShape terminalColor
     , _mcHP = 100
     , _mcUpdate = machineAddSound fridgeHumS 
         $ machineUpdateDeathEff $ \mc -> (buttons . at (fromJust (_plMID pl)) .~ Nothing)
@@ -68,14 +68,24 @@ putTerminal f = plGenUpdate ?~ g $ ps0PushPS (PutButton thebutton)
         , _btID = 0
         , _btText = "TERMINAL"
         , _btState = BtOff
-        , _btTerminalParams = TerminalParams [] [] 10 "TERMINAL"
+        , _btTerminalParams = TerminalParams [] [] 10 "TERMINAL" Nothing []
         }
 
 terminalColor :: Color
 terminalColor = dark magenta
 
-terminalShape :: Machine -> Shape
+terminalShape :: Color -> Machine -> Shape
-terminalShape _ = upperPrismPoly 15 $ square 10
+--terminalShape _ = upperPrismPoly 15 $ square 10
+terminalShape col _ = 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]
+    )
 
 displayTerminalMessage :: Int -> World -> World
 displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory DisplayTerminal
@@ -84,18 +94,21 @@ displayTerminalMessage btid w = w & hud . hudElement .~ DisplayInventory Display
     }
 
 simpleTermMessage :: [String] -> (GenParams -> TerminalParams)
-simpleTermMessage ss = const $ TerminalParams
+simpleTermMessage = genTermMessage . const
-    {_termDisplayedLines = []
+--simpleTermMessage ss = const $ TerminalParams
-    ,_termFutureLines = TerminalLineEffect 0 termsound
+--    {_termDisplayedLines = []
-        : map totermline (topFlushStrings ss ++ ss)
+--    ,_termFutureLines = TerminalLineEffect 0 termsound
-    ,_termMaxLines = 7
+--        : map totermline (topFlushStrings ss ++ ss)
-    ,_termTitle = "TERMINAL"
+--    ,_termMaxLines = 7
-    }
+--    ,_termTitle = "TERMINAL"
-  where
+--    ,_termSel = Nothing
-    totermline s = TerminalLineDisplay 0 (const (s,white))
+--    ,_termMaxSel = Nothing
-    termsound subinv w' = soundStart TerminalSound tpos computerBeepingS Nothing w'
+--    }
-      where
+--  where
-        tpos = fromMaybe 0 $ w' ^? buttons . ix (_termID subinv) . btPos
+--    totermline s = TerminalLineDisplay 0 (const (s,white))
+--    termsound subinv w' = soundStart TerminalSound tpos computerBeepingS Nothing w'
+--      where
+--        tpos = fromMaybe 0 $ w' ^? buttons . ix (_termID subinv) . btPos
 
 topFlushStrings :: [String] -> [String]
 topFlushStrings = topFlush . maximum . map length
@@ -110,6 +123,8 @@ genTermMessage f = \gp -> TerminalParams
         : map totermline (topFlushStrings (f gp) ++ f gp)
     ,_termMaxLines = 7
     ,_termTitle = "TERMINAL"
+    ,_termSel = Nothing
+    ,_termOptions = []
     }
   where
     totermline s = TerminalLineDisplay 0 (const (s,white))

src/Dodge/PlacementSpot.hs

@@ -21,6 +21,7 @@ module Dodge.PlacementSpot
     , twoRoomPoss
     , isUnusedLnkType
     , rprBoolShift 
+    , rprShift
     , rprBool
     , shiftInBy
     , resetPLUse
@@ -71,6 +72,15 @@ resetPLUse (PSPos f g fallback) = PSPos f' g fallback
     f' rp = fmap (second (rpPlacementUse .~ 0)) . f rp
 resetPLUse _ = error "Tried to reset _rpPlacementUse of non PSPos placement"
 
+rprShift
+    :: (RoomPos -> Room -> Maybe (Point2,Float)) 
+    -> PlacementSpot
+rprShift t = PSPos f (const id) Nothing
+  where
+    f rp r = case t rp r of
+        Just (p,a)  -> Just (PS p a, rp & rpPlacementUse +~ 1)
+        Nothing     -> Nothing
+
 rprBoolShift :: (RoomPos -> Room -> Bool) 
     -> ((Point2,Float) -> (Point2,Float))
     -> PlacementSpot

src/Dodge/Render/HUD.hs

@@ -84,9 +84,13 @@ subInventoryDisplay subinv cfig w = case subinv of
     DisplayTerminal {_termParams = tp} -> pictures
         [ invHead cfig (_termTitle tp)
         , renderListAt subInvX 60 cfig 
+            . (++ (map (\(str,_) -> (str,white)) (_termOptions tp)))
             . reverse 
             . take (_termMaxLines tp) 
             $ _termDisplayedLines tp <&> ($ w)
+        , fromMaybe mempty $ do
+            cursori <- _termSel tp <&> (+ _termMaxLines tp)
+            return $ listCursorNSW subInvX 60 cfig cursori white 15 1
         ]
     CombineInventory mi -> pictures
         [ invHead cfig "COMBINE"

src/Dodge/Room/Door.hs

@@ -34,6 +34,7 @@ triggerDoorRoom inplid = defaultRoom
     , _rmLinks  = init lnks++ [last lnks]
     , _rmPath   = [(V2 20 35,V2 20 5)]
     , _rmInPmnt = [InPlacement f inplid]
+    , _rmName   = "triggerDoorRoom"
 -- door extends into side walls (for shadows as rendered 12/03/21)
 -- note no bounds
     }

src/Dodge/Room/SensorDoor.hs

@@ -47,7 +47,6 @@ sensorRoomRunPast dt n = do
     t <- sensorRoom dt n
     return (applyToSubforest [0] (++
         [treeFromPost [PassDown $ door & rmConnectsTo .~ S.member InLink
-            & rmName .~ "test"
         ] (UseLabel 0 corridor)]
         ) t 
         ,TreeSubLabelling "sensorRoomRunPast" Nothing)

src/Dodge/Room/Warning.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE TupleSections #-}
+module Dodge.Room.Warning where
+import Dodge.LevelGen.Data
+import Dodge.PlacementSpot
+import Dodge.Placement.Instance.Terminal
+import Dodge.Data
+import Dodge.Tree
+--import Dodge.RoomLink
+import Dodge.Room.Door
+import Dodge.Room.Ngon
+import Dodge.Room.Procedural
+--import Dodge.Room.Corridor
+import Dodge.Room.Link
+--import Dodge.Room.Procedural
+--import Dodge.Room.Foreground
+--import Dodge.Room.RoadBlock
+import Dodge.Placement.Instance
+--import Dodge.Default.Room
+--import Dodge.Item.Weapon.BulletGuns
+--import Dodge.Item.Weapon.Utility
+--import Dodge.LevelGen.Data
+--import Geometry.Data
+import Geometry
+--import Padding
+--import Color
+--import Shape
+--import Lorem
+import LensHelp
+import Dodge.RandomHelp
+
+--import qualified Data.Set as S
+import Data.Maybe
+--import Data.Char
+--import Data.Tree
+import Control.Monad.State
+import System.Random
+
+
+warningRooms :: RandomGen g => Int -> State g (LabSubCompTree Room)
+warningRooms n = do
+    rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200]
+    cenroom <- shuffleLinks $ addWarningTerminal n rm
+    let doorroom = triggerDoorRoom n
+    return ( treeFromPost [PassDown door,PassDown cenroom,PassDown doorroom] (UseAll door)
+        , TreeSubLabelling "warningRooms" Nothing)
+
+addWarningTerminal :: Int -> Room -> Room
+addWarningTerminal outplid = (rmName .++~ "warningTerm-")
+    -- & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid]
+    . (rmOutPmnt .~ [OutPlacement outplace outplid])
+  where
+    outplace = extTrigLitPos
+        (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a)))
+        (\trid -> Just $ set plSpot (rprShift fps) $ putTerminal $ termMessages trid)
+    --termspot = atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))
+    fps rp rm = case rp ^? rpLinkStatus . rplsChildNum of
+        Just 0 -> 
+            let rppos = _rpPos rp
+                rpdir = _rpDir rp
+                inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5))
+                rtpos = inpos +.+ rotateV rpdir (V2 30 0)
+                ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0)
+            in if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm)
+                -- the above test may not work properly if the room polys are
+                -- complicated, it should really use created walls...
+                then Just (rtpos, rpdir)
+                else Just (ltpos, rpdir)
+        _ -> Nothing
+    termMessages trid = (genTermMessage $ const ["A","TEST"]) 
+        <&> termFutureLines %~ (++ [TerminalLineChoice 0 (ops trid)])
+    ops trid = [ ("OPEN", triggers . ix (fromJust $ _plMID trid) .~ const True)
+        , ("LEAVE", id)
+        ]
+        

src/Geometry/Polygon.hs

@@ -8,16 +8,16 @@ import Data.Maybe
 import Data.List
 import qualified Control.Foldl as L
 
--- | Draw a clockwise rectangle based on maximal N E S W values.
+-- | Draw an anticlockwise rectangle based on maximal N E S W values.
 rectNESW :: Float -> Float -> Float -> Float -> [Point2]
 rectNESW !a !b !c !d = [V2 b a,V2 b c,V2 d c,V2 d a]
 -- | Draw a clockwise rectangle based on maximal N S E W values.
 rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
 rectNSEW !n !s !e !w = rectNESW n e s w
--- | Draw a clockwise rectangle based on maximal N S W E values.
+-- | Draw an anticlockwise rectangle based on maximal N S W E values.
 rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
 rectNSWE !n !s !w !e = [V2 w n, V2 w s, V2 e s, V2 e n]
--- | Draw a  clockwise rectangle around the origin with given height and width
+-- | Draw an anticlockwise rectangle around the origin with given height and width
 rectWH :: Float -> Float -> [Point2]
 rectWH w h = rectNSWE h (-h) (-w) w