223 lines
7.4 KiB
Haskell
223 lines
7.4 KiB
Haskell
module Dodge.SelectionSections (
|
|
scrollSelectionSections,
|
|
ssLookupDown,
|
|
ssLookupGT,
|
|
ssSetCursor,
|
|
-- setFirstPosSelectionSections,
|
|
selSecYint,
|
|
selSecSelSize,
|
|
inverseSelSecYint,
|
|
posSelSecYint,
|
|
inverseSelNumPos,
|
|
inverseSelBoundaryUp,
|
|
inverseSelBoundaryDown,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import qualified Control.Foldl as L
|
|
import Control.Lens
|
|
import Control.Monad
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Dodge.Data.Config
|
|
import Dodge.Data.SelectionList
|
|
import Dodge.ScreenPos
|
|
import Geometry.Data
|
|
import Data.Foldable
|
|
|
|
scrollSelectionSections ::
|
|
Int ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int) ->
|
|
Maybe (Int, Int)
|
|
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)
|
|
|
|
--setFirstPosSelectionSections :: SelectionSections a -> SelectionSections a
|
|
--setFirstPosSelectionSections sss = fromMaybe sss $ do
|
|
-- (i, j, _) <- ssLookupMin sss
|
|
-- return $ sss & sssExtra . sssSelPos ?~ (i, j)
|
|
|
|
ssScrollUsing ::
|
|
(Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int) ->
|
|
Maybe (Int, Int)
|
|
ssScrollUsing g =
|
|
ssScrollMinOnFail
|
|
g
|
|
. (sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable))
|
|
|
|
ssScrollMinOnFail ::
|
|
(Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int) ->
|
|
Maybe (Int, Int)
|
|
ssScrollMinOnFail f sss msel = fmap (\(i, j, _) -> (i, j)) $ l <|> ssLookupMin sss
|
|
where
|
|
l = do
|
|
(i, j) <- msel
|
|
f i j sss
|
|
|
|
ssSetCursor ::
|
|
(SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int) ->
|
|
Maybe (Int, Int)
|
|
ssSetCursor f sss msel = fromMaybe msel $ do
|
|
(i, j, _) <- f sss
|
|
return $ Just (i, j)
|
|
|
|
ssLookupMax :: SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupMax sss = do
|
|
(i, _) <- IM.lookupMax (sss ^. sssSections)
|
|
ssLookupLE' i sss
|
|
|
|
ssLookupUp :: Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupUp i j sss = case ssLookupLT i j sss of
|
|
Nothing -> ssLookupMax sss
|
|
x -> x
|
|
|
|
ssLookupDown :: Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupDown i j sss = case ssLookupGT i j sss of
|
|
Nothing -> ssLookupMin sss
|
|
x -> x
|
|
|
|
ssLookupLT :: Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupLT i j sss = fromMaybe (ssLookupLT' i sss) $ do
|
|
ss <- sss ^? sssSections . ix i
|
|
(j', si) <- IM.lookupLT j (ss ^. ssItems)
|
|
return $ Just (i, j', si)
|
|
|
|
ssLookupLT' :: Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupLT' i sss = do
|
|
(i', ss) <- IM.lookupLT i (sss ^. sssSections)
|
|
case IM.lookupMax (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupLT' i' sss
|
|
|
|
ssLookupLE' :: Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupLE' i sss = do
|
|
(i', ss) <- IM.lookupLE i (sss ^. sssSections)
|
|
case IM.lookupMax (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupLT' i' sss
|
|
|
|
ssLookupMin :: SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupMin sss = do
|
|
(i, _) <- IM.lookupMin (sss ^. sssSections)
|
|
ssLookupGE' i sss
|
|
|
|
ssLookupGT :: Int -> Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupGT i j sss = fromMaybe (ssLookupGT' i sss) $ do
|
|
ss <- sss ^? sssSections . ix i
|
|
(j', si) <- IM.lookupGT j (ss ^. ssItems)
|
|
return $ Just (i, j', si)
|
|
|
|
ssLookupGT' :: Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupGT' i sss = do
|
|
(i', ss) <- IM.lookupGT i (sss ^. sssSections)
|
|
case IM.lookupMin (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupGT' i' sss
|
|
|
|
ssLookupGE' :: Int -> SelectionSections a -> Maybe (Int, Int, SelectionItem a)
|
|
ssLookupGE' i sss = do
|
|
(i', ss) <- IM.lookupGE i (sss ^. sssSections)
|
|
case IM.lookupMin (ss ^. ssItems) of
|
|
Just (j', si) -> return (i', j', si)
|
|
Nothing -> ssLookupGT' i' sss
|
|
|
|
selSecSelSize :: Int -> Int -> SelectionSections a -> Maybe Int
|
|
selSecSelSize i j sss = fmap length $ sss ^? sssSections . ix i . ssItems . ix j . siPictures
|
|
|
|
-- need to check that the vertical gap is correctly put in here
|
|
posSelSecYint :: Configuration -> 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 -> SelectionSections a -> Maybe Int
|
|
selSecYint i j sss = do
|
|
ss <- sss ^? sssSections . ix i
|
|
return . (secpos +)
|
|
. subtract (ss ^. ssOffset)
|
|
. sum
|
|
. fmap _siHeight
|
|
. fst
|
|
$ IM.split j (ss ^. ssItems)
|
|
where
|
|
secpos = sum . fmap (length . _ssShownItems) . fst $ IM.split i $ sss ^. sssSections
|
|
|
|
-- it is annoying that Control.Foldl doesn't seem to allow for scans to be done
|
|
-- at the same time as folds
|
|
inverseSelSecYint :: Int -> SelectionSections a -> Maybe (Int, Int)
|
|
inverseSelSecYint yint sss = do
|
|
((i, ss), othersss) <- IM.minViewWithKey (_sssSections sss)
|
|
let l = length $ _ssShownItems ss
|
|
if l <= yint
|
|
then inverseSelSecYint (yint - l) (sss & sssSections .~ othersss)
|
|
else do
|
|
let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
|
|
j <- L.fold (L.findIndex (\x -> x - _ssOffset ss > yint)) ls
|
|
return (i, j)
|
|
|
|
inverseSelSecYintXPosCheck ::
|
|
Configuration ->
|
|
ListDisplayParams ->
|
|
Float ->
|
|
Int ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int)
|
|
inverseSelSecYintXPosCheck cfig ldp x yint sss = do
|
|
((i, ss), othersss) <- IM.minViewWithKey (_sssSections sss)
|
|
let l = length $ _ssShownItems ss
|
|
V2 x0 _ = screenPosAbs cfig (ldp ^. ldpPos)
|
|
guard (x - x0 < 150) -- HACK, should determine selection item width and offset below
|
|
if l <= yint
|
|
then inverseSelSecYint (yint - l) (sss & sssSections .~ othersss)
|
|
else do
|
|
let ls = L.postscan (L.premap _siHeight L.sum) (_ssItems ss)
|
|
j <- L.fold (L.findIndex (\val -> val - _ssOffset ss > yint)) ls
|
|
return (i, j)
|
|
|
|
inverseSelNumPos ::
|
|
Configuration ->
|
|
ListDisplayParams ->
|
|
SelectionSections a ->
|
|
Point2 ->
|
|
Maybe (Int, Int)
|
|
inverseSelNumPos cfig ldp sss (V2 x y) =
|
|
inverseSelSecYintXPosCheck cfig ldp x (posSelSecYint cfig ldp y) sss
|
|
|
|
inverseSelBoundaryUp ::
|
|
Configuration ->
|
|
ListDisplayParams ->
|
|
SelectionSections a ->
|
|
Point2 ->
|
|
Maybe (Int, Int)
|
|
inverseSelBoundaryUp cfig ldp sss (V2 _ y) = do
|
|
sel <- inverseSelSecYint (posSelSecYint cfig ldp y) sss
|
|
let mselup = inverseSelSecYint (posSelSecYint cfig ldp y - 1) sss
|
|
if Just sel == mselup
|
|
then return $ sel & _2 +~ 1
|
|
else return sel
|
|
|
|
inverseSelBoundaryDown ::
|
|
Configuration ->
|
|
ListDisplayParams ->
|
|
SelectionSections a ->
|
|
Point2 ->
|
|
Maybe (Int, Int)
|
|
inverseSelBoundaryDown cfig ldp sss (V2 _ y) = do
|
|
sel <- inverseSelSecYint (posSelSecYint cfig ldp y) sss
|
|
let mseldown = inverseSelSecYint (posSelSecYint cfig ldp y + 1) sss
|
|
if Just sel == mseldown
|
|
then return $ sel & _2 -~ 1
|
|
else return sel
|
|
|
|
--getIthPos :: Int -> IM.IntMap (SelectionItem a) -> Int
|
|
--getIthPos i sm = sum . fmap _siHeight . fst $ IM.split i sm
|