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

Cleanup

Browse Source
This commit is contained in:
justin
2023-05-01 22:35:33 +01:00
parent 7b8b8750a9
commit 61f88aeb4a
9 changed files with 120 additions and 121 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data/Terminal.hs
+3 -1
View File
@@ -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
src/Dodge/Default/Terminal.hs
+5 -3
View File
@@ -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
src/Dodge/Inventory.hs
+15 -10
View File
@@ -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
src/Dodge/Render/HUD.hs
+34 -34
View File
@@ -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)
src/Dodge/Terminal.hs
+16 -21
View File
@@ -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
src/Dodge/TmTm.hs
+1
View File
@@ -8,3 +8,4 @@ doTmTm tmtm = case tmtm of
TmTmClearDisplayedLines -> tmDisplayedLines .~ []
TmTmSetStatus s -> tmStatus .~ s
TmId -> id
TmTmSetPartialCommand ms -> tmPartialCommand .~ ms
src/Dodge/Update.hs
+1 -2
View File
@@ -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
src/Dodge/Update/Camera.hs
+39 -37
View File
@@ -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
src/Dodge/WorldEffect.hs
+6 -13
View File
@@ -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