Commit towards merge

2022-03-20 17:18:12 +00:00
parent 6c3e335ded
commit 5e897c6a6c
10 changed files with 301 additions and 98 deletions
@@ -174,7 +174,7 @@ data ScreenLayer
        , _scOptionFlag :: OptionScreenFlag
        }
    | ColumnsScreen String [(String,String)]
-    | InputScreen String
+    | InputScreen String String
    | WaitScreen
        { _scWaitMessage :: Universe -> String
        , _scWaitTime    :: Int
@@ -616,6 +616,7 @@ data ItemParams
        , _shellThrustDelay :: Int
        }
    | Refracting    {_phaseV :: Float}
+    | Traction    {_power :: Point2}
    | BulletShooter -- this should possibly be moved into ammo type
        { _muzVel   :: Float
        , _rifling  :: Float
@@ -1,14 +1,32 @@
 module Dodge.Debug.Terminal
+<<<<<<< HEAD
    ( applyTerminalString
    ) where
 import Dodge.Data
 import Dodge.Creature
 import Dodge.Creature.YourControl
 import Dodge.Creature.State
+=======
+    where
+import           Dodge.Creature
+import           Dodge.Creature.State
+import           Dodge.Creature.YourControl
+import           Dodge.Data
+import Dodge.Menu.PushPop
+import Control.Monad
+>>>>>>> ross/loop-master

-import Control.Lens
+import           Control.Lens
+import Text.Read (readMaybe)
+import Data.List (isPrefixOf, isInfixOf, intercalate)
+import Data.Maybe (fromJust)
+import LensHelp
+import qualified Debug.Trace
+import Graphics.Rendering.OpenGL.GL.Shaders (validateProgram)
+import Dodge.Data (Universe(Universe))

 applyTerminalString :: String -> Universe -> Universe
+<<<<<<< HEAD
 applyTerminalString str = case str of
    "NOCLIP" -> config . debug_noclip %~ not
    "LOADME" -> (uvWorld . creatures . ix 0 . crInv .~ stackedInventory)
@@ -23,3 +41,98 @@ applyTerminalString str = case str of

 loadme :: a -> a
 loadme = id
+=======
+applyTerminalString "NOCLIP" = config . debug_noclip %~ not
+applyTerminalString "LOADME" = (uvWorld . creatures . ix 0 . crInv .~ stackedInventory)
+    . (uvWorld . creatures . ix 0 . crInvCapacity .~ 50)
+applyTerminalString "GODON" =
+    uvWorld . creatures . ix 0 . crUpdate .~ stateUpdateDamage clearDamage yourControl
+applyTerminalString "GODOFF" = uvWorld . creatures . ix 0 . crUpdate .~ stateUpdate yourControl
+applyTerminalString "LOADTEST" = (uvWorld . creatures . ix 0 . crInv .~ testInventory)
+    . (uvWorld . creatures . ix 0 . crInvCapacity .~ 50)
+applyTerminalString "LM" = applyTerminalString "LOADME"
+applyTerminalString "LT" = applyTerminalString "LOADTEST"
+applyTerminalString ('s': 'e': 't': '_': 'h': 'p': ' ': hp)
+    | (readMaybe hp :: Maybe Int) == Nothing = id
+    | otherwise = uvWorld . creatures . ix 0 . crHP .~ read hp
+applyTerminalString ('s': 'e': 't': '_': 'i': 'n': 'v': 'c': 'a': 'p': ' ': n)
+    | (readMaybe n :: Maybe Int) == Nothing = id
+    | otherwise = (uvWorld . creatures . ix 0 . crInvCapacity .~ read n)
+applyTerminalString ('s': 'e': 't': ' ': var)
+    | var /= [] = applySetTerminalString var
+    | otherwise = id
+applyTerminalString ('g': 'o': 'd': ' ': var)
+    | var == "on" = applyTerminalString "GODON"
+    | var == "off" = applySetTerminalString "GODOFF"
+    | otherwise = showTerminalError ("god "++var) ("Invalid god argument: " ++ var)
+applyTerminalString ('s': 'p': 'a': 'w': 'n': ' ': var)
+    | var /= [] = id -- work out how to spawn stuff
+    | otherwise = id
+applyTerminalString _   = id
+
+showTerminalError :: String -> String -> Universe -> Universe
+showTerminalError cmd s = menuLayers .:~ InputScreen cmd s
+
+applySetTerminalString :: String -> Universe -> Universe
+applySetTerminalString [] = id
+applySetTerminalString var = case key' of
+    "" -> showTerminalError ("set "++var) ("Unable to read as argument as float: " ++ val)
+    "hp" -> uvWorld . creatures . ix 0 . crHP .~ round (fromJust val')
+    "invcap" -> uvWorld . creatures . ix 0 . crInvCapacity .~ round (fromJust val')
+    "invsel" -> uvWorld . creatures . ix 0 . crInvSel .~ round (fromJust val')
+    "mass" -> uvWorld . creatures . ix 0 . crMass .~ fromJust val'
+    "mvspeed" -> uvWorld . creatures . ix 0 . crMvType .mvSpeed .~ fromJust val'
+    _ -> showTerminalError ("set "++var) ("Invalid set command: " ++ key) -- never reached?
+    where
+        (key, val) = getSplitString var
+        val' = readMaybe val :: Maybe Float
+        key' = if val' == Nothing then "" else key
+
+autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe)
+autoCompleteTerminal s help = return . (popScreen' >=> pushScreen' (InputScreen input_str valid_commands))
+            where
+            (key, val) = getSplitString $ tail s
+            command_options = case val of
+                "" -> filter (isInfixOf key) (validTerminalCommands "")
+                _ -> filter (isInfixOf val) (validTerminalCommands key)
+            -- basic autocomplete if single option available (or as far as possible)
+            input_str = case (key, val) of
+                (_, "") -> if length command_options == 1 then ">" ++ head command_options ++ " " else ">" ++ longestCommonPrefix command_options
+                _ -> if length command_options == 1 then ">" ++ key ++ " " ++ head command_options ++ " " else if null command_options then s else ">" ++ key ++ " " ++ longestCommonPrefix command_options
+
+            command_options' = if length command_options > 0 && head command_options == key then validTerminalCommands key else command_options
+
+            --val' = Debug.Trace.trace key tail val
+            valid_commands = "Options: " ++ intercalate ", " command_options'
+
+getSplitString :: [Char] -> ([Char], [Char])
+getSplitString str = case break (==' ') str of
+    (a, _:b) -> (a, b)
+    (a, _) -> (a, "")
+
+isValidCommand :: String -> String -> Bool
+isValidCommand arg1 arg2
+    | arg2 `elem` v = True
+    | otherwise = False
+    where
+        v = validTerminalCommands arg1
+
+
+validTerminalCommands :: String -> [String]
+validTerminalCommands "set" = ["hp", "invcap", "invsel", "mass", "mvspeed"]
+validTerminalCommands "god" = ["on", "off"]
+validTerminalCommands _ = ["set", "spawn", "god"]
+
+
+loadme :: a
+loadme = undefined
+
+longestCommonPrefix :: Eq a => [[a]] -> [a]
+longestCommonPrefix [] = []
+longestCommonPrefix lists = foldr1 commonPrefix lists
+
+commonPrefix :: Eq a => [a] -> [a] -> [a]
+commonPrefix (x:xs) (y:ys)
+    | x == y    = x : commonPrefix xs ys
+commonPrefix _ _ = []
+>>>>>>> ross/loop-master
@@ -9,59 +9,60 @@ We cannot handle multiple keys held down at once here,
 because these are separate events.
 Instead we store the events in a set, and deal with the combinations in
 "Dodge.Update".  -}
-module Dodge.Event 
+module Dodge.Event
    ( handleEvent
    ) where
-import Dodge.Event.Keyboard
-import Dodge.Combine
+import           Dodge.Combine
+import           Dodge.Event.Keyboard
 --import Dodge.Event.Menu
-import Dodge.Data
-import Dodge.Base
+import           Dodge.Base
+import           Dodge.Data
 --import Dodge.Base.Window
-import Dodge.PreloadData
+import           Dodge.PreloadData
 --import Dodge.Creature.Action
-import Dodge.SoundLogic
-import Dodge.Inventory
-import Dodge.Inventory.Add
+import           Dodge.Inventory
+import           Dodge.Inventory.Add
+import           Dodge.SoundLogic
 --import Geometry
 --import Preload.Update
-import qualified IntMapHelp as IM
-import ListHelp
-import Dodge.FloorItem
+import           Dodge.FloorItem
+import qualified IntMapHelp           as IM
+import           ListHelp

 --import Data.Monoid
-import Data.Maybe
-import Control.Lens
+import           Control.Lens
+import           Data.Maybe
 --import Data.Maybe
 --import Data.Char
 --import Data.List
 --import Data.Function (on)
-import qualified Data.Set as S
-import SDL
+import qualified Data.Set             as S
+import           SDL

 handleEvent :: Event -> Universe -> IO (Maybe Universe)
 handleEvent e = case eventPayload e of
-    KeyboardEvent kev           -> handleKeyboardEvent kev
-    MouseMotionEvent mmev       -> return . handleMouseMotionEvent mmev
-    MouseButtonEvent mbev       -> return . handleMouseButtonEvent mbev
-    MouseWheelEvent mwev        -> return . handleMouseWheelEvent mwev
-    WindowSizeChangedEvent sev  -> handleResizeEvent sev
-    WindowMovedEvent mev        -> return . handleWindowMoveEvent mev
-    _                           -> return . Just
+    TextInputEvent tev         -> handleTextInputEvent tev
+    KeyboardEvent kev          -> handleKeyboardEvent kev
+    MouseMotionEvent mmev      -> return . handleMouseMotionEvent mmev
+    MouseButtonEvent mbev      -> return . handleMouseButtonEvent mbev
+    MouseWheelEvent mwev       -> return . handleMouseWheelEvent mwev
+    WindowSizeChangedEvent sev -> handleResizeEvent sev
+    WindowMovedEvent mev       -> return . handleWindowMoveEvent mev
+    _                          -> return . Just

 handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe
 handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2
    (fromIntegral x - 0.5*_windowX cfig)
    (0.5*_windowY cfig - fromIntegral y)
-  where 
+  where
    cfig = _config u
    P (V2 x y) = mouseMotionEventPos mmev

 handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe
 handleMouseButtonEvent mbev = case mouseButtonEventMotion mbev of
    Released -> Just . updateButtons S.delete
-    Pressed  -> handlePressedMouseButton thebutton . updateButtons S.insert 
-  where 
+    Pressed  -> handlePressedMouseButton thebutton . updateButtons S.insert
+  where
    thebutton = mouseButtonEventButton mbev
    updateButtons f = uvWorld . mouseButtons %~ f thebutton

@@ -81,7 +82,7 @@ handleResizeEvent sev u = return . Just $ u
    & config . windowX .~ fromIntegral x
    & config . windowY .~ fromIntegral y
    & uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y
-  where 
+  where
    x = fromIntegral x'
    y = fromIntegral y'
    V2 x' y' = windowSizeChangedEventSize sev
@@ -136,7 +137,7 @@ wheelEvent y w = case _hudElement $ _hud w of
        | invKeyDown -> stopSoundFrom (CrReloadSound 0) $ changeInvSel yi w
        | rbDown ->     w & changeTweakParam yi
        | otherwise ->  w & moveTweakSel yi
-    DisplayInventory (CombineInventory _) -> w 
+    DisplayInventory (CombineInventory _) -> w
        & hud . hudElement . subInventory . combineInvSel . _Just %~ ((`mod` numcombs) . subtract yi)
    _ -> w
  where
@@ -165,7 +166,7 @@ moveTweakSel i w = case yourItem w ^? _Just . itTweaks . tweakParams of
                    . itTweaks . tweakSel %~ (`mod` length l) . subtract i
    _ -> w
 changeTweakParam :: Int -> World -> World
-changeTweakParam i w = w 
+changeTweakParam i w = w
    & creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)) %~
        ( (itTweaks . tweakParams . ix paramid . curTweak .~ x)
        . _doTweak params x)
