diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index fb7c0a5b6..6c3c3ee29 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -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 diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index 265fda5b6..13daf031c 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -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 diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 597716fd4..33b92ef3c 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -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) diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 3eab5182b..f77465201 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -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 diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index eb4e60f82..9ce53bbac 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -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)] diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index dbbbca136..f47f1c84b 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -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 diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 984fc0a35..36c8a1286 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -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 diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 26ddd039b..ede8029cd 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 0899d068b..a4aff0b73 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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'. -} diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 0b1a2a9a9..fea5f51f0 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -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