196 lines
6.3 KiB
Haskell
196 lines
6.3 KiB
Haskell
module Dodge.SelectionSections (
|
|
scrollSelectionSections,
|
|
nextInSectionSS,
|
|
ssLookupDown,
|
|
ssSetCursor,
|
|
selSecYint,
|
|
selSecSelSize,
|
|
inverseSelSecYint,
|
|
posSelSecYint,
|
|
inverseSelNumPos,
|
|
) where
|
|
|
|
import Dodge.Data.HUD
|
|
import Dodge.Data.CardinalPoint
|
|
import qualified Data.IntSet as IS
|
|
import Control.Applicative
|
|
import qualified Control.Foldl as L
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import Data.Foldable
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.ScreenPos
|
|
import Geometry.Data
|
|
|
|
scrollSelectionSections :: Int -> IMSS a -> Maybe Selection -> Maybe Selection
|
|
scrollSelectionSections yi sss msel
|
|
| yi == 0 = msel
|
|
| yi > 0 = foldl' (&) msel $ replicate yi (ssScrollUsing ssLookupUp sss)
|
|
| otherwise = foldl' (&) msel $ replicate (negate yi) (ssScrollUsing ssLookupDown sss)
|
|
|
|
nextInSectionSS :: IMSS a -> Maybe Selection -> Maybe Selection
|
|
nextInSectionSS = ssScrollUsing ssLookupNextMax
|
|
|
|
ssScrollUsing ::
|
|
(Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
IMSS a ->
|
|
Maybe Selection ->
|
|
Maybe Selection
|
|
ssScrollUsing g = ssScrollMinOnFail g . fmap (ssItems %~ IM.filter _siIsSelectable)
|
|
|
|
ssScrollMinOnFail ::
|
|
(Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
IMSS a ->
|
|
Maybe Selection ->
|
|
Maybe Selection
|
|
ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> Sel i j (q i j)) $ l <|> ssLookupMin sss
|
|
where
|
|
q i j = fromMaybe mempty $ do
|
|
Sel k _ xs <- msel ^? _Just
|
|
guard $ j `IS.member` xs && i == k
|
|
return xs
|
|
l = do
|
|
Sel i j _ <- msel
|
|
f i j sss
|
|
|
|
ssSetCursor ::
|
|
(IMSS a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
IMSS a ->
|
|
Maybe Selection ->
|
|
Maybe Selection
|
|
ssSetCursor f sss msel = fromMaybe msel $ do
|
|
(i, j, _) <- f sss
|
|
let newxs = fromMaybe mempty $ do
|
|
Sel k _ xs <- msel
|
|
guard $ k == i && j `IS.member` xs
|
|
return xs
|
|
return $ Just (Sel i j newxs)
|
|
|
|
ssLookupMax :: IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupMax sss = do
|
|
(i, _) <- IM.lookupMax sss
|
|
ssLookupLE' i sss
|
|
|
|
ssLookupUp :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupUp i j sss = case ssLookupLT i j sss of
|
|
Nothing -> ssLookupMax sss
|
|
x -> x
|
|
|
|
ssLookupDown :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupDown i j sss = case ssLookupGT i j sss of
|
|
Nothing -> ssLookupMin sss
|
|
x -> x
|
|
|
|
ssLookupNextMax :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupNextMax i j sss = case ssLookupGT i j sss of
|
|
Just x@(i',j',_) | i' == i && j' > j -> Just x
|
|
_ -> ssLookupMaxInSection i sss <|> ssLookupDown i j sss
|
|
|
|
ssLookupMaxInSection :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupMaxInSection i sss = do
|
|
ss <- sss ^? ix i . ssItems
|
|
(j,s) <- IM.lookupMax ss
|
|
return (i,j,s)
|
|
|
|
ssLookupLT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do
|
|
ss <- sss ^? ix i
|
|
(j', si) <- IM.lookupLT j (ss ^. ssItems)
|
|
return $ Just (i, j', si)
|
|
|
|
ssLookupLT' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupLT' i sss = do
|
|
(i', ss) <- IM.lookupLT i sss
|
|
case IM.lookupMax (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupLT' i' sss
|
|
|
|
ssLookupLE' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupLE' i sss = do
|
|
(i', ss) <- IM.lookupLE i sss
|
|
case IM.lookupMax (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupLT' i' sss
|
|
|
|
ssLookupMin :: IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupMin sss = do
|
|
(i, _) <- IM.lookupMin sss
|
|
ssLookupGE' i sss
|
|
|
|
ssLookupGT :: Int -> Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupGT i j sss = fromMaybe (ssLookupGT' i sss) $ do
|
|
ss <- sss ^? ix i
|
|
(j', si) <- IM.lookupGT j (ss ^. ssItems)
|
|
return $ Just (i, j', si)
|
|
|
|
ssLookupGT' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupGT' i sss = do
|
|
(i', ss) <- IM.lookupGT i sss
|
|
case IM.lookupMin (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupGT' i' sss
|
|
|
|
ssLookupGE' :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupGE' i sss = do
|
|
(i', ss) <- IM.lookupGE i sss
|
|
case IM.lookupMin (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupGT' i' sss
|
|
|
|
selSecSelSize :: Int -> Int -> IMSS a -> Maybe Int
|
|
selSecSelSize i j = (^? ix i . ssItems . ix j . siHeight)
|
|
|
|
-- need to check that the vertical gap is correctly put in here
|
|
posSelSecYint :: Config -> ListDisplayParams -> Float -> Int
|
|
posSelSecYint cfig ldp y = floor $ (y0 - y) / (20 / ldp ^. ldpScale + ldp ^. ldpVerticalGap)
|
|
where
|
|
V2 _ y0 = screenPosAbs cfig (ldp ^. ldpPos)
|
|
|
|
selSecYint :: Int -> Int -> IMSS a -> Maybe Int
|
|
selSecYint i j sss = do
|
|
ss <- sss ^? ix i
|
|
return . (secpos +)
|
|
. subtract (ss ^. ssOffset)
|
|
. sum
|
|
. fmap _siHeight
|
|
. fst
|
|
$ IM.split j (ss ^. ssItems)
|
|
where
|
|
secpos = sum . fmap _ssShownLength . fst $ IM.split i sss
|
|
|
|
inverseSelSecYint :: Int -> IMSS a -> XInfinity (Int, Int)
|
|
inverseSelSecYint yint sss
|
|
| yint < 0 = NegInf
|
|
| otherwise = fromMaybe PosInf $ do
|
|
((i, ss), othersss) <- IM.minViewWithKey sss
|
|
let l = _ssShownLength ss
|
|
if l <= yint
|
|
then return $ inverseSelSecYint (yint - l) othersss
|
|
else do
|
|
let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
|
|
(j,_) <- L.fold (L.find (\(_,x) -> x - _ssOffset ss > yint)) $ IM.toList ls
|
|
return $ NonInf (i, j)
|
|
|
|
inverseSelSecYintXPosCheck ::
|
|
Config ->
|
|
ListDisplayParams ->
|
|
Float ->
|
|
Int ->
|
|
IMSS a ->
|
|
Maybe (Int,Int)
|
|
inverseSelSecYintXPosCheck cfig ldp x yint sss = do
|
|
(i,j) <- inverseSelSecYint yint sss ^? nonInf
|
|
let V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos)
|
|
sindent <- sss ^? ix i . ssIndent
|
|
itindent <- sss ^? ix i . ssItems . ix j . siOffX
|
|
let x1 = x0 + _ldpScale ldp * 10 * (fromIntegral (sindent + itindent) - 0.5)
|
|
guard $ x - x1 < 160 && x > x1
|
|
return (i,j)
|
|
|
|
inverseSelNumPos :: Config -> ListDisplayParams -> Point2 -> IMSS a -> Maybe (Int, Int)
|
|
inverseSelNumPos cfig ldp (V2 x y) =
|
|
inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y)
|