@@ -1,23 +1,35 @@
 {- | Deals with keyboard events.  -}
 module Dodge.Event.Keyboard
    ( handleKeyboardEvent
+    , handleTextInputEvent
    ) where
-import Dodge.Data
-import Dodge.Combine
-import Dodge.Save
-import Dodge.Base
-import Dodge.Reloading
-import Dodge.Creature.Action
-import Dodge.Event.Test
-import Dodge.Event.Menu
-import Dodge.Menu
-import Dodge.Inventory
-import qualified Data.IntMap.Strict as IM
+import qualified Data.IntMap.Strict    as IM
+import           Dodge.Base
+import           Dodge.Combine
+import           Dodge.Creature.Action
+import           Dodge.Data
+import           Dodge.Event.Menu
+import           Dodge.Event.Test
+import           Dodge.Inventory
+import           Dodge.Menu
+import           Dodge.Reloading
+import           Dodge.Save

-import SDL
-import Data.Maybe
-import qualified Data.Set as S
-import Control.Lens
+import           Control.Lens
+import           Data.Maybe
+import qualified Data.Set              as S
+import           SDL
+import Data.Text (unpack)
+
+handleTextInputEvent :: TextInputEventData -> Universe -> IO (Maybe Universe)
+handleTextInputEvent tev = handleTextInput text
+  where
+    text = unpack $ textInputEventText tev
+
+handleTextInput :: String -> Universe -> IO (Maybe Universe)
+handleTextInput text w  
+    | null (_menuLayers w) = return $ Just w
+    | otherwise = handleTextInMenu (head $ _menuLayers w) text w

 {- | Handles keyboard press and release.
 On release, remove scancode from the 'Set' of pressed keys.
@@ -26,20 +38,21 @@ see 'handlePressedKeyInGame'.
 -}
 handleKeyboardEvent :: KeyboardEventData -> Universe -> IO (Maybe Universe)
 handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of
