141 lines
4.7 KiB
Haskell
141 lines
4.7 KiB
Haskell
module Dodge.SelectionSections (
|
|
scrollSelectionSections,
|
|
ssLookupDown,
|
|
ssLookupGT,
|
|
ssSetCursor,
|
|
setFirstPosSelectionSections,
|
|
selSecYint,
|
|
selSecSelSize,
|
|
) where
|
|
|
|
import Control.Applicative
|
|
import Control.Lens
|
|
import qualified Data.IntMap.Strict as IM
|
|
import Data.Maybe
|
|
import Dodge.Data.SelectionList
|
|
|
|
scrollSelectionSections :: Int -> SelectionSections a -> SelectionSections a
|
|
scrollSelectionSections yi sss
|
|
| yi == 0 = sss
|
|
| yi > 0 = foldr ($) sss $ replicate yi (ssScrollUsing ssLookupUp)
|
|
| otherwise = foldr ($) sss $ replicate (negate yi) (ssScrollUsing ssLookupDown)
|
|
|
|
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 ->
|
|
SelectionSections a
|
|
ssScrollUsing g sss =
|
|
sss & sssExtra . sssSelPos
|
|
.~ fmap f (ssScrollUsing' g (sss & sssSections %~ fmap (ssItems %~ IM.filter _siIsSelectable)))
|
|
where
|
|
f (i, j, _) = (i, j)
|
|
|
|
ssScrollUsing' ::
|
|
( Int ->
|
|
Int ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int, SelectionItem a)
|
|
) ->
|
|
SelectionSections a ->
|
|
Maybe (Int, Int, SelectionItem a)
|
|
ssScrollUsing' f sss = l <|> ssLookupMin sss
|
|
where
|
|
l = do
|
|
(i, j) <- sss ^? sssExtra . sssSelPos . _Just
|
|
f i j sss
|
|
|
|
ssSetCursor ::
|
|
(SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
SelectionSections a ->
|
|
SelectionSections a
|
|
ssSetCursor f sss = fromMaybe sss $ do
|
|
(i, j, _) <- f sss
|
|
return $
|
|
sss
|
|
& sssExtra . sssSelPos ?~ (i, j)
|
|
|
|
-- & sssSections . ix i . ssCursor ?~ SectionCursor j j (_siHeight si) (_siColor si)
|
|
|
|
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
|
|
|
|
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
|
|
|
|
--getIthPos :: Int -> IM.IntMap (SelectionItem a) -> Int
|
|
--getIthPos i sm = sum . fmap _siHeight . fst $ IM.split i sm
|