justin
cae02d8008
Zoom scrolling behaviour has slightly changed, I'm not sure how I want it to work yet though
216 lines
8.1 KiB
Haskell
216 lines
8.1 KiB
Haskell
module Dodge.Update.Scroll (
|
|
updateWheelEvent,
|
|
) where
|
|
|
|
import Control.Monad
|
|
import Geometry
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.Universe
|
|
--import Dodge.HeldScroll
|
|
import Dodge.Inventory
|
|
import Dodge.SelectionSections
|
|
--import Dodge.SoundLogic
|
|
import Dodge.Terminal
|
|
--import Dodge.Tweak
|
|
import qualified IntMapHelp as IM
|
|
import LensHelp
|
|
import SDL
|
|
|
|
updateWheelEvent :: Int -> World -> World
|
|
updateWheelEvent yi w = case w ^. hud . hudElement of
|
|
DisplayCarte
|
|
| bdown ButtonRight -> w & hud . carteZoom %~ min 0.75 . max 0.05 . ((1 + y * 0.1) *)
|
|
| otherwise -> w & cWorld . lWorld . selLocation %~ (`mod` numLocs) . (+ yi)
|
|
DisplayInventory{_subInventory = NoSubInventory{}}
|
|
-- functions that modify the inventory should be centralised so that
|
|
-- this lock can be sensibly applied, perhaps
|
|
| w ^?! cWorld . lWorld . creatures . ix 0 . crInvLock -> w
|
|
-- | rbDown -> case (yourScrollAttachment w, _rbOptions w) of
|
|
-- (_,EquipOptions{}) -> w & rbOptions . opSel %~ scrollRBOption yi rbscrollmax
|
|
-- (Nothing, _) -> w
|
|
-- (Just (invid,hs), _) -> doHeldScroll invid hs y w
|
|
| bdown ButtonRight -> case _rbOptions w of
|
|
EquipOptions{} -> w & rbOptions . opSel %~ scrollRBOption yi rbscrollmax
|
|
NoRightButtonOptions -> selectedItemScroll yi w
|
|
| bdown ButtonLeft -> w & wCam . camZoom +~ y
|
|
| invKeyDown -> changeSwapSel yi w
|
|
| otherwise -> scrollAugInvSel yi w
|
|
DisplayInventory{_subInventory = ExamineInventory}
|
|
| invKeyDown -> scrollAugInvSel yi w
|
|
| otherwise -> w
|
|
-- | invKeyDown && rbDown -> w & moveTweakSel yi
|
|
-- | invKeyDown -> scrollAugInvSel yi w
|
|
-- | rbDown -> w & changeTweakParam mi yi
|
|
-- | otherwise -> w & moveTweakSel yi
|
|
DisplayInventory{_subInventory = CombineInventory{}} -> w & moveCombineSel yi
|
|
DisplayInventory{_subInventory = DisplayTerminal tmid} -> terminalWheelEvent yi tmid w
|
|
_ -> w
|
|
where
|
|
rbscrollmax = fromMaybe 1 $ do
|
|
invid <- you w ^? crManipulation . manObject . imSelectedItem
|
|
esite <- you w ^? crInv . ix invid . itUse . uequipEffect . eeType
|
|
return $ length $ eqSiteToPositions esite
|
|
y = fromIntegral yi
|
|
numLocs = (fst . IM.findMax $ (w ^. cWorld . lWorld . seenLocations)) + 1
|
|
bdown b = b `M.member` _mouseButtons (_input w)
|
|
invKeyDown = ScancodeCapsLock `M.member` _pressedKeys (_input w)
|
|
|
|
selectedItemScroll :: Int -> World -> World
|
|
selectedItemScroll scrollamount w = fromMaybe w $ do
|
|
i <- you w ^? crManipulation . manObject . imSelectedItem
|
|
itm <- you w ^? crInv . ix i
|
|
return $ itemScroll scrollamount itm w
|
|
|
|
itemScroll :: Int -> Item -> World -> World
|
|
itemScroll yi itm w = case itm ^. itType of
|
|
ATTACH ZOOMSCOPE -> updateScopeZoom w
|
|
_ -> w
|
|
|
|
-- note that your _crInvLock does not apply to this TODO check that this is what
|
|
-- is wanted
|
|
updateScopeZoom :: World -> World
|
|
updateScopeZoom w = fromMaybe w $ do
|
|
i <- you w ^? crManipulation . manObject . imSelectedItem
|
|
return $ updateScopeZoom' i w
|
|
|
|
updateScopeZoom' :: Int -> World -> World
|
|
updateScopeZoom' i w
|
|
| SDL.ButtonRight `M.member` _mouseButtons (_input w) =
|
|
w & wppointer %~ doScopeZoom (w ^. input . smoothScrollAmount) (w ^. input . mousePos)
|
|
| otherwise = w & wppointer %~ resetscope
|
|
where
|
|
wppointer = cWorld . lWorld . creatures . ix 0 . crInv . ix i . itUse . uScope
|
|
resetscope (OpticScope _ _ defz) = OpticScope (V2 0 0) defz defz
|
|
|
|
doScopeZoom :: Int -> Point2 -> Scope -> Scope
|
|
doScopeZoom scrollamount mp sc = case scrollamount of
|
|
x
|
|
| x > 10 -> (zoomInLongGun mp . zoomInLongGun mp . zoomInLongGun mp) sc
|
|
| x > 5 -> (zoomInLongGun mp . zoomInLongGun mp) sc
|
|
| x > 0 -> zoomInLongGun mp sc
|
|
| x < -10 -> (zoomOutLongGun . zoomOutLongGun . zoomOutLongGun) sc
|
|
| x < -5 -> (zoomOutLongGun . zoomOutLongGun) sc
|
|
| x < 0 -> zoomOutLongGun sc
|
|
| otherwise -> sc
|
|
|
|
zoomSpeed :: Float
|
|
zoomSpeed = 39 / 40
|
|
|
|
zoomInLongGun :: Point2 -> Scope -> Scope
|
|
zoomInLongGun mousep sc = fromMaybe sc $ do
|
|
curzoom <- sc ^? opticZoom
|
|
guard $ curzoom < 8
|
|
return $
|
|
sc & opticPos .+.+~ (1 - zoomSpeed) * zoomSpeed / curzoom *.* mousep
|
|
& opticZoom %~ (/ zoomSpeed)
|
|
|
|
zoomOutLongGun :: Scope -> Scope
|
|
zoomOutLongGun sc = fromMaybe sc $ do
|
|
curzoom <- sc ^? opticZoom
|
|
guard $ curzoom > 0.5
|
|
return $
|
|
sc & opticPos %~ (\p -> p +.+ (zoomSpeed - 1) / curzoom *.* p)
|
|
& opticZoom *~ zoomSpeed
|
|
|
|
|
|
moveCombineSel :: Int -> World -> World
|
|
moveCombineSel yi =
|
|
( hud . hudElement . subInventory %~ doscroll
|
|
)
|
|
. (worldEventFlags . at CombineInventoryChange ?~ ())
|
|
where
|
|
doscroll ci = fromMaybe ci $ do
|
|
sss <- ci ^? ciSections
|
|
return $ ci & ciSelection %~ scrollSelectionSections yi sss
|
|
|
|
--moveSubSel :: Int -> Int -> World -> World
|
|
--moveSubSel yi maxyi =
|
|
-- hud . hudElement . subInventory . subInvMSel . _Just
|
|
-- %~ ((`mod` maxyi) . subtract yi)
|
|
|
|
guardDisconnectedID :: Int -> World -> World -> World
|
|
guardDisconnectedID tmid w w' = case w ^? cWorld . lWorld . terminals . ix tmid . tmStatus of
|
|
Just TerminalReady -> w'
|
|
_ -> w
|
|
|
|
terminalWheelEvent :: Int -> Int -> World -> World
|
|
terminalWheelEvent yi tmid w
|
|
| rbDown =
|
|
guardDisconnectedID tmid w $
|
|
w
|
|
& cWorld . lWorld . terminals . ix tmid %~ updatetermsubsel
|
|
| otherwise =
|
|
guardDisconnectedID tmid w $
|
|
w
|
|
& cWorld . lWorld . terminals . ix tmid %~ updatetermsel
|
|
where
|
|
rbDown = ButtonRight `M.member` _mouseButtons (_input w)
|
|
updatetermsel tm = case tm ^? tmInput . tiSel of
|
|
Nothing -> tm & tmInput . tiSel .~ (0, 0)
|
|
Just (i, _) ->
|
|
let newi = (i - yi) `mod` length (scrollCommandStrings w tm)
|
|
in tm & setInput newi 0
|
|
updatetermsubsel tm = case tm ^? tmInput . tiSel of
|
|
Nothing -> tm & tmInput . tiSel .~ (0, 0)
|
|
Just (i, j) ->
|
|
let newj = (j - yi) `mod` length (getArguments' (scrollCommands tm !! i) tm w)
|
|
in tm & setInput i newj
|
|
setInput i j tm =
|
|
tm
|
|
& tmInput . tiSel .~ (i, j)
|
|
& tmInput . tiText .~ (comstr ++ arg)
|
|
where
|
|
comstr = scrollCommandStrings w tm !! i
|
|
tc = scrollCommands tm !! i
|
|
arg = getArguments' tc tm w !! j
|
|
|
|
scrollRBOption :: Int -> Int -> Int -> Int
|
|
scrollRBOption dy ymax
|
|
| dy < 0 = min (ymax -1) . subtract dy
|
|
| dy > 0 = max 0 . subtract dy
|
|
| otherwise = id
|
|
|
|
--moveTweakSel :: Int -> World -> World
|
|
--moveTweakSel i w = case yourSelectedItem w ^? _Just . itTweaks . tweakParams of
|
|
-- Just l -> moveSubSel i (length l) w
|
|
-- _ -> w
|
|
|
|
--changeTweakParam :: Maybe Int -> Int -> World -> World
|
|
--changeTweakParam mi i w = fromMaybe w $ do
|
|
-- curpos <- you w ^? crManipulation . manObject . imSelectedItem
|
|
-- paramid <- mi
|
|
-- params <- yourSelectedItem w ^? _Just . itTweaks . tweakParams . ix paramid
|
|
-- let x = (_tweakVal params + i) `mod` _tweakMax params
|
|
-- return $
|
|
-- w & cWorld . lWorld . creatures . ix 0 . crInv . ix curpos
|
|
-- %~ ( (itTweaks . tweakParams . ix paramid . tweakVal .~ x)
|
|
-- . doTweak (_tweakType params) x
|
|
-- )
|
|
|
|
scrollCommands :: Terminal -> [TerminalCommand]
|
|
scrollCommands = (nullCommand :) . _tmScrollCommands
|
|
|
|
scrollCommandStrings :: World -> Terminal -> [String]
|
|
scrollCommandStrings w tm = case tm ^? tmPartialCommand . _Just of
|
|
Nothing -> map _tcString $ scrollCommands tm
|
|
Just tc -> "" : map tail (getArguments tc tm w)
|
|
|
|
getArguments' :: TerminalCommand -> Terminal -> World -> [String]
|
|
getArguments' tc tm = ("" :) . getArguments tc tm
|
|
|
|
nullCommand :: TerminalCommand
|
|
nullCommand =
|
|
TerminalCommand
|
|
{ _tcString = ""
|
|
, _tcAlias = []
|
|
, _tcHelp = ""
|
|
, _tcEffect = TerminalCommandEffectNone -- \_ _ -> NoArguments []
|
|
}
|
|
|
|
getArguments :: TerminalCommand -> Terminal -> World -> [String]
|
|
getArguments tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of
|
|
NoArguments{} -> []
|
|
OneArgument _ m -> map (' ' :) $ M.keys m
|