222 lines
8.5 KiB
Haskell
222 lines
8.5 KiB
Haskell
--{-# LANGUAGE TupleSections #-}
|
|
module Dodge.Update.Scroll (
|
|
updateWheelEvent,
|
|
) where
|
|
|
|
import NewInt
|
|
import Control.Applicative
|
|
import qualified Data.ListTrie.Patricia.Map.Enum as PTE
|
|
import Dodge.Data.Terminal.Status
|
|
import Dodge.Data.EquipType
|
|
import Padding
|
|
import Control.Monad
|
|
import qualified Data.Map.Strict as M
|
|
import Data.Maybe
|
|
import Dodge.Base
|
|
import Dodge.Data.Universe
|
|
import Dodge.Inventory
|
|
import Dodge.SelectionSections
|
|
import Dodge.Terminal
|
|
import Geometry
|
|
import LensHelp
|
|
import SDL
|
|
|
|
-- yi should be nonzero
|
|
updateWheelEvent :: Int -> World -> World
|
|
updateWheelEvent yi w = case w ^. hud . subInventory of
|
|
NoSubInventory -> updateBaseWheelEvent yi w
|
|
ExamineInventory -> updateBaseWheelEvent yi w
|
|
MapperInventory{} -> updateBaseWheelEvent yi w
|
|
CombineInventory{} -> moveCombineSel yi w
|
|
DisplayTerminal tmid -> terminalWheelEvent yi tmid w
|
|
|
|
-- yi should be nonzero
|
|
updateBaseWheelEvent :: Int -> World -> World
|
|
updateBaseWheelEvent yi w
|
|
-- | Just True <- w ^? cWorld . lWorld . creatures . ix 0 . crInvLock = w
|
|
| Just True <- w ^? cWorld . lWorld . lInvLock = w
|
|
| bdown ButtonRight = case _rbOptions w of
|
|
EquipOptions{} -> w & rbOptions . opSel %~ scrollRBOption yi rbscrollmax
|
|
NoRightButtonOptions -> fromMaybe w (selectedItemScroll yi w)
|
|
| bdown ButtonLeft = w & wCam . camZoom +~ fromIntegral yi
|
|
| ScancodeCapsLock `M.member` _pressedKeys (_input w) = changeSwapSel yi w
|
|
| otherwise = scrollAugInvSel yi w
|
|
where
|
|
bdown b = w & has (input . mouseButtons . ix b)
|
|
rbscrollmax = fromMaybe 1 $ do
|
|
invid <- you w ^? crManipulation . manObject . imSelectedItem
|
|
esite <- you w ^? crInv . ix invid >>= \k -> w ^? cWorld . lWorld . items . ix k >>= equipType -- . itUse . uequipEffect . eeType
|
|
return . length $ eqSiteToPositions esite
|
|
|
|
selectedItemScroll :: Int -> World -> Maybe World
|
|
selectedItemScroll yi w = do
|
|
i <- you w ^? crManipulation . manObject . imSelectedItem
|
|
itm <- you w ^? crInv . ix i >>= \k -> w ^? cWorld . lWorld . items . ix k
|
|
return $ itemScroll yi itm w
|
|
|
|
itemScroll :: Int -> Item -> World -> World
|
|
itemScroll yi itm w
|
|
| Just xs <- itm ^? itUse . uaParams . apProjectiles = w
|
|
& itmlens . itUse . uaParams . apProjectiles .~ rotateList yi xs
|
|
| ATTACH ZOOMSCOPE <- itm ^. itType = updateScopeZoom (itm ^. itID) w
|
|
| HELD ALTERIFLE <- itm ^. itType
|
|
, yi /= 0 =
|
|
w
|
|
& itmlens . itParams . alteRifleSwitch
|
|
%~ ((`mod` 2) . (+ 1))
|
|
| isJust $ itm ^? itScroll . itsInt = w & itmlens . itScroll . itsInt +~ yi
|
|
| Just y <- itm ^? itScroll . itsMax = w & itmlens . itScroll . itsRangeInt
|
|
%~ ((`mod` y) . (+ yi))
|
|
| otherwise = w
|
|
where
|
|
--itmlens = cWorld . lWorld . creatures . ix 0 . crInv . ix invid
|
|
itmlens = cWorld . lWorld . items . ix (itm ^. itID . unNInt)
|
|
|
|
-- note that your _crInvLock does not apply to this TODO check that this is what
|
|
-- is wanted
|
|
updateScopeZoom :: NewInt ItmInt -> World -> World
|
|
updateScopeZoom itid w
|
|
| Just 0 <- w ^. input . mouseButtons . at SDL.ButtonRight =
|
|
w
|
|
& wppointer %~ resetscope
|
|
| Just _ <- w ^. input . mouseButtons . at SDL.ButtonRight =
|
|
w & wppointer %~ doScopeZoom (w ^. input . smoothScrollAmount) (w ^. input . mousePos)
|
|
| otherwise = w & wppointer %~ resetscope
|
|
where
|
|
wppointer = cWorld . lWorld . items . ix (_unNInt itid) . 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 . subInventory %~ doscroll
|
|
)
|
|
. (worldEventFlags . at CombineInventoryChange ?~ ())
|
|
where
|
|
doscroll ci = fromMaybe ci $ do
|
|
sss <- ci ^? ciSections
|
|
return $ ci & ciSelection %~ scrollSelectionSections yi sss
|
|
|
|
terminalWheelEvent :: Int -> Int -> World -> World
|
|
terminalWheelEvent yi tmid w
|
|
| w & has (input . mouseButtons . ix ButtonRight)
|
|
, Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
|
|
w & cWorld . lWorld . terminals . ix tmid %~ g
|
|
| Just TerminalTextInput{} <- w ^? cWorld . lWorld . terminals . ix tmid . tmStatus =
|
|
w & cWorld . lWorld . terminals . ix tmid %~ f
|
|
| otherwise = w
|
|
where
|
|
dowrap = if yi > 0 then wrapup else wrapdown
|
|
wrapup s coms = PTE.findSuccessor s coms <|> PTE.findMin coms
|
|
wrapdown s coms = PTE.findPredecessor s coms <|> PTE.findMax coms
|
|
f tm = fromMaybe tm $ do
|
|
let coms = getCommands w tm
|
|
x <- tm ^? tmStatus . tiText
|
|
let s = fromMaybe "" $ x ^? to words . ix 0
|
|
(s',_) <- dowrap s coms
|
|
return $ tm & tmStatus . tiText .~ s'
|
|
g tm = fromMaybe tm $ do
|
|
let coms = getCommands w tm
|
|
x <- tm ^? tmStatus . tiText
|
|
let s = fromMaybe "" $ x ^? to words . ix 0
|
|
y = fromMaybe "" $ x ^? to words . ix 1
|
|
-- (s',m) <- fmap (s,) (PTE.lookup s coms) <|> dowrap s coms
|
|
-- (arg,_) <- dowrap y m
|
|
(s',arg,_) <- if yi > 0 then doubleFindSucc s y coms <|> doubleFindMin coms
|
|
else doubleFindPred s y coms <|> doubleFindMax coms
|
|
return $ tm & tmStatus . tiText .~ s' ++ " " ++ arg
|
|
--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)
|
|
-- & tmStatus . tiText .~ comstr ++ arg
|
|
-- where
|
|
-- comstr = scrollCommandStrings w tm !! i
|
|
-- tc = scrollCommands tm !! i
|
|
-- arg = getArguments' tc tm w !! j
|
|
|
|
doubleFindMin :: (Enum a,Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
|
doubleFindMin m = do
|
|
(x,n) <- PTE.findMin m
|
|
case PTE.findMin n of
|
|
Just (y,z) -> Just (x,y,z)
|
|
Nothing -> Nothing
|
|
|
|
doubleFindSucc :: (Enum a,Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
|
doubleFindSucc xs ys m = case PTE.lookup xs m of
|
|
Just m' -> case PTE.findSuccessor ys m' of
|
|
Just (ys',z) -> Just (xs,ys',z)
|
|
Nothing -> dfs xs m
|
|
Nothing -> dfs xs m
|
|
where
|
|
dfs xs' m' = case PTE.findSuccessor xs' m' of
|
|
Just (xs'',n) -> case PTE.findMin n of
|
|
Just (ys',z) -> Just (xs'',ys',z)
|
|
Nothing -> dfs xs'' m'
|
|
Nothing -> Nothing
|
|
|
|
-- there are edge cases where this doesn't behave as might be expected
|
|
doubleFindMax :: (Enum a,Enum b) => PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
|
doubleFindMax m = do
|
|
(x,n) <- PTE.findMax m
|
|
case PTE.findMax n of
|
|
Just (y,z) -> Just (x,y,z)
|
|
Nothing -> Nothing
|
|
|
|
doubleFindPred :: (Enum a,Enum b) => [a] -> [b] -> PTE.TrieMap a (PTE.TrieMap b c) -> Maybe ([a],[b],c)
|
|
doubleFindPred xs ys m = case PTE.lookup xs m of
|
|
Just m' -> case PTE.findPredecessor ys m' of
|
|
Just (ys',z) -> Just (xs,ys',z)
|
|
Nothing -> dfs xs m
|
|
Nothing -> dfs xs m
|
|
where
|
|
dfs xs' m' = case PTE.findPredecessor xs' m' of
|
|
Just (xs'',n) -> case PTE.findMax n of
|
|
Just (ys',z) -> Just (xs'',ys',z)
|
|
Nothing -> dfs xs'' m'
|
|
Nothing -> Nothing
|
|
|
|
scrollRBOption :: Int -> Int -> Int -> Int
|
|
scrollRBOption dy ymax
|
|
| dy < 0 = min (ymax -1) . subtract dy
|
|
| dy > 0 = max 0 . subtract dy
|
|
| otherwise = id
|