-    Released    -> return . Just $ u & uvWorld . keys %~ S.delete kcode
-    Pressed     -> handlePressedKey (keyboardEventRepeat kev) kcode
-        (u & uvWorld . keys %~ S.insert kcode) 
+    Released    -> return . Just $ u & uvWorld . keys %~ S.delete scode
+    Pressed     -> handlePressedKey (keyboardEventRepeat kev) scode
+        (u & uvWorld . keys %~ S.insert scode)
  where
-    kcode = (keysymScancode . keyboardEventKeysym) kev
+    scode = (keysymScancode . keyboardEventKeysym) kev

 handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe)
-handlePressedKey True _     w   = return $ Just w
-handlePressedKey _    ScancodeF5 w = return . Just $ doQuicksave w
-handlePressedKey _    ScancodeF9 w = return . Just $ loadSaveSlot QuicksaveSlot w
-handlePressedKey _    ScancodeSemicolon w = return . Just $ gotoTerminal w
-handlePressedKey _    scode w
+handlePressedKey True _    w   = return $ Just w
+handlePressedKey _   ScancodeF5 w = return . Just $ doQuicksave w
+handlePressedKey _   ScancodeF9 w = return . Just $ loadSaveSlot QuicksaveSlot w
+handlePressedKey _   ScancodeSemicolon w = return . Just $ gotoTerminal w
+handlePressedKey _   scode w
    | null (_menuLayers w)      = return $ uvWorld (handlePressedKeyInGame scode) w
    | otherwise                 = handlePressedKeyInMenu (head $ _menuLayers w) scode w
