From 61f88aeb4ad7758b7f3ec27cc73ce0a41013ac72 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 1 May 2023 22:35:33 +0100 Subject: [PATCH] Cleanup --- src/Dodge/Data/Terminal.hs | 4 +- src/Dodge/Default/Terminal.hs | 8 ++-- src/Dodge/Inventory.hs | 25 +++++++----- src/Dodge/Render/HUD.hs | 68 +++++++++++++++---------------- src/Dodge/Terminal.hs | 37 ++++++++--------- src/Dodge/TmTm.hs | 1 + src/Dodge/Update.hs | 3 +- src/Dodge/Update/Camera.hs | 76 ++++++++++++++++++----------------- src/Dodge/WorldEffect.hs | 19 +++------ 9 files changed, 120 insertions(+), 121 deletions(-) diff --git a/src/Dodge/Data/Terminal.hs b/src/Dodge/Data/Terminal.hs index f136be657..a3f6576b0 100644 --- a/src/Dodge/Data/Terminal.hs +++ b/src/Dodge/Data/Terminal.hs @@ -31,7 +31,7 @@ data TerminalBootProgram data Terminal = Terminal { _tmID :: Int - , _tmBootProgram :: TerminalBootProgram -- Terminal -> World -> [TerminalLine] + , _tmBootProgram :: TerminalBootProgram , _tmButtonID :: Int , _tmMachineID :: Int , _tmName :: String @@ -46,6 +46,7 @@ data Terminal = Terminal , _tmStatus :: TerminalStatus , _tmCommandHistory :: [String] , _tmToggles :: M.Map String TerminalToggle + , _tmPartialCommand :: Maybe String } --deriving (Eq, Show, Read) --, Generic) --h--deriving (Eq, Show, Read) --Generic, Flat) @@ -57,6 +58,7 @@ data TmTm = TmId | TmTmClearDisplayedLines | TmTmSetStatus TerminalStatus + | TmTmSetPartialCommand (Maybe String) --deriving (Eq, Ord, Show, Read) --Generic, Flat) data TerminalLine diff --git a/src/Dodge/Default/Terminal.hs b/src/Dodge/Default/Terminal.hs index b847bea24..71426d11c 100644 --- a/src/Dodge/Default/Terminal.hs +++ b/src/Dodge/Default/Terminal.hs @@ -1,6 +1,7 @@ -module Dodge.Default.Terminal where +module Dodge.Default.Terminal + ( defaultTerminal + ) where -import qualified Data.Map.Strict as M import Dodge.Data.Terminal import Dodge.Data.WorldEffect @@ -22,7 +23,8 @@ defaultTerminal = , _tmDeathEffect = TmWdId , _tmStatus = TerminalOff , _tmCommandHistory = [] - , _tmToggles = M.empty + , _tmToggles = mempty + , _tmPartialCommand = mempty } defaultTerminalInput :: TerminalInput diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 3e7e40732..a1ae1828d 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -10,7 +10,7 @@ module Dodge.Inventory ( rmInvItem, updateCloseObjects, updateRBList, - updateTerminal, + checkTermDist, closeObjScrollDir, changeSwapSel, scrollAugInvSel, @@ -21,6 +21,7 @@ module Dodge.Inventory ( setInvPosFromSS, ) where +import Control.Monad import Color import Control.Applicative import qualified Data.Map.Strict as M @@ -155,16 +156,20 @@ selNumEndMidHeight cfig ldp sss i j = do selSecSelCol :: Int -> Int -> SelectionSections a -> Maybe Color selSecSelCol i j sss = sss ^? sssSections . ix i . ssItems . ix j . siColor -updateTerminal :: World -> World -updateTerminal = checkTermDist - checkTermDist :: World -> World -checkTermDist w = case w ^? hud . hudElement . subInventory . termID of - Just tmid -> fromMaybe (w & hud . hudElement . subInventory .~ NoSubInventory) $ do - btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID - btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos - if dist btpos (_crPos $ you w) < 40 then Just w else Nothing - Nothing -> w +--checkTermDist w = case w ^? hud . hudElement . subInventory . termID of +-- Just tmid -> fromMaybe (w & hud . hudElement . subInventory .~ NoSubInventory) $ do +-- btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID +-- btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos +-- guard $ dist btpos (_crPos $ you w) < 40 +-- return w +-- Nothing -> w +checkTermDist w = fromMaybe w $ do + tmid <- w ^? hud . hudElement . subInventory . termID + btid <- w ^? cWorld . lWorld . terminals . ix tmid . tmButtonID + btpos <- w ^? cWorld . lWorld . buttons . ix btid . btPos + guard $ dist btpos (_crPos $ you w) > 40 + return (w & hud . hudElement . subInventory .~ NoSubInventory) -- this looks ugly... updateCloseObjects :: World -> World diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index 34e1d0db2..0bfa104a9 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -3,7 +3,7 @@ module Dodge.Render.HUD ( drawHUD, ) where -import Dodge.SelectionSections.Draw +import Data.Foldable import Control.Lens import qualified Data.Map.Strict as M import Data.Maybe @@ -22,8 +22,8 @@ import Dodge.Item.Info import Dodge.ListDisplayParams import Dodge.Render.Connectors import Dodge.Render.List +import Dodge.SelectionSections.Draw import Dodge.Tweak.Show ---import Dodge.WorldPos import Geometry import qualified IntMapHelp as IM import Justify @@ -41,11 +41,10 @@ drawHUD cfig w = case w ^. hud . hudElement of <> drawSubInventory subinv cfig w drawHP :: Configuration -> World -> Picture -drawHP cfig w = dShadCol white $ displayHP 0 cfig w - +drawHP cfig = dShadCol white . displayHP 0 cfig drawInventory :: SelectionSections () -> World -> Configuration -> Picture -drawInventory sss w = drawSelectionSections sss (invDisplayParams w) +drawInventory sss = drawSelectionSections sss . invDisplayParams drawSubInventory :: SubInventory -> Configuration -> World -> Picture drawSubInventory subinv cfig w = case subinv of @@ -55,7 +54,6 @@ drawSubInventory subinv cfig w = case subinv of DisplayTerminal tid -> displayTerminal tid cfig (w ^. cWorld . lWorld) CombineInventory{_ciSections = sss} -> drawCombineInventory cfig sss w - drawCombineInventory :: Configuration -> SelectionSections CombinableItem -> World -> Picture drawCombineInventory cfig sss w = invHead cfig "COMBINE" @@ -66,11 +64,20 @@ drawExamineInventory :: Configuration -> Maybe Int -> World -> Picture drawExamineInventory cfig mtweaki w = invHead cfig "EXAMINE" <> examineInventoryExtra mtweaki itm cfig - <> drawSelectionList secondColumnParams - cfig - ( defaultSelectionList & slItems .~ ammoTweakSelectionItems itm - ++ map f (makeParagraph 60 $ yourAugmentedItem itemInfo (yourInfo (you w)) (closeObjectInfo (crNumFreeSlots (you w))) w) - ) + <> drawSelectionList + secondColumnParams + cfig + ( defaultSelectionList & slItems .~ ammoTweakSelectionItems itm + ++ map + f + ( makeParagraph 60 $ + yourAugmentedItem + itemInfo + (yourInfo (you w)) + (closeObjectInfo (crNumFreeSlots (you w))) + w + ) + ) where itm = yourItem w f str = @@ -78,8 +85,7 @@ drawExamineInventory cfig mtweaki w = { _siPictures = [str] , _siHeight = 1 , _siIsSelectable = True - , --, _siWidth = length str - _siColor = white + , _siColor = white , _siOffX = 0 , _siPayload = () } @@ -104,7 +110,7 @@ yourAugmentedItem f x g w = case you w ^? crManipulation . manObject of drawNoSubInventory :: Configuration -> World -> Picture drawNoSubInventory cfig w = - pictures + fold [ equipcursors , equipcursor -- the order is important, this should go on top of the other equipcursors , rboptions @@ -134,8 +140,6 @@ examineInventoryExtra mtweaki mitm cfig = fromMaybe mempty $ do tparam <- mitm ^? _Just . itTweaks . tweakParams . ix tweaki return $ listCursorNSW subInvX 60 cfig tweaki 0 white (length $ showTweak tparam) 15 --- , drawSelectionList thirdColumnParams cfig (thirdColumnPara (itmInfo mitm)) - combineInventoryExtra :: SelectionSections CombinableItem -> Configuration -> World -> Picture combineInventoryExtra sss cfig w = fromMaybe mempty $ do (i, j) <- sss ^? sssExtra . sssSelPos . _Just @@ -204,13 +208,9 @@ displayTerminal tid cfig w = fromMaybe mempty $ do , drawSelectionList secondColumnParams cfig (thesellist tm) ] where - --toselitm (str, col) = SelectionItem [str] 1 True (length str) col 0 () toselitm (str, col) = SelectionItem [str] 1 True col 0 () thesellist tm = - defaultSelectionList - { _slItems = thelist tm - -- , _slLength = length (thelist tm) - } + defaultSelectionList & slItems .~ thelist tm thelist tm = map toselitm . displayTermInput tm . reverse @@ -218,11 +218,12 @@ displayTerminal tid cfig w = fromMaybe mempty $ do $ _tmDisplayedLines tm displayTermInput tm = case _tmInput tm of TerminalInput s hasfoc _ -> (++ [(displayInputText tm s ++ displayBlinkCursor hasfoc, white)]) + partcommand tm = fromMaybe "" $ tm ^? tmPartialCommand . _Just displayInputText tm s - | _tmStatus tm == TerminalReady = '>' : s + | _tmStatus tm == TerminalReady = partcommand tm ++ "> " ++ s | otherwise = "" displayBlinkCursor hasfoc - | hasfoc = clockCycle 10 (V.fromList ["_", ""]) w + | hasfoc = clockCycle 10 (V.fromList ["_", "."]) w | otherwise = [] drawRBOptions :: Configuration -> World -> RightButtonOptions -> Picture @@ -276,8 +277,7 @@ combineCounts cfig w = foldMap f . group f _ = mempty lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture -lnkMidPosInvSelsCol cfig w i col = - foldMap f +lnkMidPosInvSelsCol cfig w i col = foldMap f where f j = fromMaybe mempty $ do sss <- w ^? hud . hudElement . diSections @@ -301,7 +301,7 @@ tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak tp invHead :: Configuration -> String -> Picture invHead cfig = - translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) + translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) . dShadCol white . scale 0.4 0.4 . text @@ -310,15 +310,16 @@ drawCarte :: Configuration -> World -> Picture drawCarte cfig w = pictures $ renderListAt 0 0 cfig locs : - -- zipWith bConnect (displayListEndCoords cfig locTexts) locPoss - -- ++ + -- zipWith bConnect (displayListEndCoords cfig locTexts) locPoss + -- ++ mapOverlay w ++ [mainListCursor white iPos cfig] where iPos = w ^. cWorld . lWorld . selLocation locs = map (\(_, s) -> (s, white)) . IM.elems . _seenLocations . _lWorld $ _cWorld w - --locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w - --locTexts = map fst locs + +--locPoss = map (cartePosToScreen cfig (w ^. hud) . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations . _lWorld $ _cWorld w +--locTexts = map fst locs --displayListEndCoords :: Configuration -> [String] -> [Point2] --displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..] @@ -399,8 +400,7 @@ picsToSelectable pics = { _siPictures = pics , _siHeight = length pics , _siIsSelectable = True - , --, _siWidth = wdth - _siColor = white + , _siColor = white , _siOffX = 0 , _siPayload = () } @@ -418,8 +418,8 @@ openCursorAt :: Configuration -> Picture openCursorAt wth col xoff yoff yint w = - translate (xoff - halfWidth w) (halfHeight w - (20 * fromIntegral yint + yoff) - 20) - $ lineCol + translate (xoff - halfWidth w) (halfHeight w - (20 * fromIntegral yint + yoff) - 20) $ + lineCol [ (V2 wth 12.5, withAlpha 0 col) , (V2 0 12.5, col) , (V2 0 (-7.5), col) diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index a8998e24e..e754df794 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -22,7 +22,6 @@ import Data.Char import Data.Foldable import qualified Data.Map.Strict as M import Data.Maybe ---import qualified Data.Text as T import Dodge.Data.World import Dodge.Default import Dodge.SoundLogic @@ -38,7 +37,6 @@ basicTerminal = , _tmFutureLines = [] , _tmMaxLines = 14 , _tmTitle = "TERMINAL" - , _tmInput = defaultTerminalInput , _tmScrollCommands = [quitCommand] , _tmWriteCommands = [helpCommand, commandsCommand] , _tmBootProgram = TerminalBootLines connectionBlurb @@ -112,11 +110,6 @@ connectionBlurb = termSoundLine :: SoundID -> TerminalLine termSoundLine sid = TerminalLineEffect 0 (TmWdWdTermSound sid) --- where --- termsound tm w = soundStart TerminalSound tpos sid Nothing w --- where --- tpos = fromMaybe 0 $ w ^? buttons . ix (_tmButtonID tm) . btPos - termTextColor :: Color termTextColor = greyN 0.9 @@ -141,14 +134,14 @@ commandColor = yellow doTerminalCommandEffect :: TerminalCommandEffect -> Terminal -> World -> EffectArguments doTerminalCommandEffect tce = case tce of TerminalCommandArguments eas -> \_ _ -> eas - TerminalCommandEffectDamageCoding -> \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding - TerminalCommandEffectSensorParameter -> \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm - TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) - TerminalCommandEffectHelp -> \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm + TerminalCommandEffectDamageCoding -> \_ -> OneArgument "a damage type" . getDamageCoding + TerminalCommandEffectSensorParameter -> \tm -> OneArgument "a sensor parameter" . sensorInfoMap tm + TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "a linked object" (togglesToEffects tm) + TerminalCommandEffectHelp -> \tm -> OneArgument "an available command" . getCommandsHelp tm TerminalCommandEffectNoArgumentsStr str -> \_ _ -> NoArguments (makeTermPara str) TerminalCommandEffectCommands -> \tm _ -> NoArguments - ( makeTermLine "AVAILABLE COMMANDS:" : + ( makeTermLine "Available commands:" : makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm)) ) TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TerminalLineEffect 0 (TmWdWdfromWdWd eff) : map makeTermLine followingLines @@ -156,9 +149,9 @@ doTerminalCommandEffect tce = case tce of argumentHelp :: TerminalCommand -> Terminal -> World -> (String, Maybe [String]) argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of - NoArguments{} -> ("ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED.", Nothing) + NoArguments{} -> ("Any arguments provided to this command are ignored.", Nothing) OneArgument argtype argm -> - ( "EXPECTS " ++ argtype ++ " AS ARGUMENT. AVAILABLE ARGUMENTS: " + ( "Expects " ++ argtype ++ " as argument. Available arguments: " , Just (M.keys argm) ) @@ -192,10 +185,10 @@ getDamageCoding = decodedtmap . _sensorCoding . _cwgParams . _cwGen . _cWorld sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine] sensorInfoMap tm w = M.fromList - [ ("REQUIREMENT", getSensor _proxRequirement tm w) - , ("DISTANCE", getSensor _proxDist tm w) - , ("CURRENTSTATUS", getSensor _proxStatus tm w) - , ("PASTSTATUS", getSensor _sensToggle tm w) + [ ("Requirement", getSensor _proxRequirement tm w) + , ("Distance", getSensor _proxDist tm w) + , ("Currentstatus", getSensor _proxStatus tm w) + , ("Paststatus", getSensor _sensToggle tm w) ] getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine] @@ -270,9 +263,11 @@ commandFutureLines s tm w = fromMaybe [errline "^ INVALID COMMAND"] $ do command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm) case doTerminalCommandEffect (_tcEffect command) tm w of NoArguments tls -> Just tls - OneArgument argtype m -> - Just $ - fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS " ++ argtype] $ + OneArgument argtype m -> + let setpartial = TerminalLineTerminalEffect 0 (TmTmSetPartialCommand (Just str)) + : makeTermPara ("expects " ++ argtype ++ " as an argument") + in Just $ + fromMaybe setpartial $ safeHead args >>= (m M.!?) where errline = makeColorTermLine red diff --git a/src/Dodge/TmTm.hs b/src/Dodge/TmTm.hs index c4a959cb4..44c753828 100644 --- a/src/Dodge/TmTm.hs +++ b/src/Dodge/TmTm.hs @@ -8,3 +8,4 @@ doTmTm tmtm = case tmtm of TmTmClearDisplayedLines -> tmDisplayedLines .~ [] TmTmSetStatus s -> tmStatus .~ s TmId -> id + TmTmSetPartialCommand ms -> tmPartialCommand .~ ms diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 21ab4b91c..86c9fb56a 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -227,7 +227,6 @@ scrollTimeForward w = case w ^? timeFlow . futureWorlds . _head of i <- w ^? timeFlow . scrollItemLocation return $ pointerToItemLocation (w ^?! cWorld . lWorld . itemLocations . ix i) . itUse . leftConsumption . wpCharge .~ ramount - -- | The update step. functionalUpdate :: Universe -> Universe functionalUpdate w = @@ -271,7 +270,7 @@ functionalUpdate w = . over uvWorld updateCreatureGroups . over uvWorld updateWallDamages . over uvWorld updateSeenWalls - . over uvWorld updateTerminal + . over uvWorld checkTermDist . over uvWorld updateRBList . over uvWorld updateCloseObjects . over uvWorld updateWheelEvents diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index f75767567..e1df50b7c 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -5,13 +5,7 @@ module Dodge.Update.Camera ( updateCamera, ) where -import Dodge.WASD -import Dodge.SmoothScroll -import SDL (MouseButton (..)) -import Dodge.Base.Coordinate -import Dodge.InputFocus import Bound -import Dodge.Viewpoints import Control.Monad import Data.Foldable import qualified Data.Map.Strict as M @@ -21,10 +15,15 @@ import Dodge.Creature.Test import Dodge.Data.Config import Dodge.Data.World import Dodge.Equipment +import Dodge.InputFocus +import Dodge.SmoothScroll +import Dodge.Viewpoints +import Dodge.WASD import Dodge.Zoning.Wall import Geometry import qualified IntMapHelp as IM import LensHelp +import SDL (MouseButton (..)) import qualified SDL {- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; @@ -35,12 +34,13 @@ updateCamera cfig w = case w ^. wCam . camControl of CamFloat -> updateFloatingCamera cfig w updateFloatingCamera :: Configuration -> World -> World -updateFloatingCamera cfig w = w - & updateBounds cfig - & wCam %~ setViewDistance cfig - & wCam %~ translateFloatingCamera theinput - & wCam %~ translateFloatingCameraKeys theinput - & wCam %~ zoomFloatingCamera theinput +updateFloatingCamera cfig w = + w + & updateBounds cfig + & wCam %~ setViewDistance cfig + & wCam %~ translateFloatingCamera theinput + & wCam %~ translateFloatingCameraKeys theinput + & wCam %~ zoomFloatingCamera theinput where theinput = w ^. input @@ -49,24 +49,25 @@ translateFloatingCamera theinput cam = fromMaybe cam $ do presstime <- theinput ^. mouseButtons . at ButtonLeft guard $ presstime > 0 hpos <- theinput ^? heldPos . ix ButtonLeft - let thetran = + let thetran = screenToWorldPos cam hpos - -.- - screenToWorldPos cam (theinput ^. mousePos) - return $ cam & camCenter +~ thetran - & camViewFrom +~ thetran + -.- screenToWorldPos cam (theinput ^. mousePos) + return $ + cam & camCenter +~ thetran + & camViewFrom +~ thetran translateFloatingCameraKeys :: Input -> Camera -> Camera -translateFloatingCameraKeys theinput = (camCenter -~ thetran) +translateFloatingCameraKeys theinput = + (camCenter -~ thetran) . (camViewFrom -~ thetran) where thetran = 10 *.* wasdDir theinput zoomFloatingCamera :: Input -> Camera -> Camera -zoomFloatingCamera theinput cam - | ButtonRight `M.member` (theinput ^. mouseButtons) = cam - & camZoom *~ (zoomSpeed ^^ negate (getSmoothScrollValue theinput)) - | otherwise = cam +zoomFloatingCamera theinput + | ButtonRight `M.member` (theinput ^. mouseButtons) = + camZoom *~ (zoomSpeed ^^ negate (getSmoothScrollValue theinput)) + | otherwise = id updateInGameCamera :: Configuration -> World -> World updateInGameCamera cfig w = @@ -100,8 +101,9 @@ moveZoomCamera cfig theinput cr campos = guard (SDL.ButtonRight `M.member` _mouseButtons theinput) mitm ^? _Just . itScope . scopePos newcen = cpos +.+ fromMaybe (V2 0 0) mscopeoffset +.+ offset - offset = rotateV (campos ^. camRot) - $ ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos theinput + offset = + rotateV (campos ^. camRot) $ + ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos theinput newzoom = case mitm ^? _Just . itScope of Just zs@ZoomScope{} -> _scopeZoom zs _ -> newDefaultZoom * newItemZoom @@ -123,7 +125,6 @@ moveZoomCamera cfig theinput cr campos = distFromEqmnt = foldl' max 1 $ IM.mapMaybe (_eeViewDist . _equipEffect . _itUse) $ getCrEquipment cr hw = halfWidth cfig hh = halfHeight cfig - -- = maybe clipZoom zoomFromItem (yourItem w ^? itZoom) wallZoom -- these speeds are inverted, larger means slower zoomInSpeed = 25 zoomOutSpeed = 15 @@ -135,8 +136,8 @@ updateScopeZoom w = fromMaybe w $ do updateScopeZoom' :: Int -> World -> World updateScopeZoom' i w - | SDL.ButtonRight `M.member` _mouseButtons (_input w) - = w & wppointer %~ doScopeZoom (w ^. input . smoothScrollAmount) mp + | SDL.ButtonRight `M.member` _mouseButtons (_input w) = + w & wppointer %~ doScopeZoom (w ^. input . smoothScrollAmount) mp | otherwise = w & wppointer %~ resetscope where wppointer = cWorld . lWorld . creatures . ix 0 . crInv . ix i . itScope @@ -152,7 +153,7 @@ doScopeZoom scrollamount mp sc = case scrollamount of | x > 0 -> zoomInLongGun mp sc | x < -10 -> (zoomOutLongGun . zoomOutLongGun . zoomOutLongGun) sc | x < -5 -> (zoomOutLongGun . zoomOutLongGun) sc - | x < 0 -> zoomOutLongGun sc + | x < 0 -> zoomOutLongGun sc | otherwise -> sc zoomSpeed :: Float @@ -160,17 +161,19 @@ zoomSpeed = 39 / 40 zoomInLongGun :: Point2 -> Scope -> Scope zoomInLongGun mousep sc = fromMaybe sc $ do - curzoom <- sc ^? scopeZoom + curzoom <- sc ^? scopeZoom guard $ curzoom < 8 - return $ sc & scopePos .+.+~ (1 - zoomSpeed)*zoomSpeed/curzoom *.* mousep - & scopeZoom %~ (/ zoomSpeed) + return $ + sc & scopePos .+.+~ (1 - zoomSpeed) * zoomSpeed / curzoom *.* mousep + & scopeZoom %~ (/ zoomSpeed) zoomOutLongGun :: Scope -> Scope zoomOutLongGun sc = fromMaybe sc $ do curzoom <- sc ^? scopeZoom guard $ curzoom > 0.5 - return $ sc & scopePos %~ (\p -> p +.+ (zoomSpeed - 1) / curzoom *.* p) - & scopeZoom *~ zoomSpeed + return $ + sc & scopePos %~ (\p -> p +.+ (zoomSpeed - 1) / curzoom *.* p) + & scopeZoom *~ zoomSpeed ifConfigWallRotate :: Configuration -> World -> World ifConfigWallRotate cfig w @@ -197,7 +200,6 @@ doWallRotate wl w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl) - (w ^. wC | b - b' < negate 0.01 = w & wCam . camRot -~ 0.01 | otherwise = w where - --b = a * (2 / pi) b = a * (4 / pi) b' = fromIntegral (round b :: Int) @@ -208,8 +210,9 @@ rotateCameraBy x w = & cWorld %~ rotateanyscope where rotateanyscope = fromMaybe id $ do - i <- w ^? cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . inInventory . ispItem - return $ lWorld . creatures . ix 0 . crInv . ix i + i <- w ^? cWorld . lWorld . creatures . ix 0 . crManipulation . manObject . inInventory . ispItem + return $ + lWorld . creatures . ix 0 . crInv . ix i . itScope . scopePos %~ rotateV x @@ -252,7 +255,6 @@ farWallDistDirection p w = findBoundDists :: Configuration -> World -> (Float, Float, Float, Float) findBoundDists cfig w | debugOn Bound_box_screen cfig = (hh, - hh, hw, - hw) --- | otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (w ^. cWorld . camPos . camCenter) w | otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (w ^. wCam . camViewFrom) w where hw = halfWidth cfig diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs index 1951949f5..6d0a078a7 100644 --- a/src/Dodge/WorldEffect.hs +++ b/src/Dodge/WorldEffect.hs @@ -1,4 +1,9 @@ -module Dodge.WorldEffect where +module Dodge.WorldEffect + ( doWdWd + , accessTerminal + , doTmWdWd + , lineOutputTerminal + ) where import Data.Foldable import qualified Data.Map.Strict as M @@ -63,17 +68,6 @@ torqueCr x cid w where (rot, g) = randomR (- x, x) $ _randGen w -doCommandInstant :: String -> Terminal -> World -> World -doCommandInstant arg tm w = doLineEffectsInstant tm w $ commandFutureLines arg tm w - --- doesn't do internal terminal effects -doLineEffectsInstant :: Terminal -> World -> [TerminalLine] -> World -doLineEffectsInstant tm = foldr f - where - f tl w = case tl of - TerminalLineEffect _ eff -> doTmWdWd eff tm w - _ -> w - lineOutputTerminal :: [TerminalLine] -> Terminal lineOutputTerminal tls = defaultTerminal @@ -81,7 +75,6 @@ lineOutputTerminal tls = , _tmFutureLines = [] , _tmMaxLines = 14 , _tmTitle = "TERMINAL" - , _tmInput = defaultTerminalInput , _tmScrollCommands = [quitCommand] , _tmWriteCommands = [helpCommand, commandsCommand] , _tmBootProgram = TerminalBootLines $ connectionBlurbLines tls