Simplify updating selection sections

2023-02-18 15:46:03 +00:00
parent 6eca3bab38
commit 41851ba24d
5 changed files with 230 additions and 87 deletions
@@ -0,0 +1,104 @@
+module Dodge.SelectionSections where
+
+import Data.Maybe
+import Control.Lens
+import qualified Data.IntMap.Strict as IM
+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
+
+firstPosSelectionSections :: SelectionSections a -> SelectionSections a
+firstPosSelectionSections sss = fromMaybe sss $ do
+    (i,j,si) <- ssLookupMin sss
+    return $ sss
+        & sssSelPos ?~ i
+        & sssSections . ix i . ssCursor ?~ SectionCursor j j (_siHeight si) (_siColor si)
+
+
+scrollUpSelectionSections :: SelectionSections a -> SelectionSections a
+scrollUpSelectionSections sss = fromMaybe (firstPosSelectionSections sss) $ do
+    i <- sss ^? sssSelPos . _Just
+    j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
+    (i',j',si) <- ssLookupUp i j sss
+    return $ sss & sssSelPos ?~ i'
+        & sssSections . ix i' . ssCursor ?~ SectionCursor j' j' (_siHeight si) (_siColor si)
+
+scrollDownSelectionSections :: SelectionSections a -> SelectionSections a
+scrollDownSelectionSections sss = fromMaybe (firstPosSelectionSections sss) $ do
+    i <- sss ^? sssSelPos . _Just
+    j <- sss ^? sssSections . ix i . ssCursor . _Just . scurSel
+    (i',j',si) <- ssLookupDown i j sss
+    return $ sss & sssSelPos ?~ i'
+        & 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
+        & 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