+    -- | otherwise                 = return $ Just w

 handlePressedKeyInGame :: Scancode -> World -> Maybe World
 handlePressedKeyInGame scode w = case scode of
@@ -67,8 +80,8 @@ toggleInspectInv he = case he of

 gotoTerminal :: Universe -> Universe
 gotoTerminal w = case _menuLayers w of
-    (InputScreen _ : _ ) ->  w
-    _ -> w & menuLayers %~ (InputScreen [] :)
+    (InputScreen _ _ : _ ) ->  w
+    _                    -> w & menuLayers %~ (InputScreen [] "Enter command" :)

 spaceAction :: World -> World
 spaceAction w = case _hudElement $ _hud w of
@@ -76,21 +89,21 @@ spaceAction w = case _hudElement $ _hud w of
    DisplayInventory NoSubInventory -> case selectedCloseObject w of
        Just (_,Left flit) -> pickUpItem 0 flit w
        Just (_,Right but) -> _btEvent but but w
-        _ -> w
+        _                  -> w
    DisplayInventory DisplayTerminal {} -> w & hud . hudElement .~ DisplayInventory NoSubInventory
    _ -> w & hud . hudElement .~ DisplayInventory NoSubInventory
  where
    theLoc = fst (_seenLocations w IM.! _selLocation w) w
