263 lines
8.9 KiB
Haskell
263 lines
8.9 KiB
Haskell
module Dodge.SelectionSections (
|
|
scrollSelectionSections,
|
|
nextInSectionSS,
|
|
ssLookupDown,
|
|
ssSetCursor,
|
|
selSecYint,
|
|
selSecSelSize,
|
|
inverseSelSecYint,
|
|
posSelSecYint,
|
|
inverseSelNumPos,
|
|
inverseSelNumPosFixedWidth,
|
|
mouseInvPosFixWidth,
|
|
ssLookupGE,
|
|
ssLookupLE,
|
|
sssSelectionSlice,
|
|
ssScrollUsing,
|
|
ssLookupSecGTLoop,
|
|
ssLookupSecLTLoop,
|
|
) where
|
|
|
|
import Dodge.ListDisplayParams
|
|
import Dodge.Data.Universe
|
|
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.CardinalPoint
|
|
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) $ l <|> ssLookupMin sss
|
|
where
|
|
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
|
|
return $ Just (Sel i j)
|
|
|
|
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 (ssLookupSecLT i sss) $ do
|
|
ss <- sss ^? ix i
|
|
(j', si) <- IM.lookupLT j (ss ^. ssItems)
|
|
return $ Just (i, j', si)
|
|
|
|
ssLookupSecLTLoop :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupSecLTLoop i sss = ssLookupSecLT i sss <|> ssLookupMax sss
|
|
|
|
ssLookupSecLT :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupSecLT i sss = do
|
|
(i', ss) <- IM.lookupLT i sss
|
|
case IM.lookupMax (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupSecLT 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 -> ssLookupSecLT 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 (ssLookupSecGT i sss) $ do
|
|
ss <- sss ^? ix i
|
|
(j', si) <- IM.lookupGT j (ss ^. ssItems)
|
|
return $ Just (i, j', si)
|
|
|
|
ssLookupSecGT :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupSecGT i sss = do
|
|
(i', ss) <- IM.lookupGT i sss
|
|
case IM.lookupMin (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupSecGT i' sss
|
|
|
|
ssLookupSecGTLoop :: Int -> IMSS a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupSecGTLoop i sss = ssLookupSecGT i sss <|> ssLookupMin sss
|
|
|
|
ssLookupGE :: XInfinity (Int,Int) -> IMSS a -> Maybe (Int,Int,SelectionItem a)
|
|
ssLookupGE x sss = case x of
|
|
NegInf -> ssLookupMin sss
|
|
PosInf -> Nothing
|
|
NonInf (i,j) -> case sss ^? ix i . ssItems . ix j of
|
|
Nothing -> ssLookupGT i j sss
|
|
Just s -> Just (i,j,s)
|
|
|
|
ssLookupLE :: XInfinity (Int,Int) -> IMSS a -> Maybe (Int,Int,SelectionItem a)
|
|
ssLookupLE x sss = case x of
|
|
NegInf -> Nothing
|
|
PosInf -> ssLookupMax sss
|
|
NonInf (i,j) -> case sss ^? ix i . ssItems . ix j of
|
|
Nothing -> ssLookupLT i j sss
|
|
Just s -> Just (i,j,s)
|
|
|
|
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 -> ssLookupSecGT 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 -> LDParams -> 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 ^. ssYOffset)
|
|
. 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 - _ssYOffset ss > yint)) $ IM.toList ls
|
|
return $ NonInf (i, j)
|
|
|
|
inverseSelSecYintXPosCheck ::
|
|
Config -> LDParams -> Float -> Int -> IMSS a -> Maybe (XInfinity (Int, Int))
|
|
inverseSelSecYintXPosCheck cfig ldp x yint sss = do
|
|
let sel = inverseSelSecYint yint sss
|
|
(i,j) <- case sel of
|
|
NonInf v -> Just v
|
|
NegInf -> do
|
|
(i',j',_) <- ssLookupMin sss
|
|
return (i',j')
|
|
PosInf -> do
|
|
(i',j',_) <- ssLookupMax sss
|
|
return (i',j')
|
|
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 sel
|
|
|
|
inverseSelSecYintXPosCheckFixedWidth ::
|
|
Config -> LDParams -> Float -> Int -> IMSS a -> Maybe (XInfinity (Int, Int))
|
|
inverseSelSecYintXPosCheckFixedWidth cfig ldp x yint sss = do
|
|
let sel = inverseSelSecYint yint sss
|
|
(i,_) <- case sel of
|
|
NonInf v -> Just v
|
|
NegInf -> do
|
|
(i',j',_) <- ssLookupMin sss
|
|
return (i',j')
|
|
PosInf -> do
|
|
(i',j',_) <- ssLookupMax sss
|
|
return (i',j')
|
|
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)
|
|
let x1 = x0 + _ldpScale ldp * 10 * (fromIntegral (sindent) - 0.5)
|
|
guard $ x - x1 < 170 && x > x1
|
|
return sel
|
|
|
|
mouseInvPosFixWidth :: Universe -> Maybe (XInfinity (Int,Int))
|
|
mouseInvPosFixWidth u = inverseSelNumPosFixedWidth
|
|
(u^.uvConfig)
|
|
invDP
|
|
(u^.uvWorld. input . mousePos)
|
|
(u ^.uvWorld. hud . diSections)
|
|
|
|
|
|
inverseSelNumPos :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (XInfinity (Int, Int))
|
|
inverseSelNumPos cfig ldp (V2 x y) =
|
|
inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y)
|
|
|
|
inverseSelNumPosFixedWidth :: Config -> LDParams -> Point2 -> IMSS a -> Maybe (XInfinity (Int, Int))
|
|
inverseSelNumPosFixedWidth cfig ldp (V2 x y) =
|
|
inverseSelSecYintXPosCheckFixedWidth cfig ldp x (posSelSecYint cfig ldp y)
|
|
|
|
sssSelectionSlice :: IMSS a -> XInfinity (Int,Int) -> XInfinity (Int,Int) -> IMSS a
|
|
sssSelectionSlice sss x1 x2 = fromMaybe mempty $ do
|
|
let (xmin,xmax) | x1 < x2 = (x1,x2)
|
|
| otherwise = (x2,x1)
|
|
(mini,minj,_) <- ssLookupGE xmin sss
|
|
(maxi,maxj,_) <- ssLookupLE xmax sss
|
|
return $ fst (IM.split (maxi+1) . snd $ IM.split (mini-1) sss)
|
|
& ix mini . ssItems %~ snd . IM.split (minj-1)
|
|
& ix maxi . ssItems %~ fst . IM.split (maxj+1)
|
|
|