122 lines
4.4 KiB
Haskell
122 lines
4.4 KiB
Haskell
module Dodge.SelectionSections (
|
|
scrollSelectionSections,
|
|
ssLookupDown,
|
|
ssLookupGT,
|
|
ssSetCursor,
|
|
firstPosSelectionSections,
|
|
) where
|
|
|
|
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 scrollUpSelectionSections
|
|
| otherwise = foldr ($) sss $ replicate (negate yi) scrollDownSelectionSections
|
|
|
|
-- when is this used? it needs to correctly set the cursor
|
|
firstPosSelectionSections :: SelectionSections a -> SelectionSections a
|
|
firstPosSelectionSections sss = fromMaybe sss $ do
|
|
(i, j, si) <- ssLookupMin sss
|
|
return $
|
|
sss
|
|
& sssSelPos ?~ (i, j)
|
|
|
|
-- & sssSetCursor
|
|
-- & sssSections . ix i . ssCursor ?~ SectionCursor j j (_siHeight si) (_siColor si)
|
|
|
|
--sssSetCursor :: SelectionSections a -> SelectionSections a
|
|
--sssSetCursor sss = sss
|
|
|
|
scrollUpSelectionSections :: SelectionSections a -> SelectionSections a
|
|
scrollUpSelectionSections sss = fromMaybe (firstPosSelectionSections sss) $ do
|
|
(i, j) <- sss ^? sssSelPos . _Just
|
|
(i', j', si) <- ssLookupUp i j sss
|
|
return $ sss & sssSelPos ?~ (i', j')
|
|
|
|
-- & sssSections . ix i' . ssCursor ?~ SectionCursor j' j' (_siHeight si) (_siColor si)
|
|
|
|
scrollDownSelectionSections :: SelectionSections a -> SelectionSections a
|
|
scrollDownSelectionSections sss = fromMaybe (firstPosSelectionSections sss) $ do
|
|
(i, j) <- sss ^? sssSelPos . _Just
|
|
-- j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
|
|
(i', j', si) <- ssLookupDown i j sss
|
|
return $ sss & sssSelPos ?~ (i', j')
|
|
|
|
-- & sssSections . ix i' . ssCursor ?~ SectionCursor j' j' (_siHeight si) (_siColor si)
|
|
|
|
ssSetCursor ::
|
|
(SelectionSections a -> Maybe (Int, Int, SelectionItem a)) ->
|
|
SelectionSections a ->
|
|
SelectionSections a
|
|
ssSetCursor f sss = fromMaybe sss $ do
|
|
(i, j, si) <- f sss
|
|
return $
|
|
sss
|
|
& 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
|