156 lines
6.1 KiB
Haskell
156 lines
6.1 KiB
Haskell
module Dodge.Update.Scroll (
|
|
updateWheelEvent,
|
|
) where
|
|
|
|
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 -> w
|
|
| bdown ButtonLeft -> w & wCam . camZoom +~ y
|
|
| invKeyDown -> changeSwapSel yi $ w-- & hud . hudElement . diSelectionExtra .~ mempty
|
|
| otherwise -> scrollAugInvSel yi $ w-- & hud . hudElement . diSelectionExtra .~ mempty
|
|
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 . eeSite
|
|
return $ length $ equipSiteToPositions 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)
|
|
|
|
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
|