--    updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail 
+--    updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail

 pauseGame :: World -> World
 pauseGame w = w & sideEffects %~ (. (menuLayers .~ [pauseMenu]))

 toggleMap :: World -> World
 toggleMap w = case _hudElement $ _hud w of
-    DisplayCarte    -> w & hud . hudElement .~ DisplayInventory NoSubInventory
-    _               -> w & hud . hudElement .~ DisplayCarte
+    DisplayCarte -> w & hud . hudElement .~ DisplayInventory NoSubInventory
+    _            -> w & hud . hudElement .~ DisplayCarte
 escapeMap :: World -> World
 escapeMap w = case _hudElement $ _hud w of
-    DisplayCarte    -> w & hud . hudElement .~ DisplayInventory NoSubInventory
-    _               -> w
+    DisplayCarte -> w & hud . hudElement .~ DisplayInventory NoSubInventory
+    _            -> w
@@ -1,6 +1,7 @@
 module Dodge.Event.Menu
    ( handlePressedKeyInMenu
-    ) 
+    , handleTextInMenu
+    )
  where
 import Dodge.Data
 import Dodge.Debug.Terminal
@@ -11,25 +12,44 @@ import Data.Maybe
 import Control.Monad
 --import Control.Lens
 import SDL
+import Control.Lens ((%~))
+import qualified Debug.Trace
+
+
+handleTextInMenu :: ScreenLayer -> [Char] -> Universe -> IO (Maybe Universe)
+handleTextInMenu mState text = case mState of
+    InputScreen s help-> return . (popScreen' >=> pushScreen' (InputScreen new_text help))
+        where
+            new_text
+                -- Text events occur after key events so ignore the first
+                -- (key that opened the terminal menu)
+                | s == "" = ">"
+                | otherwise = s ++ text
+    _ -> return . Just
+

 handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe)
 handlePressedKeyInMenu mState scode = case mState of
-    OptionScreen { _scOptions = mos, _scDefaultEff = defeff} 
+    OptionScreen { _scOptions = mos, _scDefaultEff = defeff}
                        -> optionListToEffects mos defeff scode
    DisplayScreen {}    -> popScreen
    ColumnsScreen {}    -> popScreen
    WaitScreen {}       -> return . Just
-    InputScreen s       -> case scode of
+    InputScreen s help       -> case scode of
        ScancodeEscape  -> popScreen
-        ScancodeReturn  -> popScreen . applyTerminalString s
-        ScancodeBackspace 
-            -> return . (popScreen' >=> pushScreen' (InputScreen $ dropLast s))
-        _   -> return . (popScreen' >=> pushScreen' (InputScreen $ s ++ [scodeToChar scode]))
-  where 
+        -- Remove the menu layer (we readd it in applyTerminalString if the commmand fails)
+        ScancodeReturn  -> return. Just . applyTerminalString (tail s) . (menuLayers %~ tail)
+        ScancodeTab  -> autoCompleteTerminal s help
+        ScancodeBackspace
+            -> return . (popScreen' >=> pushScreen' (InputScreen (dropLast s) "Enter command"))
+            -- Ignore (text input now handled by handleText)
+        _   -> return . (popScreen' >=> pushScreen' (InputScreen s help))
+  where
+    dropLast [x] = ['>']
    dropLast (x:xs) = init (x:xs)
-    dropLast _      = []
+    dropLast _      = ['>']

-optionListToEffects :: [MenuOption] -> (Universe -> IO (Maybe Universe)) -> Scancode 
+optionListToEffects :: [MenuOption] -> (Universe -> IO (Maybe Universe)) -> Scancode
    -> Universe -> IO (Maybe Universe)
 optionListToEffects mos defaulteff sc = fromMaybe defaulteff .
    lookup sc $ concatMap menuOptionToEffects mos
@@ -37,9 +57,9 @@ optionListToEffects mos defaulteff sc = fromMaybe defaulteff .
 menuOptionToEffects :: MenuOption -> [(Scancode,Universe -> IO (Maybe Universe))]
 menuOptionToEffects Toggle          {_moKey = k, _moEff = eff} = [(k,eff)]
 menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)]
-menuOptionToEffects Toggle2 
+menuOptionToEffects Toggle2
    { _moKey1 = k1
    , _moEff1 = eff1
    , _moKey2 = k2
-    , _moEff2 = eff2 
+    , _moEff2 = eff2
    } = [(k1,eff1) , (k2,eff2)]
@@ -145,7 +145,49 @@ tractorGun = lasGun
        & useAim . aimSpeed .~ 0.4
        & useAim . aimRange .~ 1
        & useAim . aimStance .~ TwoHandTwist
+    , _itDimension = ItemDimension
+        { _dimRad = 10
+        , _dimCenter = V3 15 0 0
+        , _dimPortage = HeldItem 5 30
+        , _dimSPic = tractorGunPic
+        }
+    , _itParams = Traction  {_power = 1}
+    , _itTweaks = Tweakable
+        { _tweakParams = IM.fromList [(0,tractorGunTweak)]
+        , _tweakSel = 0
+        }
    }
+tractorGunTweak :: TweakParam
+tractorGunTweak = TweakParam
+    { _doTweak = thetweak
+    , _curTweak = 1
+    , _maxTweak = 4
+    , _showTweak = showPower
+    , _nameTweak = "TRACTION POWER"
+    }
+  where
+    thetweak 0 = itParams . power .~ 1
+    thetweak 1 = itParams . power .~ -1
+    thetweak 2 = itParams . power .~ -10
+    thetweak 3 = itParams . power .~ 0
+    thetweak _ = id
+    showPower 0 = "+"
+    showPower 1 = "-"
+    showPower 2 = "#"
+    showPower 3 = "0" -- object should stay in the center of the beam
+    showPower i = "THIS SHOULD NOT BE POSSIBLE" ++ show i
+
+tractorGunPic :: Item -> SPic
+tractorGunPic it = 
+    ( colorSH red $ 
+           upperPrismPoly 4 (rectNESW 3    30   1  0)
+        <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0)
+        <> upperPrismPoly 1 (rectNESW 3    30 (-3) 0)
+    , setLayer 1 . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0
+    )
+  where
+    amFrac = fractionLoadedAmmo it
+    col = brightX 2 1.5 $ mixColors amFrac (1-amFrac) green red

 aTeslaArc :: Creature -> World -> World
 aTeslaArc cr w = set randGen g w
@@ -191,7 +233,7 @@ mvLaser phasev pos dir w pt
        ]

 aTractorBeam :: Item -> Creature -> World -> World
-aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir
+aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir power
  where 
    i = newProjectileKey w
    cpos = _crPos cr
@@ -200,9 +242,10 @@ aTractorBeam _ cr w = w & props . at i ?~ tractorBeamAt i spos outpos dir
    dir = _crDir cr
    outpos = collidePointWalls cpos xpos
        $ wallsAlongLine cpos xpos w
+    power = _power . _itParams $ _crInv cr IM.! _crInvSel cr

-tractorBeamAt :: Int -> Point2 -> Point2 -> Float -> Prop
-tractorBeamAt i pos outpos dir = ProjectileTimed
+tractorBeamAt :: Int -> Point2 -> Point2 -> Float -> Point2 -> Prop
+tractorBeamAt i pos outpos dir power = ProjectileTimed
    { _pjPos = pos
    , _pjStartPos = outpos
    , _pjVel = d
@@ -212,7 +255,7 @@ tractorBeamAt i pos outpos dir = ProjectileTimed
    , _pjTime = 10
    }
  where 
-    d  = unitVectorAtAngle dir
+    d  = unitVectorAtAngle dir * power
 {- |
 The interaction of this with objects, walls etc needs more thought.  -}
 updateTractor :: Prop -> World -> World
@@ -52,7 +52,7 @@ trySeedFromClipboard :: Universe -> IO (Maybe Universe)
 trySeedFromClipboard u = do
    mcstr <- getClipboardString
    case mcstr >>= readMaybe of
-        Nothing -> pushScreen (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER") 
+        Nothing -> pushScreen (seedStartMenu "CLIPBOARD UNUSABLE, NEED INTEGER")
            (u & menuLayers %~ tail)
        Just i -> return . Just $ startSeedGame i u

@@ -71,8 +71,8 @@ optionsOptions =
    ]
 debugMenu :: ScreenLayer
 debugMenu = slTitleOptions
-    "OPTIONS:GAMEPLAY" 
-    debugMenuOptions 
+    "OPTIONS:GAMEPLAY"
+    debugMenuOptions
 debugMenuOptions :: [MenuOption]
 debugMenuOptions =
    [ doption ScancodeF debug_seconds_frame "SHOW SECONDS/FRAME" _debug_seconds_frame
@@ -82,7 +82,7 @@ debugMenuOptions =
    , doption ScancodeP debug_pathing "SHOW PATHING" _debug_pathing
    ]
  where
-    doption scode l t rec 
+    doption scode l t rec
        = Toggle scode (return . Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w))
 gameplayMenu :: ScreenLayer
 gameplayMenu  = slTitleOptions
@@ -107,10 +107,10 @@ soundMenuOptions =
    , theoption ScancodeN volume_music  ScancodeM "MUSIC VOLUME:"   _volume_music
    ]
  where
-    theoption scod1 stype scod2 str voltype = Toggle2 
-        scod1 
+    theoption scod1 stype scod2 str voltype = Toggle2
+        scod1
        (change dec stype)
-        scod2 
+        scod2
        (change inc stype)
        (\w -> str ++ show (round $ 10 * voltype (_config w)::Int))
    change g vt = return . Just . (config . vt %~ g) . sw
@@ -127,7 +127,7 @@ graphicsMenu = slTitleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions
 graphicsMenuOptions :: [MenuOption]
 graphicsMenuOptions =
    [ makeEnumOption ScancodeS resolution_factor "RESOLUTION"    updateFramebufferSize
-    , makeBoolOption ScancodeW wall_textured     "WALL TEXTURES" 
+    , makeBoolOption ScancodeW wall_textured     "WALL TEXTURES"
    , makeBoolOption ScancodeD cloud_shadows     "CLOUD SHADOWS"
    ]

@@ -139,10 +139,11 @@ gameOverMenu = OptionScreen
    , _scOptionFlag = GameOverOptions
    }

-- | hacky
+-- | hacky - no longer used
 scodeToChar :: Scancode -> Char
 scodeToChar = toEnum . (+ 61) . fromIntegral . unwrapScancode

+
 --charToScode :: Char -> Scancode
 --charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum

@@ -11,9 +11,9 @@ import Padding
 menuScreen :: Universe -> ScreenLayer -> Picture
 menuScreen w screen = case screen of
    OptionScreen {_scTitle = titf, _scOptions = mos} 
-                            -> drawOptions w (titf w) mos
-    (WaitScreen sf _)       -> drawOptions w (sf w) []
-    (InputScreen s)         -> drawOptions w ('>':s) []
+                            -> drawOptions w (titf w) mos "Use keys to navigate the menu"
+    (WaitScreen sf _)       -> drawOptions w (sf w) [] ""
+    (InputScreen s help)         -> drawOptions w (s) [] help
    (DisplayScreen sd )     -> sd w
    (ColumnsScreen title pairs) -> drawTwoColumnsScreen (_config w) title pairs

@@ -47,10 +47,11 @@ drawOptions
    :: Universe
    -> String       -- ^ Title
    -> [MenuOption] -- ^ Options
+    -> String       -- ^ Help Text
    -> Picture
-drawOptions u title ops = pictures $
+drawOptions u title ops help = pictures $
    [darkenBackground cfig 
-    , drawTitle cfig title] ++
+    , drawTitle cfig title, drawHelpText cfig help red] ++
    zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s) 
        (map (menuOptionToString u) ops') 
        [hh-100,hh-150 ..]
@@ -73,6 +74,13 @@ drawTitle cfig = placeString (-hw + 30) (hh - 50) 0.4
    hh = halfHeight cfig
    hw = halfWidth  cfig

+drawHelpText :: Configuration -> String -> Color -> Picture
+drawHelpText cfig col = placeString (-hw + 30) (-hh+10) 0.1 col
+  where
+    placeString x y sc t col  = translate x y $ scale sc sc $ color col $ text t
+    hh = halfHeight cfig
+    hw = halfWidth cfig
+
 menuOptionToString :: Universe -> MenuOption -> String
 menuOptionToString w mo = theKeys ++ _moString mo w
  where
@@ -170,6 +170,7 @@ quarterRoomTri w = do
            ]
        , _rmBound  = [[V2 0 0,V2 w w,V2 (-w) w]]
        }
+
 quarterRoomSquare :: RandomGen g => Float -> State g Room
 quarterRoomSquare w = do
    b <- takeOne 
@@ -183,8 +184,9 @@ quarterRoomSquare w = do
            , blockLine (V2 0 w) (V2 0 (w*2))
            ]
        ]
+    let thepoly = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
    pure $ defaultRoom
-        { _rmPolys  = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
+        { _rmPolys  = thepoly
        , _rmLinks  = map toBothLnk
            [ (V2 (w/2) (3*w/2), negate $ pi/4)
            , (V2 (negate $ w/2) (3*w/2), pi/4)
@@ -204,7 +206,8 @@ quarterRoomSquare w = do
        , _rmPmnts = b ++ [ blockLine (V2 (w/2) (w/2)) (V2 0 w) ]
        , _rmPos = [ RoomPos p pi S.empty NotLink 0 
                    | p <- [V2 20 (2*w-40),V2 25 (2*w-45)] ]
-        , _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
+        --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
+        , _rmBound = thepoly
        }
 {- | Randomise the ordering of placements in a room.
 Useful for randomising the position of generic placements such as 'PutNothing'. -}
@@ -34,9 +34,9 @@ posRms :: [ConvexPoly]
    -> [(Int,Tree RoomInt)]     -- the list of children, with indices
    -> Seq (Tree RoomInt)
    -> IO (Maybe [RoomInt])
-posRms bounds (parent,i) [] st = case st of
-    Empty                   -> return $ Just [(parent,i)]
-    Node childi ts :<| tseq -> fmap ((parent,i):) <$> posRms bounds childi (zipCount ts) tseq
+posRms bounds roomi [] st = case st of
+    Empty                   -> return $ Just [roomi]
+    Node nextroomi ts :<| tseq -> fmap (roomi:) <$> posRms bounds nextroomi (zipCount ts) tseq
 posRms bounds parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do
    printInfoCheckNum parenti numChild childi
    tryParentLinks outlinks