hgeometry-combinatorial 0.10.0.0 → 0.11.0.0

raw patch · 28 files changed

+1312/−744 lines, 28 filesdep +hashabledep +primitivedep ~lineardep ~randomPVP ok

version bump matches the API change (PVP)

Dependencies added: hashable, primitive

Dependency ranges changed: linear, random

API changes (from Hackage documentation)

Files

• changelog.org +25/−0
• doctests.hs +4/−0
• hgeometry-combinatorial.cabal +32/−3
• src/Algorithms/BinarySearch.hs +91/−0
• src/Algorithms/DivideAndConquer.hs +22/−14
• src/Control/CanAquire.hs +79/−0
• src/Data/BalBST.hs +0/−378
• src/Data/BinaryTree.hs +4/−38
• src/Data/Ext.hs +5/−0
• src/Data/IndexedDoublyLinkedList.hs +206/−0
• src/Data/IndexedDoublyLinkedList/Bare.hs +188/−0
• src/Data/LSeq.hs +49/−11
• src/Data/List/Alternating.hs +86/−0
• src/Data/List/Set.hs +71/−0
• src/Data/List/Util.hs +77/−0
• src/Data/List/Zipper.hs +72/−0
• src/Data/Measured.hs +5/−0
• src/Data/Measured/Class.hs +11/−0
• src/Data/Measured/Size.hs +40/−0
• src/Data/PlanarGraph/Core.hs +15/−7
• src/Data/RealNumber/Rational.hs +68/−0
• src/Data/Sequence/Util.hs +2/−57
• src/Data/SlowSeq.hs +0/−205
• src/Data/Tree/Util.hs +57/−4
• src/Data/UnBounded.hs +43/−2
• src/Data/Util.hs +22/−23
• test/Data/IndexedDoublyLinkedListSpec.hs +36/−0
• test/Data/PlanarGraphSpec.hs +2/−2

@@ -0,0 +1,25 @@+#+STARTUP: showeverything++* Changelog++** 0.11++- Changed the implementation of Two and Three in Data.Util+  (hgeometry-combinatorial). Now they have proper Functor, Foldable,+  and Traversable instances.+- Added Data.RealNumber.Rational wrapping the Rational type giving+  some more readable show/read instances+- Added function to compute levels in a Rose-Tree+- Moved the binary searching functions from Data.Sequence.Util into+  Algorithms.BinarySearch, also added a version for fractional types+  that stops at a given threshold.+- Removed Data.BalBST and Data.SlowSeq+- Moved Measured from Data.BinaryTree into a separate module.++** 0.10++- More Instances++** 0.9++- First release in which hgeometry-combinatorial was split off from hgeometry.

@@ -63,4 +63,8 @@   , "Data.PlanarGraph.Core"   , "Data.Tree.Util"   , "Data.Set.Util"++  , "Data.List.Util"+  , "Data.List.Alternating"+  , "Data.List.Zipper"   ]

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                hgeometry-combinatorial-version:             0.10.0.0+version:             0.11.0.0 synopsis:            Data structures, and Data types. description:     The Non-geometric data types and algorithms used in HGeometry.@@ -42,6 +42,7 @@   exposed-modules:                     -- * Algorithmic Strategies                     Algorithms.DivideAndConquer+                    Algorithms.BinarySearch                      -- * Graph Algorithms                     Algorithms.Graph.DFS@@ -50,11 +51,22 @@                      Algorithms.StringSearch.KMP +                    -- * Numeric Data Types+                    Data.RealNumber.Rational++                    -- * Measurements+                    Data.Measured+                    Data.Measured.Class+                    Data.Measured.Size+                     -- * General Data Types                     Data.UnBounded                     Data.Intersection                     Data.Range+                     Data.Ext+                    -- Data.Ext.Multi+                     Data.LSeq                     Data.CircularSeq                     Data.Sequence.Util@@ -62,15 +74,23 @@                     Data.BinaryTree.Zipper                      Data.CircularList.Util-                    Data.BalBST                     Data.OrdSeq-                    Data.SlowSeq                     Data.Tree.Util                     Data.Util +                    Data.IndexedDoublyLinkedList+                    -- Data.IndexedDoublyLinkedList.Unboxed+                    Data.IndexedDoublyLinkedList.Bare+                     Data.DynamicOrd+                     Data.Set.Util +                    Data.List.Set+                    Data.List.Util+                    Data.List.Zipper+                    Data.List.Alternating+                     -- * Planar Graphs                     Data.Permutation                     Data.PlanarGraph@@ -83,7 +103,11 @@                      -- * Other                     System.Random.Shuffle+                     Control.Monad.State.Persistent++                    Control.CanAquire+                     Data.Yaml.Util    other-modules:@@ -103,9 +127,13 @@               , deepseq                 >= 1.1               , fingertree              >= 0.1               , MonadRandom             >= 0.5+              , random                  >= 1.1               , QuickCheck              >= 2.5               , quickcheck-instances    >= 0.3               , reflection              >= 2.1+              , primitive               >= 0.6.3.0+              , linear                  >= 1.20.8+              , hashable                >= 1.2                , vector                  >= 0.11               , data-clist              >= 0.1.2.3@@ -181,6 +209,7 @@                  Data.PlanarGraphSpec                  Data.OrdSeqSpec                  Data.CircularSeqSpec+                 Data.IndexedDoublyLinkedListSpec     build-depends:        base

@@ -0,0 +1,91 @@+module Algorithms.BinarySearch where++import Data.Sequence(Seq, ViewL(..),ViewR(..))+import qualified Data.Sequence as S+import qualified Data.Vector.Generic as V++--------------------------------------------------------------------------------++-- | Given a monotonic predicate p, a lower bound l, and an upper bound u, with:+--  p l = False+--  p u = True+--  l < u.+--+-- Get the index h such that everything strictly smaller than h has: p i =+-- False, and all i >= h, we have p h = True+--+-- running time: \(O(\log(u - l))\)+{-# SPECIALIZE binarySearch :: (Int -> Bool) -> Int -> Int -> Int #-}+{-# SPECIALIZE binarySearch :: (Word -> Bool) -> Word -> Word -> Word #-}+binarySearch   :: Integral a => (a -> Bool) -> a -> a -> a+binarySearch p = go+  where+    go l u = let d = u - l+                 m = l + (d `div` 2)+             in if d == 1 then u else if p m then go l m+                                             else go m u++-- | Given a value \(\varepsilon\), a monotone predicate \(p\), and two values \(l\) and+-- \(u\) with:+--+-- - \(p l\) = False+-- - \(p u\) = True+-- - \(l < u\)+--+-- we find a value \(h\) such that:+--+-- - \(p h\) = True+-- - \(p (h - \varepsilon)\) = False+--+-- >>> binarySearchUntil (0.1) (>= 0.5) 0 (1 :: Double)+-- 0.5+-- >>> binarySearchUntil (0.1) (>= 0.51) 0 (1 :: Double)+-- 0.5625+-- >>> binarySearchUntil (0.01) (>= 0.51) 0 (1 :: Double)+-- 0.515625+binarySearchUntil       :: (Fractional r, Ord r)+                        => r+                        -> (r -> Bool) -> r -> r -> r+binarySearchUntil eps p = go+  where+    go l u | u - l < eps = u+           | otherwise   = let m = (l + u) / 2+                           in if p m then go l m else go m u+++--------------------------------------------------------------------------------++-- | Given a monotonic predicate, Get the index h such that everything strictly+-- smaller than h has: p i = False, and all i >= h, we have p h = True+--+-- returns Nothing if no element satisfies p+--+-- running time: \(O(\log^2 n + T*\log n)\), where \(T\) is the time to execute the+-- predicate.+binarySearchSeq     :: (a -> Bool) -> Seq a -> Maybe Int+binarySearchSeq p s = case S.viewr s of+                       EmptyR                 -> Nothing+                       (_ :> x)   | p x       -> Just $ case S.viewl s of+                         (y :< _) | p y          -> 0+                         _                       -> binarySearch p' 0 u+                                  | otherwise -> Nothing+  where+    p' = p . S.index s+    u  = S.length s - 1++-- | Given a monotonic predicate, get the index h such that everything strictly+-- smaller than h has: p i = False, and all i >= h, we have p h = True+--+-- returns Nothing if no element satisfies p+--+-- running time: \(O(T*\log n)\), where \(T\) is the time to execute the+-- predicate.+binarySearchVec                             :: V.Vector v a+                                            => (a -> Bool) -> v a -> Maybe Int+binarySearchVec p' v | V.null v   = Nothing+                     | not $ p n' = Nothing+                     | otherwise  = Just $ if p 0 then 0+                                                  else binarySearch p 0 n'+  where+    n' = V.length v - 1+    p = p' . (v V.!)

@@ -7,32 +7,33 @@                                   , mergeSortedListsBy                                   ) where +import qualified Data.Foldable as F import           Data.List.NonEmpty (NonEmpty(..),(<|)) import qualified Data.List.NonEmpty as NonEmpty-+import           Data.Semigroup.Foldable  -- | Divide and conquer strategy ----- the running time is: O(n*L) + T(n) = 2T(n/2) + M(n)+-- the running time satifies T(n) = 2T(n/2) + M(n), ----- where M(n) is the time corresponding to the semigroup operation of s+-- where M(n) is the time corresponding to the semigroup operation of s on n elements. ---divideAndConquer1 :: Semigroup s => (a -> s) -> NonEmpty a -> s+--+divideAndConquer1 :: (Foldable1 f, Semigroup s) => (a -> s) -> f a -> s divideAndConquer1 = divideAndConquer1With (<>) ---- | Divide and conquer for-divideAndConquer   :: Monoid s => (a -> s) -> [a] -> s-divideAndConquer g = maybe mempty (divideAndConquer1 g) . NonEmpty.nonEmpty+-- | Divide and conquer strategy. See 'divideAndConquer1'.+divideAndConquer   :: (Foldable f, Monoid s) => (a -> s) -> f a -> s+divideAndConquer g = maybe mempty (divideAndConquer1 g) . NonEmpty.nonEmpty . F.toList  -- | Divide and conquer strategy ----- the running time is: O(n*L) + T(n) = 2T(n/2) + M(n)+-- the running time satifies T(n) = 2T(n/2) + M(n), ----- where M(n) is the time corresponding to the merge operation s+-- where M(n) is the time corresponding to the semigroup operation of s on n elements. ---divideAndConquer1With         :: (s -> s -> s) -> (a -> s) -> NonEmpty a -> s-divideAndConquer1With (<.>) g = repeatedly merge . fmap g+divideAndConquer1With         :: Foldable1 f => (s -> s -> s) -> (a -> s) -> f a -> s+divideAndConquer1With (<.>) g = repeatedly merge . fmap g . toNonEmpty   where     repeatedly _ (t :| []) = t     repeatedly f ts        = repeatedly f $ f ts@@ -45,21 +46,28 @@ -------------------------------------------------------------------------------- -- * Merging NonEmpties/Sorted lists +-- | Merges two sorted non-Empty lists in linear time. mergeSorted :: Ord a => NonEmpty a -> NonEmpty a -> NonEmpty a mergeSorted = mergeSortedBy compare +-- | Merges two sorted lists in linear time. mergeSortedLists :: Ord a => [a] -> [a] -> [a] mergeSortedLists = mergeSortedListsBy compare  -- | Given an ordering and two nonempty sequences ordered according to that--- ordering, merge them+-- ordering, merge them.+--+-- running time: \(O(n*T)\), where \(n\) is the length of the list,+-- and \(T\) the time required to compare two elements. mergeSortedBy           :: (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a -> NonEmpty a mergeSortedBy cmp ls rs = NonEmpty.fromList                         $ mergeSortedListsBy cmp (NonEmpty.toList ls) (NonEmpty.toList rs) - -- | Given an ordering and two nonempty sequences ordered according to that -- ordering, merge them+--+-- running time: \(O(n*T)\), where \(n\) is the length of the list,+-- and \(T\) the time required to compare two elements. mergeSortedListsBy     :: (a -> a -> Ordering) -> [a] -> [a] -> [a] mergeSortedListsBy cmp = go   where

@@ -0,0 +1,79 @@+{-# LANGUAGE FunctionalDependencies #-}+module Control.CanAquire(+      runAcquire+    , CanAquire(..)+    , HasIndex(..)++    , replaceByIndex, labelWithIndex+    , I+    ) where++import           Control.Monad.ST.Strict+import           Control.Monad.State.Strict+import           Data.Reflection+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++--------------------------------------------------------------------------------++-- | Run a computation on something that can aquire i's.+runAcquire         :: forall t a b. Traversable t+                   => (forall i. CanAquire i a => t i -> b)+                   -> t a -> b+runAcquire alg pts = reify v $ \px -> alg (coerceTS px ts)+  where+    (v,ts) = replaceByIndex pts++    coerceTS   :: proxy s -> t Int -> t (I s a)+    coerceTS _ = fmap I+      -- Ideally this would just be a coerce. But GHC doesn't want to do that.++class HasIndex i Int => CanAquire i a where+  -- | A value of type i can obtain something of type 'a'+  aquire  :: i -> a++class HasIndex t i | t -> i where+  -- | Types that have an instance of this class can act as indices.+  indexOf :: t -> i++--------------------------------------------------------------------------------++-- | Replaces every element by an index. Returns the new traversable+-- containing only these indices, as well as a vector with the+-- values. (such that indexing in this value gives the original+-- value).+replaceByIndex     :: forall t a. Traversable t => t a -> (V.Vector a, t Int)+replaceByIndex ts' = runST $ do+                               v <- MV.new n+                               t <- traverse (lbl v) ts+                               (,t) <$> V.unsafeFreeze v+  where+    (ts, n) = labelWithIndex ts'++    lbl         :: MV.MVector s' a -> (Int,a) -> ST s' Int+    lbl v (i,x) = MV.write v i x >> pure i++-- | Label each element with its index. Returns the new collection as+-- well as its size.+labelWithIndex :: Traversable t => t a -> (t (Int, a), Int)+labelWithIndex = flip runState 0 . traverse lbl+  where+    lbl   :: a -> State Int (Int,a)+    lbl x = do i <- get+               put $ i+1+               pure (i,x)+++--------------------------------------------------------------------------------++-- | A type that can act as an Index.+newtype I s a = I Int deriving (Eq, Ord, Enum)++instance Show (I s a) where+  showsPrec i (I j) = showsPrec i j++instance HasIndex (I s a) Int where+  indexOf (I i) = i++instance Reifies s (V.Vector a) => (I s a) `CanAquire` a where+  aquire (I i) = let v = reflect @s undefined in v V.! i

@@ -1,378 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module Data.BalBST where--import           Control.Applicative((<|>))-import           Data.Bifunctor-import           Data.Function (on)-import           Data.Functor.Contravariant-import qualified Data.List as L-import           Data.Maybe-import qualified Data.Tree as T-import           Prelude hiding (lookup,null)-------------------------------------------------------------------------------------- | Describes how to search in a tree-data TreeNavigator k a = Nav { goLeft     :: a -> k -> Bool-                             , extractKey :: a -> a -> k-                             }--instance Contravariant (TreeNavigator k) where-  contramap f (Nav gL eK) = Nav (\a k -> gL (f a) k) (\x y -> eK (f x) (f y))---ordNav :: Ord a => TreeNavigator a a-ordNav = Nav (<=) min---ordNavBy   :: Ord b => (a -> b) ->  TreeNavigator b a-ordNavBy f = Nav (\x k -> f x <= k) (min `on` f)----- instance Functor (TreeNavigator k) where---   fmap f Nav{..} = Nav (\b k -> )------ | A balanced binary search tree-data BalBST k a = BalBST { nav    :: !(TreeNavigator k a)-                         , toTree :: !(Tree k a)-                         }--instance (Show k, Show a) => Show (BalBST k a) where-  show (BalBST _ t) = "BalBST (" ++ show t ++ ")"---data Color = Red | Black deriving (Show,Read,Eq,Ord)--type Height = Int---- Red-Black tree with values in the leaves-data Tree k a = Empty-              | Leaf !a-              | Node !Color !Height (Tree k a) !k (Tree k a) deriving (Show,Eq)-------------------------------------------------------------------------------------- | Creates an empty BST-empty   :: TreeNavigator k a -> BalBST k a-empty n = BalBST n Empty----- | \(O(n\log n)\)-fromList :: TreeNavigator k a -> [a] -> BalBST k a-fromList n = foldr insert (empty n)--fromList' :: Ord a => [a] -> BalBST a a-fromList' = fromList ordNav----- -- | \(O(n)\)--- fromAscList :: TreeNavigator k a -> [a] -> BalBST k a--- fromAscList = undefined--------------------------------------------------------------------------------------- | Check if the tree is empty-null                  :: BalBST k a -> Bool-null (BalBST _ Empty) = True-null _                = False---- | Test if an element occurs in the BST.--- \(O(\log n)\)-lookup :: Eq a => a -> BalBST k a -> Maybe a-lookup x (BalBST Nav{..} t) = lookup' t-  where-    lookup' Empty            = Nothing-    lookup' (Leaf y)         = if x == y then Just y else Nothing-    lookup' (Node _ _ l k r)-      | goLeft x k           = lookup' l-      | otherwise            = lookup' r---- | \(O(\log n)\)-member   :: Eq a => a -> BalBST k a -> Bool-member x = isJust . lookup x---- | Search for the Predecessor--- \(O(\log n)\)-lookupLE :: Ord k => k -> BalBST k a -> Maybe a-lookupLE kx (BalBST n@Nav{..} t) = lookup' t-  where-    lookup' Empty            = Nothing-    lookup' (Leaf y)         = if goLeft y kx then Just y else Nothing-    lookup' (Node _ _ l k r)-      | kx <= k              = lookup' l-      | otherwise            = lookup' r <|> lookupMax (BalBST n l)----- | Insert an element in the BST.------ \(O(\log n)\)-insert :: a -> BalBST k a -> BalBST k a-insert x (BalBST n@Nav{..} t) = BalBST n (blacken $ insert' t)-  where-    insert' Empty    = Leaf x-    insert' (Leaf y) = let k     = extractKey x y-                           (l,r) = if goLeft x k then (x,y) else (y,x)-                       in red 2 (Leaf l) k (Leaf r)-    insert' (Node c h l k r)-      | goLeft  x k  = balance c h (insert' l) k r-      | otherwise    = balance c h l           k (insert' r)------ delete = undefined---- | Delete (one occurance of) an element.--- \(O(\log n)\)-delete                        :: Eq a => a -> BalBST k a -> BalBST k a-delete x t = let Split l _ r = split x t-                 n           = nav t-             in BalBST n $ joinWith n l r----- (BalBST n@Nav{..} t) = delete' t---   where---     delete' Empty      = Empty---     delete' l@(Leaf y) = if x == y then Empty else l---     delete' (Node c h l k r)---       | goLeft x k     =---------------------------------------------------------------------------------------- | Extract the minimum from the tree--- \(O(\log n)\)-minView              :: BalBST k a -> Maybe (a, Tree k a)-minView (BalBST n t) = minView' t-  where-    minView' Empty            = Nothing-    minView' (Leaf x)         = Just (x,Empty)-    minView' (Node _ _ l _ r) = fmap (flip (joinWith n) r) <$> minView' l--lookupMin :: BalBST k b -> Maybe b-lookupMin = fmap fst . maxView---- | Extract the maximum from the tree--- \(O(\log n)\)-maxView              :: BalBST k a -> Maybe (a, Tree k a)-maxView (BalBST n t) = maxView' t-  where-    maxView' Empty            = Nothing-    maxView' (Leaf x)         = Just (x,Empty)-    maxView' (Node _ _ l _ r) = fmap (joinWith n l) <$> maxView' r--lookupMax :: BalBST k b -> Maybe b-lookupMax = fmap fst . maxView----- | Joins two BSTs. Assumes that the ranges are disjoint. It takes the left Tree nav------ \(O(\log n)\)-join                           :: BalBST k a -> BalBST k a -> BalBST k a-join (BalBST n l) (BalBST _ r) = BalBST n $ joinWith n l r---- | Joins two BSTs' with a specific Tree Navigator------ \(O(\log n)\)-joinWith               :: TreeNavigator k a -> Tree k a -> Tree k a -> Tree k a-joinWith Nav{..} tl tr-    | lh >= rh         = blacken $ joinL tl tr-    | otherwise        = blacken $ joinR tl tr-  where-    rh = height tr-    lh = height tl--    joinL Empty      _           = Empty-    joinL l          Empty       = l-    joinL l@(Leaf x) r@(Leaf y)  = red 2 l (extractKey x y) r-    joinL l@(Node c h ll k lr) r-      | h == rh                  = let lm = unsafeMax lr-                                       rm = unsafeMin r-                                   in balance Red (h+1) l (extractKey lm rm) r-      | otherwise                = balance c h ll k (joinL lr r)-        -- lh >= rh-    joinL _ _ = error "joinL. absurd"---    joinR _          Empty       = Empty-    joinR Empty      r           = r--    joinR l@(Leaf x) r@(Leaf y)  = red 2 l (extractKey x y) r-    joinR l r@(Node c h rl k rr)-      | h == lh                  = let lm = unsafeMax l-                                       rm = unsafeMin rl-                                   in balance Red (h+1) l (extractKey lm rm) r-      | otherwise                = balance c h (joinR l rl) k rr-        -- lh >= rh-    joinR _ _ = error "joinR absurd"-------------------------------------------------------------------------------------- | Splitting and extracting---- | A pair that is strict in its first argument and lazy in the second.-data Pair a b = Pair { fst' :: !a-                     , snd' :: b-                     } deriving (Show,Eq,Functor,Foldable,Traversable)---collect        :: b -> [Pair a b] -> Pair [a] b-collect def [] = Pair [] def-collect _   xs = Pair (map fst' xs) (snd' $ last xs)----- | Extract a prefix from the tree, i.e. a repeated 'minView'------ \(O(\log n +k)\), where \(k\) is the size of the extracted part-extractPrefix                      :: BalBST k a -> [Pair a (Tree k a)]-extractPrefix (BalBST n@Nav{..} t) = extractPrefix' t-  where-    extractPrefix' Empty            = []-    extractPrefix' (Leaf x)         = [Pair x Empty]-    extractPrefix' (Node _ _ l _ r) = ls ++ extractPrefix' r-      where-        ls = map (fmap $ flip (joinWith n) r) $ extractPrefix' l---- | Extract a suffix from the tree, i.e. a repeated 'minView'------ \(O(\log n +k)\), where \(k\) is the size of the extracted part-extractSuffix                      :: BalBST k a -> [Pair a (Tree k a)]-extractSuffix (BalBST n@Nav{..} t) = extract t-  where-    extract Empty            = []-    extract (Leaf x)         = [Pair x Empty]-    extract (Node _ _ l _ r) = rs ++ extract l-      where-        rs = map (fmap $ joinWith n l) $ extract r---- | Result of splititng a tree-data Split a b = Split a !b a deriving (Show,Eq)---- | Splits the tree at x. Note that if x occurs more often, no guarantees are--- given which one is found.------ \(O(\log n)\)-split                        :: Eq a => a -> BalBST k a -> Split (Tree k a) (Maybe a)-split x (BalBST n@Nav{..} t) = split' t-  where-    split' Empty                  = Split Empty Nothing Empty-    split' l@(Leaf y)-      | x == y                    = Split Empty (Just y) Empty-      | goLeft x (extractKey x y) = Split l     Nothing  Empty-      | otherwise                 = Split Empty Nothing  l-    split' (Node _ _ l k r)-      | goLeft x k                = let Split l' mx r' = split' l-                                    in Split l' mx (joinWith n r' r)-      | otherwise                 = let Split l' mx r' = split' r-                                    in Split (joinWith n l l') mx r'---- | split based on a monotonic predicate------ \(O(\log n)\)-splitMonotone                        :: (a -> Bool) -> BalBST k a-                                     -> (BalBST k a, BalBST k a)-splitMonotone p (BalBST n@Nav{..} t) = bimap (BalBST n) (BalBST n) $ split' t-  where-    split' Empty        = (Empty,Empty)-    split' l@(Leaf y)-      | p y             = (Empty,l)-      | otherwise       = (l,Empty)-    split' (Node _ _ l _ r)-      | p (unsafeMin r) = let (l',m) = split' l in (l',joinWith n m r)-      | otherwise       = let (m,r') = split' r in (joinWith n l m, r')----- | Splits at a given monotone predicate p, and then selects everything that--- satisfies the predicate sel.-splitExtract           :: (a -> Bool) -> (a -> Bool) -> BalBST k a-                       -> Split (BalBST k a) ([a],[a])-splitExtract p sel bst = Split (BalBST n before) (reverse mid1,mid2) (BalBST n after)-  where-    n                = nav bst-    (before',after') = splitMonotone p bst--    extract def = collect def . L.takeWhile (sel . fst')--    Pair mid1 before = extract (toTree before') $ extractSuffix before'-    Pair mid2 after  = extract (toTree after')  $ extractPrefix after'--------------------------------------------------------------------------------------data T k a = Internal !Color !Height !k | Val !a deriving (Show,Eq,Ord)--toRoseTree :: Tree k a -> Maybe (T.Tree (T k a))-toRoseTree Empty            = Nothing-toRoseTree (Leaf x)         = Just $ T.Node (Val x) []-toRoseTree (Node c h l k r) = Just $ T.Node (Internal c h k) (mapMaybe toRoseTree [l,r])---showTree :: (Show k, Show a) => BalBST k a -> String-showTree = maybe "Empty" T.drawTree . fmap (fmap show) . toRoseTree . toTree---- | Get the minimum in the tree. Errors when the tree is empty------ \(O(\log n)\)-unsafeMin                  :: Tree k a -> a-unsafeMin (Leaf x)         = x-unsafeMin (Node _ _ l _ _) = unsafeMin l-unsafeMin _                = error "unsafeMin: Empty"---- | Get the maximum in the tree. Errors when the tree is empty------ \(O(\log n)\)-unsafeMax                  :: Tree k a -> a-unsafeMax (Leaf x)         = x-unsafeMax (Node _ _ _ _ r) = unsafeMax r-unsafeMax _                = error "unsafeMax: Empty"---- | Extract all elements in the tree------ \(O(n)\)-toList :: BalBST k a -> [a]-toList = toList' . toTree---- | Extract all elements in the tree------ \(O(n)\)-toList'                  :: Tree k a -> [a]-toList' Empty            = []-toList' (Leaf x)         = [x]-toList' (Node _ _ l _ r) = toList' l ++ toList' r-------------------------------------------------------------------------------------- * Helper stuff--black :: Height -> Tree k a -> k -> Tree k a -> Tree k a-black = Node Black--red :: Height -> Tree k a -> k -> Tree k a -> Tree k a-red = Node Red---blacken                    :: Tree k a -> Tree k a-blacken (Node Red h l k r) = Node Black h l k r-blacken t                  = t---- | rebalance the tree-balance  :: Color -> Height -> Tree k a -> k -> Tree k a -> Tree k a-balance Black h (Node Red _ (Node Red _ a x b) y c) z d = mkNode h a x b y c z d-balance Black h (Node Red _ a x (Node Red _ b y c)) z d = mkNode h a x b y c z d-balance Black h a x (Node Red _ (Node Red _ b y c) z d) = mkNode h a x b y c z d-balance Black h a x (Node Red _ b y (Node Red _ c z d)) = mkNode h a x b y c z d-balance co h a x b                                      = Node co h a x b--mkNode                 :: Height-                       -> Tree k a -> k -> Tree k a -> k -> Tree k a  -> k -> Tree k a-                       -> Tree k a-mkNode h a x b y c z d = red h (black h a x b) y (black h c z d)--height                  :: Tree k a -> Height-height Empty            = 0-height (Leaf _)         = 1-height (Node _ h _ _ _) = h

@@ -1,5 +1,4 @@ {-# Language DeriveFunctor#-}-{-# Language FunctionalDependencies #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.BinaryTree@@ -17,12 +16,14 @@ import           Data.Bifunctor.Apply import           Data.List.NonEmpty (NonEmpty) import           Data.Maybe (mapMaybe)+import           Data.Measured.Class+import           Data.Measured.Size import           Data.Semigroup.Foldable import qualified Data.Tree as Tree+import           Data.Tree.Util (TreeNode(..)) import qualified Data.Vector as V import           GHC.Generics (Generic) import           Test.QuickCheck- --------------------------------------------------------------------------------  -- | Binary tree that stores its values (of type a) in the leaves. Internal@@ -33,9 +34,6 @@  instance (NFData v, NFData a) => NFData (BinLeafTree v a) -class Semigroup v => Measured v a | a -> v where-  measure :: a -> v- -- | smart constructor node     :: Measured v a => BinLeafTree v a -> BinLeafTree v a -> BinLeafTree v a node l r = Node l (measure l <> measure r) r@@ -116,50 +114,18 @@ zipExactWith _ _ _            _               =     error "zipExactWith: tree structures not the same " -newtype Size = Size Int deriving (Show,Read,Eq,Num,Integral,Enum,Real,Ord,Generic,NFData) -instance Semigroup Size where-  x <> y = x + y -instance Monoid Size where-  mempty = Size 0-  mappend = (<>)--newtype Elem a = Elem { _unElem :: a }-               deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable)--instance Measured Size (Elem a) where-  measure _ = 1---data Sized a = Sized !Size a-             deriving (Show,Eq,Ord,Functor,Foldable,Traversable,Generic)-instance NFData a => NFData (Sized a)--instance Semigroup a => Semigroup (Sized a) where-  (Sized i a) <> (Sized j b) = Sized (i <> j) (a <> b)--instance Monoid a => Monoid (Sized a) where-  mempty = Sized mempty mempty-  (Sized i a) `mappend` (Sized j b) = Sized (i <> j) (a `mappend` b)---- instance Semigroup a => Measured Size (Sized a) where---   measure (Sized i _) = i-- -------------------------------------------------------------------------------- -- * Converting into a Data.Tree -data RoseElem v a = InternalNode v | LeafNode a deriving (Show,Eq,Functor)--toRoseTree              :: BinLeafTree v a -> Tree.Tree (RoseElem v a)+toRoseTree              :: BinLeafTree v a -> Tree.Tree (TreeNode v a) toRoseTree (Leaf x)     = Tree.Node (LeafNode x) [] toRoseTree (Node l v r) = Tree.Node (InternalNode v) (map toRoseTree [l,r])   drawTree :: (Show v, Show a) => BinLeafTree v a -> String drawTree = Tree.drawTree . fmap show . toRoseTree-  -------------------------------------------------------------------------------- -- * Internal Node Tree

@@ -76,15 +76,20 @@  _core :: (core :+ extra) -> core _core (c :+ _) = c+{-# INLINABLE _core #-}  _extra :: (core :+ extra) -> extra _extra (_ :+ e) = e+{-# INLINABLE _extra #-}  core :: Lens (core :+ extra) (core' :+ extra) core core' core = lens _core (\(_ :+ e) c -> (c :+ e))+{-# INLINABLE core #-}  extra :: Lens (core :+ extra) (core :+ extra') extra extra' extra = lens _extra (\(c :+ _) e -> (c :+ e))+{-# INLINABLE extra #-}  ext   :: a -> a :+ () ext x = x :+ ()+{-# INLINABLE ext #-}

@@ -0,0 +1,206 @@+module Data.IndexedDoublyLinkedList( DLList(..)+                                   , Cell(..), emptyCell+                                   , DLListMonad, runDLListMonad+                                   , Index++                                   , singletons+                                   , writeList+                                   , valueAt, getNext, getPrev+                                   , toListFrom, toListFromR, toListContains+                                   , toListFromK, toListFromRK+                                   , insertAfter, insertBefore+                                   , delete+                                   , dump+                                   ) where++import           Control.Monad.Primitive (PrimMonad(..))+import           Control.Monad.Reader (ReaderT, runReaderT)+import           Control.Monad.Reader.Class+import           Control.Monad.ST+import           Data.Foldable (forM_)+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Util+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++--------------------------------------------------------------------------------++type Index = Int++-- TODO: Switch to unobxed sums for these!++-- | Cells in the Linked List+data Cell = Cell { prev :: Maybe Index+                 , next :: Maybe Index+                 } deriving (Show,Eq)++emptyCell :: Cell+emptyCell = Cell Nothing Nothing++-- | Doubly linked list implemented by a mutable vector. So actually+-- this data type can represent a collection of Linked Lists that can+-- efficiently be concatenated and split.+--+-- Supports O(1) indexing, and O(1) insertions, deletions+data DLList s a = DLList { values :: !(V.Vector a)+                         , llist  :: !(MV.MVector s Cell)+                         }++instance Functor (DLList s) where+  fmap f (DLList v l) = DLList (fmap f v) l+++--------------------------------------------------------------------------------++-- | Monad in which we can use the IndexedDoublyLinkedList.+newtype DLListMonad s b a = DLListMonad { runDLListMonad' :: ReaderT (DLList s b) (ST s) a }+                         deriving (Functor,Applicative,Monad)++instance PrimMonad (DLListMonad s b) where+  type PrimState (DLListMonad s b) = s+  primitive = DLListMonad . primitive++instance MonadReader (DLList s b) (DLListMonad s b) where+  local f = DLListMonad . local f . runDLListMonad'+  ask = DLListMonad $ ask++-- | Runs a DLList Computation, starting with singleton values, crated+-- from the input vector.+runDLListMonad         :: V.Vector b -> (forall s. DLListMonad s b a) -> a+runDLListMonad vs comp = runST $ singletons vs >>= runReaderT (runDLListMonad' comp)++----------------------------------------++-- | Constructs a new DoublyLinkedList. Every element is its own singleton list+singletons    :: (PrimMonad m, s ~ PrimState m) => V.Vector b -> m (DLList s b)+singletons vs = DLList vs <$> MV.replicate (V.length vs) emptyCell++-- | Sets the DoublyLinkedList to the given List.+--+-- Indices that do not occur in the list are not touched.+writeList   :: NonEmpty Index -> DLListMonad s b ()+writeList h = do v <- asks llist+                 forM_ (withNeighs h) $ \(STR p i s) ->+                   modify v i $ \c -> c { prev = p , next = s }+  where+    withNeighs (x:|xs) = let l = x:xs+                         in zipWith3 STR (Nothing : map Just l) l (map Just xs ++ [Nothing])++----------------------------------------+-- * Queries++-- | Gets the value at Index i+valueAt    :: Index -> DLListMonad s b b+valueAt  i = asks ((V.! i) . values)++-- | Next element in the List+getNext   :: Index -> DLListMonad s b (Maybe Index)+getNext i = do v <- asks llist+               next <$> MV.read v i++-- | Previous Element in the List+getPrev   :: Index -> DLListMonad s b (Maybe Index)+getPrev i = do v <- asks llist+               prev <$> MV.read v i++-- | Computes a maximal length list starting from the Given index+--+-- running time: \(O(k)\), where \(k\) is the length of the output list+toListFrom   :: Index -> DLListMonad s b (NonEmpty Index)+toListFrom i = (i :|) <$> iterateM getNext i++-- | Takes the current element and its k next's+toListFromK     :: Index -> Int -> DLListMonad s b (NonEmpty Index)+toListFromK i k = (i :|) <$> replicateM k getNext i++-- | Computes a maximal length list by walking backwards in the+-- DoublyLinkedList, starting from the Given index+--+-- running time: \(O(k)\), where \(k\) is the length of the output list+toListFromR :: Index -> DLListMonad s b (NonEmpty Index)+toListFromR i = (i :|) <$> iterateM getPrev i++toListFromRK     :: Index -> Int -> DLListMonad s b (NonEmpty Index)+toListFromRK i k = (i :|) <$> replicateM k getPrev i++-- | Computes a maximal length list that contains the element i.+--+-- running time: \(O(k)\), where \(k\) is the length of the output+-- list+toListContains   :: Index -> DLListMonad s b (NonEmpty Index)+toListContains i = f <$> toListFromR i <*> toListFrom i+  where+    f l r = NonEmpty.fromList $ reverse (NonEmpty.toList l) <> NonEmpty.tail r+++----------------------------------------+-- * Updates++-- | Inserts the second argument after the first one into the linked list+insertAfter     :: Index -> Index -> DLListMonad s b ()+insertAfter i j = do v  <- asks llist+                     mr <- getNext i+                     modify  v i  $ \c -> c { next = Just j }+                     modify  v j  $ \c -> c { prev = Just i , next = mr }+                     mModify v mr $ \c -> c { prev = Just j }++-- | Inserts the second argument before the first one into the linked list+insertBefore     :: Index -> Index -> DLListMonad s b ()+insertBefore i h = do v <- asks llist+                      ml <- getPrev i+                      mModify v ml $ \c -> c { next = Just h }+                      modify  v h  $ \c -> c { prev = ml , next = Just i }+                      modify  v i  $ \c -> c { prev = Just h }++-- | Deletes the element from the linked list. This element thus+-- essentially becomes a singleton list. Returns the pair of indices+-- that now have become neighbours (i.e. the predecessor and successor+-- of j just before we deleted j).+delete   :: Index -> DLListMonad s b (Maybe Index, Maybe Index)+delete j = do v <- asks llist+              ml <- getPrev j+              mr <- getNext j+              modify  v j  $ \c -> c { prev = Nothing, next = Nothing }+              mModify v ml $ \c -> c { next = mr }+              mModify v mr $ \c -> c { prev = ml }+              pure (ml,mr)+++++----------------------------------------+-- * Helper functions++-- | Applies the action at most n times.+replicateM     :: Monad m => Int -> (a -> m (Maybe a)) -> a -> m [a]+replicateM n f = go n+  where+    go 0 _ = pure []+    go k x = f x >>= \case+               Nothing -> pure []+               Just y  -> (y:) <$> go (k-1) y++iterateM  :: Monad m => (a -> m (Maybe a)) -> a -> m [a]+iterateM f = go+  where+    go x = f x >>= \case+             Nothing -> pure []+             Just y  -> (y:) <$> go y++mModify   :: PrimMonad m => MV.MVector (PrimState m) a -> Maybe Int -> (a -> a) -> m ()+mModify v mi f = case mi of+                   Nothing -> pure ()+                   Just i  -> modify v i f++modify        :: PrimMonad m => MV.MVector (PrimState m) a -> Int -> (a -> a) -> m ()+modify v i f = MV.modify v f i+++--------------------------------------------------------------------------------++-- | For debugging purposes, dump the values and the cells+dump :: DLListMonad s a (V.Vector a, V.Vector Cell)+dump = do DLList v cs <- ask+          cs' <- V.freeze cs+          pure (v,cs')

@@ -0,0 +1,188 @@+module Data.IndexedDoublyLinkedList.Bare(+    IDLList(..)+  , Cell(..), emptyCell+  , IDLListMonad, runIDLListMonad+  , Index++  , singletons+  , writeList+  , getNext, getPrev+  , toListFrom, toListFromR, toListContains+  , toListFromK, toListFromRK+  , insertAfter, insertBefore+  , delete+  , dump+  ) where++import           Control.Monad.Primitive (PrimMonad(..))+import           Control.Monad.Reader (ReaderT, runReaderT)+import           Control.Monad.Reader.Class+import           Control.Monad.ST+import           Data.Foldable (forM_)+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.Util+import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++--------------------------------------------------------------------------------++type Index = Int++-- | Cells in the Linked List+data Cell = Cell { prev :: !(Maybe Index)+                 , next :: !(Maybe Index)+                 } deriving (Show,Eq)++emptyCell :: Cell+emptyCell = Cell Nothing Nothing++-- | Doubly linked list implemented by a mutable vector. So actually+-- this data type can represent a collection of Linked Lists that can+-- efficiently be concatenated and split.+--+-- Supports O(1) indexing, and O(1) insertions, deletions+newtype IDLList s = IDLList { llist  :: MV.MVector s Cell }++--------------------------------------------------------------------------------++-- | Monad in which we can use the IndexedDoublyLinkedList.+newtype IDLListMonad s a = IDLListMonad { runIDLListMonad' :: ReaderT (IDLList s) (ST s) a }+                        deriving (Functor,Applicative,Monad)++instance PrimMonad (IDLListMonad s) where+  type PrimState (IDLListMonad s) = s+  primitive = IDLListMonad . primitive++instance MonadReader (IDLList s) (IDLListMonad s) where+  local f = IDLListMonad . local f . runIDLListMonad'+  ask = IDLListMonad $ ask++-- | Runs a DLList Computation, starting with n singleton values+runIDLListMonad        :: Int -> (forall s. IDLListMonad s a) -> a+runIDLListMonad n comp = runST $ singletons n >>= runReaderT (runIDLListMonad' comp)++----------------------------------------++-- | Constructs a new DoublyLinkedList, of size at most n+singletons   :: (PrimMonad m, s ~ PrimState m) => Int -> m (IDLList s)+singletons n = IDLList <$> MV.replicate n emptyCell++-- | Sets the DoublyLinkedList to the given List.+--+-- Indices that do not occur in the list are not touched.+writeList   :: NonEmpty Index -> IDLListMonad s ()+writeList h = do v <- asks llist+                 forM_ (withNeighs h) $ \(STR p i s) ->+                   modify v i $ \c -> c { prev = p , next = s }+  where+    withNeighs (x:|xs) = let l = x:xs+                         in zipWith3 STR (Nothing : map Just l) l (map Just xs ++ [Nothing])++----------------------------------------+-- * Queries++-- | Next element in the List+getNext   :: Index -> IDLListMonad s (Maybe Index)+getNext i = do v <- asks llist+               next <$> MV.read v i++-- | Previous Element in the List+getPrev   :: Index -> IDLListMonad s (Maybe Index)+getPrev i = do v <- asks llist+               prev <$> MV.read v i++-- | Computes a maximal length list starting from the Given index+--+-- running time: \(O(k)\), where \(k\) is the length of the output list+toListFrom   :: Index -> IDLListMonad s (NonEmpty Index)+toListFrom i = (i :|) <$> iterateM getNext i++-- | Takes the current element and its k next's+toListFromK     :: Index -> Int -> IDLListMonad s (NonEmpty Index)+toListFromK i k = (i :|) <$> replicateM k getNext i++-- | Computes a maximal length list by walking backwards in the+-- DoublyLinkedList, starting from the Given index+--+-- running time: \(O(k)\), where \(k\) is the length of the output list+toListFromR :: Index -> IDLListMonad s (NonEmpty Index)+toListFromR i = (i :|) <$> iterateM getPrev i++toListFromRK     :: Index -> Int -> IDLListMonad s (NonEmpty Index)+toListFromRK i k = (i :|) <$> replicateM k getPrev i++-- | Computes a maximal length list that contains the element i.+--+-- running time: \(O(k)\), where \(k\) is the length of the output+-- list+toListContains   :: Index -> IDLListMonad s (NonEmpty Index)+toListContains i = f <$> toListFromR i <*> toListFrom i+  where+    f l r = NonEmpty.fromList $ reverse (NonEmpty.toList l) <> NonEmpty.tail r+++----------------------------------------+-- * Updates++-- | Inserts the second argument after the first one into the linked list+insertAfter     :: Index -> Index -> IDLListMonad s ()+insertAfter i j = do v  <- asks llist+                     mr <- getNext i+                     modify  v i  $ \c -> c { next = Just j }+                     modify  v j  $ \c -> c { prev = Just i , next = mr }+                     mModify v mr $ \c -> c { prev = Just j }++-- | Inserts the second argument before the first one into the linked list+insertBefore     :: Index -> Index -> IDLListMonad s ()+insertBefore i h = do v <- asks llist+                      ml <- getPrev i+                      mModify v ml $ \c -> c { next = Just h }+                      modify  v h  $ \c -> c { prev = ml , next = Just i }+                      modify  v i  $ \c -> c { prev = Just h }++-- | Deletes the element from the linked list. This element thus+-- essentially becomes a singleton list.+delete   :: Index -> IDLListMonad s ()+delete j = do v <- asks llist+              ml <- getPrev j+              mr <- getNext j+              modify  v j  $ \c -> c { prev = Nothing, next = Nothing }+              mModify v ml $ \c -> c { next = mr }+              mModify v mr $ \c -> c { prev = ml }++----------------------------------------+-- * Helper functions++-- | Applies the action at most n times.+replicateM     :: Monad m => Int -> (a -> m (Maybe a)) -> a -> m [a]+replicateM n f = go n+  where+    go 0 _ = pure []+    go k x = f x >>= \case+               Nothing -> pure []+               Just y  -> (y:) <$> go (k-1) y++iterateM  :: Monad m => (a -> m (Maybe a)) -> a -> m [a]+iterateM f = go+  where+    go x = f x >>= \case+             Nothing -> pure []+             Just y  -> (y:) <$> go y++mModify   :: PrimMonad m => MV.MVector (PrimState m) a -> Maybe Int -> (a -> a) -> m ()+mModify v mi f = case mi of+                   Nothing -> pure ()+                   Just i  -> modify v i f++modify        :: PrimMonad m => MV.MVector (PrimState m) a -> Int -> (a -> a) -> m ()+modify v i f = MV.modify v f i+++--------------------------------------------------------------------------------++-- | For debugging purposes, dump the values and the cells+dump :: IDLListMonad s (V.Vector Cell)+dump = do IDLList cs <- ask+          cs' <- V.freeze cs+          pure cs'

@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE BangPatterns #-} -------------------------------------------------------------------------------- -- | -- Module      :  Data.LSeq@@ -26,7 +27,7 @@                 , take                 , drop                 , unstableSort, unstableSortBy-                , head, last+                , head, tail, last, init                 , append                  , ViewL(..)@@ -40,25 +41,28 @@                 , viewr                 , pattern (:|>) +                , zipWith                  , promise                 , forceLSeq                 ) where  import           Control.DeepSeq-import           Control.Lens ((%~), (&), (<&>), (^?), bimap)+import           Control.Lens ((%~), (&), (<&>), (^?!), bimap) import           Control.Lens.At (Ixed(..), Index, IxValue) import           Data.Aeson+import           Data.Coerce(coerce) import qualified Data.Foldable as F+import           Data.Functor.Apply import qualified Data.List.NonEmpty as NonEmpty-import           Data.Maybe (fromJust) import           Data.Proxy import           Data.Semigroup.Foldable+import           Data.Semigroup.Traversable import qualified Data.Sequence as S import qualified Data.Traversable as Tr import           GHC.Generics (Generic) import           GHC.TypeLits-import           Prelude hiding (drop,take,head,last)+import           Prelude hiding (drop,take,head,last,tail,init,zipWith) import           Test.QuickCheck (Arbitrary(..),vector)  --------------------------------------------------------------------------------@@ -103,7 +107,11 @@     | otherwise                 = pure s  instance (1 <= n) => Foldable1 (LSeq n)+-- instance (1 <= n) => Traversable1 (LSeq n) where+--   traverse1 f s = case traverse1 f $ viewl s of+--                     x :< s' -> x <| s' + empty :: LSeq 0 a empty = LSeq S.empty @@ -135,8 +143,8 @@ -- checked. -- -- This function should be a noop-promise :: LSeq m a -> LSeq n a-promise = LSeq . toSeq+promise :: forall m n a. LSeq m a -> LSeq n a+promise = coerce   -- | Forces the first n elements of the LSeq@@ -144,11 +152,11 @@ forceLSeq n = promise . go (fromInteger $ natVal n)   where     -- forces the Lseq for n' positions-    go      :: Int -> LSeq m a -> LSeq m a-    go n' s | n' <= l    = s-            | otherwise  = error msg+    go                    :: Int -> LSeq m a -> LSeq m a+    go !n' s | n' <= l    = s+             | otherwise  = error msg       where-        l   = S.length . S.take n' . toSeq $ s+        !l  = S.length . S.take n' . toSeq $ s         msg = "forceLSeq: too few elements. expected " <> show n' <> " but found " <> show l  @@ -162,7 +170,7 @@ -- | get the element with index i, counting from the left and starting at 0. -- O(log(min(i,n-i))) index     :: LSeq n a -> Int -> a-index s i = fromJust $ s^?ix i+index s i = s^?!ix i  adjust       :: (a -> a) -> Int -> LSeq n a -> LSeq n a adjust f i s = s&ix i %~ f@@ -220,6 +228,15 @@   foldMap = Tr.foldMapDefault instance Traversable (ViewL n) where   traverse f (x :< xs) = (:<) <$> f x <*> traverse f xs+instance (1 <= n) => Foldable1 (ViewL n)+instance (1 <= n) => Traversable1 (ViewL n) where+  traverse1 f (a :< LSeq as) = (\(b :< bs) -> b :< promise bs) <$> go a as+    where+      go x = \case+        S.Empty       -> (:< empty) <$> f x+        (y S.:<| ys) -> (\x' (y' :< ys') -> x' :< promise @1 @0 (y' :<| ys'))+                        <$> f x <.> go y ys+ instance Eq a => Eq (ViewL n a) where   s == s' = F.toList s == F.toList s' instance Ord a => Ord (ViewL n a) where@@ -301,6 +318,12 @@ head           :: LSeq (1 + n) a -> a head (x :<| _) = x +-- | Get the LSeq without its first element+-- -- >>> head $ forceLSeq (Proxy :: Proxy 3) $ fromList [1,2,3]+-- LSeq (fromList [2,3])+tail           :: LSeq (1 + n) a -> LSeq n a+tail (_ :<| s) = s+ -- s = let (x :< _) = viewl s in x  -- | Get the last element of the LSeq@@ -310,6 +333,14 @@ last           :: LSeq (1 + n) a -> a last (_ :|> x) = x ++-- | The sequence without its last element+--+-- >>> init $ forceLSeq (Proxy :: Proxy 3) $ fromList [1,2,3]+-- LSeq (fromList [1,2])+init           :: LSeq (1 + n) a -> LSeq n a+init (s :|> _) = s+ -- testL = (eval (Proxy :: Proxy 2) $ fromList [1..5])  -- testL' :: LSeq 2 Integer@@ -317,3 +348,10 @@  -- test            :: Show a => LSeq (1 + n) a -> String -- test (x :<| xs) = show x ++ show xs+++--------------------------------------------------------------------------------++-- | Zips two equal length LSeqs+zipWith         :: (a -> b -> c) -> LSeq n a -> LSeq n b -> LSeq n c+zipWith f sa sb = LSeq $ S.zipWith f (toSeq sa) (toSeq sb)

@@ -0,0 +1,86 @@+module Data.List.Alternating(+    Alternating(..)+  , withNeighbours+  , mergeAlternating+  , insertBreakPoints+  , reverse+  ) where++import Prelude hiding (reverse)+import Control.Lens+import Data.Bifoldable+import Data.Bitraversable+import Data.Ext+import qualified Data.List as List++--------------------------------------------------------------------------------++-- | A (non-empty) alternating list of a's and b's+data Alternating a b = Alternating a [b :+ a] deriving (Show,Eq,Ord)++instance Bifunctor Alternating where+  bimap = bimapDefault+instance Bifoldable Alternating where+  bifoldMap = bifoldMapDefault+instance Bitraversable Alternating where+  bitraverse f g (Alternating a xs) = Alternating <$> f a <*> traverse (bitraverse g f) xs+++-- | Computes a b with all its neighbours+--+-- >>> withNeighbours (Alternating 0 ['a' :+ 1, 'b' :+ 2, 'c' :+ 3])+-- [(0,'a' :+ 1),(1,'b' :+ 2),(2,'c' :+ 3)]+withNeighbours                     :: Alternating a b -> [(a,b :+ a)]+withNeighbours (Alternating a0 xs) = let as = a0 : map (^.extra) xs+                                     in zipWith (\a ba -> (a,ba)) as xs++++-- | Generic merging scheme that merges two Alternatings and applies+-- the function 'f', with the current/new value at every event. So+-- note that if the alternating consists of 'Alternating a0 [t1 :++-- a1]' then the function is applied to a1, not to a0 (i.e. every+-- value ai is considered alive on the interval [ti,t(i+1))+--+-- >>> let odds  = Alternating "a" [3 :+ "c", 5 :+ "e", 7 :+ "g"]+-- >>> let evens = Alternating "b" [4 :+ "d", 6 :+ "f", 8 :+ "h"]+-- >>> mergeAlternating (\_ a b -> a <> b) odds evens+-- [3 :+ "cb",4 :+ "cd",5 :+ "ed",6 :+ "ef",7 :+ "gf",8 :+ "gh"]+-- >>> mergeAlternating (\t a b -> if t `mod` 2 == 0 then a else b) odds evens+-- [3 :+ "b",4 :+ "c",5 :+ "d",6 :+ "e",7 :+ "f",8 :+ "g"]+-- >>> mergeAlternating (\_ a b -> a <> b) odds (Alternating "b" [0 :+ "d", 5 :+ "e", 8 :+ "h"])+-- [0 :+ "ad",3 :+ "cd",5 :+ "ee",7 :+ "ge",8 :+ "gh"]+mergeAlternating                         :: Ord t+                                         => (t -> a -> b -> c)+                                         -> Alternating a t -> Alternating b t -> [t :+ c]+mergeAlternating f (Alternating a00 as0)+                   (Alternating b00 bs0) = go a00 b00 as0 bs0+  where+    go a  _  []                bs                 = map (\(t :+ b) -> t :+ f t a b) bs+    go _  b  as                []                 = map (\(t :+ a) -> t :+ f t a b) as+    go a0 b0 as@((t :+ a):as') bs@((t' :+ b):bs') = case t `compare` t' of+                                                      LT -> (t  :+ f t  a  b0) : go a  b0 as' bs+                                                      EQ -> (t  :+ f t  a  b)  : go a  b  as' bs'+                                                      GT -> (t' :+ f t' a0 b)  : go a0 b  as  bs'+++-- | Adds additional t-values in the alternating, (in sorted order). I.e. if we insert a+-- "breakpoint" at time t the current 'a' value is used at that time.+--+-- >>> insertBreakPoints [0,2,4,6,8,10] $ Alternating "a" [3 :+ "c", 5 :+ "e", 7 :+ "g"]+-- Alternating "a" [0 :+ "a",2 :+ "a",3 :+ "c",4 :+ "c",5 :+ "e",6 :+ "e",7 :+ "g",8 :+ "g",10 :+ "g"]+insertBreakPoints                         :: Ord t => [t] -> Alternating a t -> Alternating a t+insertBreakPoints ts a@(Alternating a0 _) =+  Alternating a0 $ mergeAlternating (\_ _ a' -> a') (Alternating undefined (ext <$> ts)) a+++-- | Reverses an alternating list.+--+-- >>> reverse $ Alternating "a" [3 :+ "c", 5 :+ "e", 7 :+ "g"]+-- Alternating "g" [7 :+ "e",5 :+ "c",3 :+ "a"]+reverse                      :: Alternating a b -> Alternating a b+reverse p@(Alternating s xs) = case xs of+    []             -> p+    ((e1 :+ _):tl) -> let ys = (e1 :+ s) : List.zipWith (\(_ :+ v) (e :+ _) -> e :+ v) xs tl+                          t  = (last xs)^.extra+                      in Alternating t (List.reverse ys)

@@ -0,0 +1,71 @@+module Data.List.Set( Set, singleton+                    , insert, delete+                    , union, intersection, difference+                    , fromList, insertAll+                    ) where++import qualified Data.List as List++--------------------------------------------------------------------------------++-- | A Set of 'a's, implemented using a simple list. The only+-- advantage of this implementation over 'Data.Set' from containers is+-- that most operations require only 'Eq a' rather than 'Ord a'.+newtype Set a = Set { toList :: [a] }+              deriving (Show,Read,Functor,Foldable,Traversable)++instance Eq a => Eq (Set a) where+  (Set xs) == (Set ys) = all (`elem` ys) xs &&  all (`elem` xs) ys+++instance Eq a => Semigroup (Set a) where+  (Set xs) <> s = insertAll xs s++instance Eq a => Monoid (Set a) where+  mempty = Set []++-- | Creates a singleton set.+singleton   :: a -> Set a+singleton x = Set [x]++-- | Inserts an element in the set+--+-- running time: \(O(n)\)+insert                           :: Eq a => a -> Set a -> Set a+insert x s@(Set xs) | x `elem` s = s+                    | otherwise  = Set (x:xs)++insertAll      :: Eq a => [a] -> Set a -> Set a+insertAll xs s = List.foldl' (flip insert) s xs++fromList :: Eq a => [a] -> Set a+fromList = flip insertAll mempty++-- | Deletes an element from the set+--+-- running time: \(O(n)\)+delete            :: Eq a => a -> Set a -> Set a+delete x (Set xs) = Set $ go xs+  where+    go = \case+      [] -> []+      (y:ys) | x == y    -> ys -- found the element, no need to continue looking+             | otherwise -> y:go ys++-- | Computes the union of two sets+--+-- running time: \(O(n^2)\)+union :: Eq a => Set a -> Set a -> Set a+union = (<>)++-- | Computes the intersection of two sets+--+-- running time: \(O(n^2)\)+intersection                     :: Eq a => Set a -> Set a -> Set a+(Set xs) `intersection` (Set ys) = Set (xs `List.intersect` ys)++-- | Computes the difference of two sets+--+-- running time: \(O(n^2)\)+difference :: Eq a => Set a -> Set a -> Set a+(Set xs) `difference` (Set ys) = Set $ xs List.\\ ys

@@ -0,0 +1,77 @@+module Data.List.Util where++import           Data.Bifunctor+import           Data.Ext+import qualified Data.Foldable as F+import qualified Data.List as List+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NonEmpty+import           Data.List.Zipper (allNonEmptyNexts, extractNext)+import qualified Data.List.Zipper as Zipper+import           Data.Maybe+import           Data.Ord (comparing)++--------------------------------------------------------------------------------++-- | Given an input list, computes all lists in which just one element is missing.+--+-- >>> mapM_ print $ leaveOutOne [1..5]+-- (1,[2,3,4,5])+-- (2,[1,3,4,5])+-- (3,[1,2,4,5])+-- (4,[1,2,3,5])+-- (5,[1,2,3,4])+-- >>> leaveOutOne []+-- []+-- >>> leaveOutOne [1]+-- [(1,[])]+leaveOutOne    :: [a] -> [(a,[a])]+leaveOutOne xs = (second F.toList . fromJust . extractNext)+              <$> allNonEmptyNexts (Zipper.fromList xs)+++--------------------------------------------------------------------------------+-- * Improved functions for minima and maxima++minimum1 :: Ord a => [a] -> Maybe a+minimum1 = minimum1By compare++maximum1 :: Ord a => [a] -> Maybe a+maximum1 = minimum1By (flip compare)++minimum1By     :: (a -> a -> Ordering) -> [a] -> Maybe a+minimum1By cmp = \case+  [] -> Nothing+  xs -> Just $ List.minimumBy cmp xs++minimaOn   :: Ord b => (a -> b) -> [a] -> [a]+minimaOn f = minimaBy (comparing f)++-- | computes all minima+minimaBy     :: (a -> a -> Ordering) -> [a] -> [a]+minimaBy cmp = \case+  []     -> []+  (x:xs) -> NonEmpty.toList $ List.foldl' (\mins@(m:|_) y -> case m `cmp` y of+                                                               LT -> mins+                                                               EQ -> (y NonEmpty.<| mins)+                                                               GT -> (y:|[])+                                          ) (x:|[]) xs++-- | extracts all minima from the list. The result consists of the+-- list of minima, and all remaining points. Both lists are returned+-- in the order in which they occur in the input.+--+-- >>> extractMinimaBy compare [1,2,3,0,1,2,3,0,1,2,0,2]+-- [0,0,0] :+ [2,3,1,2,3,1,2,1,2]+extractMinimaBy     :: (a -> a -> Ordering) -> [a] -> [a] :+ [a]+extractMinimaBy cmp = \case+  []     -> [] :+ []+  (x:xs) -> first NonEmpty.toList $ foldr (\y (mins@(m:|_) :+ rest) ->+                                             case m `cmp` y of+                                               LT -> mins :+ y:rest+                                               EQ -> (y NonEmpty.<| mins) :+ rest+                                               GT -> (y:|[]) :+ NonEmpty.toList mins <> rest+                                          ) ((x:|[]) :+ []) xs+  -- TODO: This is actually a good scenario for testing how much slower :+ is compared+  -- to doing nothing. i..e compare minimaBy and extractMinimaBy+  -- note that I'm using foldr here, and foldl' before

@@ -0,0 +1,72 @@+module Data.List.Zipper where++import qualified Data.List as List++--------------------------------------------------------------------------------++-- | Simple Zipper for Lists.+data Zipper a = Zipper [a] [a] deriving (Show,Eq,Functor)++instance Foldable Zipper where+  -- Folds like it it is a normal list+  foldMap f (Zipper ls rs) = foldMap f (reverse ls) <> foldMap f rs+++-- | Construct a Zipper from a list+--+-- running time: \(O(1)\)+fromList :: [a] -> Zipper a+fromList = Zipper []++-- | Go to the Next Element+--+-- running time: \(O(1)\)+goNext                :: Zipper a -> Maybe (Zipper a)+goNext (Zipper xs ys) = case ys of+                          []    -> Nothing+                          x:ys' -> Just $ Zipper (x:xs) ys'++-- | Go to the previous Element+--+-- running time: \(O(1)\)+goPrev                :: Zipper a -> Maybe (Zipper a)+goPrev (Zipper xs ys) = case xs of+                          []    -> Nothing+                          x:xs' -> Just $ Zipper xs' (x:ys)++-- | Computes all nexts, even one that has no elements initially or at+-- the end.+--+-- >>> mapM_ print $ allNexts $ fromList [1..5]+-- Zipper [] [1,2,3,4,5]+-- Zipper [1] [2,3,4,5]+-- Zipper [2,1] [3,4,5]+-- Zipper [3,2,1] [4,5]+-- Zipper [4,3,2,1] [5]+-- Zipper [5,4,3,2,1] []+allNexts :: Zipper a -> [Zipper a]+allNexts = List.unfoldr (fmap (\z -> (z,goNext z))) . Just++-- | Returns the next element, and the zipper without it+extractNext                :: Zipper a -> Maybe (a, Zipper a)+extractNext (Zipper xs ys) = case ys of+                               []      -> Nothing+                               (y:ys') -> Just $ (y,Zipper xs ys')+++-- | Drops the next element in the zipper.+--+-- running time: \(O(1)\)+dropNext :: Zipper a -> Maybe (Zipper a)+dropNext = fmap snd . extractNext++-- | Computes all list that still have next elements.+--+-- >>> mapM_ print $ allNonEmptyNexts $ fromList [1..5]+-- Zipper [] [1,2,3,4,5]+-- Zipper [1] [2,3,4,5]+-- Zipper [2,1] [3,4,5]+-- Zipper [3,2,1] [4,5]+-- Zipper [4,3,2,1] [5]+allNonEmptyNexts :: Zipper a -> [Zipper a]+allNonEmptyNexts = List.unfoldr (\z -> (z,) <$> goNext z)

@@ -0,0 +1,5 @@+{-# Language FunctionalDependencies #-}+module Data.Measured( module Data.Measured.Class+                    ) where++import Data.Measured.Class

@@ -0,0 +1,11 @@+{-# Language FunctionalDependencies #-}+module Data.Measured.Class where++class Semigroup v => Measured v a | a -> v where+  measure :: a -> v++class Measured v a => CanInsert v a where+  insertA :: a -> v -> v++class Measured v a => CanDelete v a where+  deleteA :: a -> v -> Maybe v

@@ -0,0 +1,40 @@+module Data.Measured.Size where++import Control.DeepSeq+import Data.Measured.Class+import GHC.Generics (Generic)++--------------------------------------------------------------------------------++newtype Size = Size Word deriving (Show,Read,Eq,Num,Integral,Enum,Real,Ord,Generic,NFData)++instance Semigroup Size where+  x <> y = x + y++instance Monoid Size where+  mempty = Size 0++--------------------------------------------------------------------------------++-- | Newtype wrapper for things for which we can measure the size+newtype Elem a = Elem { _unElem :: a }+               deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable)++instance Measured Size (Elem a) where+  measure _ = 1++--------------------------------------------------------------------------------++-- | Things that have a size+data Sized a = Sized {-# UNPACK #-} !Size a+             deriving (Show,Eq,Ord,Functor,Foldable,Traversable,Generic)+instance NFData a => NFData (Sized a)++instance Semigroup a => Semigroup (Sized a) where+  (Sized i a) <> (Sized j b) = Sized (i <> j) (a <> b)++instance Monoid a => Monoid (Sized a) where+  mempty = Sized mempty mempty++-- instance Semigroup a => Measured Size (Sized a) where+--   measure (Sized i _) = i

@@ -432,13 +432,23 @@ incidentEdges (VertexId v) g = g^?!embedding.orbits.ix v   -- TODO: The Delaunay triang. stuff seems to produce these in clockwise order instead --- | All incoming edges incident to vertex v, in counterclockwise order around v.+-- | All edges incident to vertex v in incoming direction+-- (i.e. pointing into v) in counterclockwise order around v.+--+-- running time: \(O(k)\), where \(k) is the total number of incident edges of v incomingEdges     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)-incomingEdges v g = V.filter (not . isPositive) $ incidentEdges v g+incomingEdges v g = orient <$> incidentEdges v g+  where+    orient d = if headOf d g == v then d else twin d --- | All outgoing edges incident to vertex v, in counterclockwise order around v.+-- | All edges incident to vertex v in outgoing direction+-- (i.e. pointing away from v) in counterclockwise order around v.+--+-- running time: \(O(k)\), where \(k) is the total number of incident edges of v outgoingEdges     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (Dart s)-outgoingEdges v g = V.filter isPositive $ incidentEdges v g+outgoingEdges v g = orient <$> incidentEdges v g+  where+    orient d = if tailOf d g == v then d else twin d   -- | Gets the neighbours of a particular vertex, in counterclockwise order@@ -446,9 +456,7 @@ -- -- running time: \(O(k)\), where \(k\) is the output size neighboursOf     :: VertexId s w -> PlanarGraph s w v e f -> V.Vector (VertexId s w)-neighboursOf v g = otherVtx <$> incidentEdges v g-  where-    otherVtx d = let u = tailOf d g in if u == v then headOf d g else u+neighboursOf v g = flip tailOf g <$> incomingEdges v g  -- | Given a dart d that points into some vertex v, report the next dart in the -- cyclic order around v.

@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Data.RealNumber.Rational(RealNumber(..)++                               -- * Converting to and from RealNumber's+                               , AsFixed(..), asFixed+                               , toFixed, fromFixed+                               ) where++import Data.Data+import Data.Fixed+import Data.Hashable+import Data.List (dropWhileEnd)+import GHC.Generics (Generic(..))+import GHC.TypeLits+import Test.QuickCheck(Arbitrary(..))++--------------------------------------------------------------------------------++-- | Real Numbers represented using Rational numbers. The number type+-- itself is exact in the sense that we can represent any rational+-- number.+--+-- The parameter, a natural number, represents the precision (in+-- number of decimals behind the period) with which we display the+-- numbers when printing them (using Show).+--+-- If the number cannot be displayed exactly a '~' is printed after+-- the number.+newtype RealNumber (p :: Nat) = RealNumber Rational+  deriving (Eq,Ord,Data,Num,Fractional,Real,RealFrac,Generic,Hashable)+++data NatPrec (p :: Nat) = NatPrec++instance KnownNat p => HasResolution (NatPrec p) where+  resolution _ = 10 ^ (1 + natVal (NatPrec @p))+++instance KnownNat p => Show (RealNumber p) where+  show r = case asFixed r of+             Exact p -> dropWhileEnd (== '.') . dropWhileEnd (== '0') . show $ p+             Lossy p -> (<> "~")                                      . show $ p++instance KnownNat p => Read (RealNumber p) where+  readsPrec i = map wrap . readsPrec @(Fixed (NatPrec p)) i+    where+      wrap (RealNumber . realToFrac -> x,s') = case s' of+                                                 '~':s'' -> (x,s'')+                                                 _       -> (x,s')++instance KnownNat p => Arbitrary (RealNumber p) where+  arbitrary = fromFixed <$> arbitrary++--------------------------------------------------------------------------------+++++data AsFixed p = Exact !(Fixed p) | Lossy !(Fixed p) deriving (Show,Eq)++toFixed :: KnownNat p => RealNumber p -> Fixed (NatPrec p)+toFixed = realToFrac++fromFixed :: KnownNat p => Fixed (NatPrec p) -> RealNumber p+fromFixed = realToFrac++asFixed   :: KnownNat p => RealNumber p -> AsFixed (NatPrec p)+asFixed r = let p = toFixed r in if r == fromFixed p then Exact p else Lossy p

@@ -1,47 +1,11 @@ module Data.Sequence.Util where -import Data.Sequence(Seq, ViewL(..),ViewR(..))+import           Algorithms.BinarySearch import qualified Data.Sequence as S-import qualified Data.Vector.Generic as V+import           Data.Sequence (Seq)  -------------------------------------------------------------------------------- --- | Given a monotonic predicate, Get the index h such that everything strictly--- smaller than h has: p i = False, and all i >= h, we have p h = True------ returns Nothing if no element satisfies p------ running time: \(O(\log^2 n + T*\log n)\), where \(T\) is the time to execute the--- predicate.-binarySearchSeq     :: (a -> Bool) -> Seq a -> Maybe Int-binarySearchSeq p s = case S.viewr s of-                       EmptyR                 -> Nothing-                       (_ :> x)   | p x       -> Just $ case S.viewl s of-                         (y :< _) | p y          -> 0-                         _                       -> binarySearch p' 0 u-                                  | otherwise -> Nothing-  where-    p' = p . S.index s-    u  = S.length s - 1---- | Given a monotonic predicate, get the index h such that everything strictly--- smaller than h has: p i = False, and all i >= h, we have p h = True------ returns Nothing if no element satisfies p------ running time: \(O(T*\log n)\), where \(T\) is the time to execute the--- predicate.-binarySearchVec                             :: V.Vector v a-                                            => (a -> Bool) -> v a -> Maybe Int-binarySearchVec p' v | V.null v   = Nothing-                     | not $ p n' = Nothing-                     | otherwise  = Just $ if p 0 then 0-                                                  else binarySearch p 0 n'-  where-    n' = V.length v - 1-    p = p' . (v V.!)-- -- | Partition the seq s given a monotone predicate p into (xs,ys) such that -- -- all elements in xs do *not* satisfy the predicate p@@ -55,22 +19,3 @@ splitMonotone p s = case binarySearchSeq p s of                       Nothing -> (s,S.empty)                       Just i  -> S.splitAt i s----- | Given a monotonic predicate p, a lower bound l, and an upper bound u, with:---  p l = False---  p u = True---  l < u.------ Get the index h such that everything strictly smaller than h has: p i =--- False, and all i >= h, we have p h = True------ running time: \(O(\log(u - l))\)-{-# SPECIALIZE binarySearch :: (Int -> Bool) -> Int -> Int -> Int #-}-{-# SPECIALIZE binarySearch :: (Word -> Bool) -> Word -> Word -> Word #-}-binarySearch       :: Integral a => (a -> Bool) -> a -> a -> a-binarySearch p l u = let d = u - l-                         m = l + (d `div` 2)-                     in if d == 1 then u else-                          if p m then binarySearch p l m-                                 else binarySearch p m u

@@ -1,205 +0,0 @@-module Data.SlowSeq where---import           Control.Lens (bimap)--- import qualified Data.FingerTree as FT--- import           Data.FingerTree hiding (null, viewl, viewr)-import           Data.FingerTree(ViewL(..),ViewR(..))-import qualified Data.Foldable as F-import           Data.Maybe-import qualified Data.Sequence as S-import qualified Data.Sequence.Util as SU--------------------------------------------------------------------------------------data Key a = NoKey | Key { getKey :: a } deriving (Show,Eq,Ord)--instance Semigroup (Key a) where-  k <> NoKey = k-  _ <> k     = k--instance Monoid (Key a) where-  mempty = NoKey-  k `mappend` k' = k <> k'--liftCmp                     :: (a -> a -> Ordering) -> Key a -> Key a -> Ordering-liftCmp _   NoKey   NoKey   = EQ-liftCmp _   NoKey   (Key _) = LT-liftCmp _   (Key _) NoKey   = GT-liftCmp cmp (Key x) (Key y) = x `cmp` y------ newtype Elem a = Elem { getElem :: a } deriving (Eq,Ord,Traversable,Foldable,Functor)---- instance Show a => Show (Elem a) where---   show (Elem x) = "Elem " <> show x---newtype OrdSeq a = OrdSeq { _asSeq :: S.Seq a }-                   deriving (Show,Eq)--instance Semigroup (OrdSeq a) where-  (OrdSeq s) <> (OrdSeq t) = OrdSeq $ s `mappend` t--instance Monoid (OrdSeq a) where-  mempty = OrdSeq mempty-  mappend = (<>)--instance Foldable OrdSeq where-  foldMap f = foldMap f . _asSeq-  null      = null . _asSeq-  length    = length . _asSeq-  minimum   = fromJust . lookupMin-  maximum   = fromJust . lookupMax---- instance Measured (Key a) (Elem a) where---   measure (Elem x) = Key x---type Compare a = a -> a -> Ordering---- | Insert into a monotone OrdSeq.------ pre: the comparator maintains monotonicity------ \(O(\log^2 n)\)-insertBy                  :: Compare a -> a -> OrdSeq a -> OrdSeq a-insertBy cmp x (OrdSeq s) = OrdSeq $ l `mappend` (x S.<| r)-  where-    (l,r) = split (\v -> cmp v x `elem` [EQ, GT]) s--------- | Insert into a sorted OrdSeq------ \(O(\log^2 n)\)-insert :: Ord a => a -> OrdSeq a -> OrdSeq a-insert = insertBy compare--deleteAllBy         :: Compare a -> a -> OrdSeq a -> OrdSeq a-deleteAllBy cmp x s = l <> r-  where-    (l,_,r) = splitBy cmp x s--    -- (l,m) = split (\v -> liftCmp cmp v (Key x) `elem` [EQ,GT]) s-    -- (_,r) = split (\v -> liftCmp cmp v (Key x) == GT) m----- | \(O(\log^2 n)\)-splitBy                  :: Compare a -> a -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a)-splitBy cmp x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r)-  where-    (l, m) = split (\v -> cmp v x `elem` [EQ,GT]) s-    (m',r) = split (\v -> cmp v x == GT) m----- | Given a monotonic function f that maps a to b, split the sequence s--- depending on the b values. I.e. the result (l,m,r) is such that--- * all (< x) . fmap f $ l--- * all (== x) . fmap f $ m--- * all (> x) . fmap f $ r------ >>> splitOn id 3 $ fromAscList' [1..5]--- (OrdSeq {_asSeq = fromList [Elem 1,Elem 2]},OrdSeq {_asSeq = fromList [Elem 3]},OrdSeq {_asSeq = fromList [Elem 4,Elem 5]})--- >>> splitOn fst 2 $ fromAscList' [(0,"-"),(1,"A"),(2,"B"),(2,"C"),(3,"D"),(4,"E")]--- (OrdSeq {_asSeq = fromList [Elem (0,"-"),Elem (1,"A")]},OrdSeq {_asSeq = fromList [Elem (2,"B"),Elem (2,"C")]},OrdSeq {_asSeq = fromList [Elem (3,"D"),Elem (4,"E")]})------ \(O(\log^2 n)\)-splitOn :: Ord b => (a -> b) -> b -> OrdSeq a -> (OrdSeq a, OrdSeq a, OrdSeq a)-splitOn f x (OrdSeq s) = (OrdSeq l, OrdSeq m', OrdSeq r)-  where-    (l, m) = split (\v -> compare (f v) x `elem` [EQ,GT]) s-    (m',r) = split (\v -> compare (f v) x ==     GT)      m---- | Given a monotonic predicate p, splits the sequence s into two sequences---  (as,bs) such that all (not p) as and all p bs------ \(O(\log^2 n)\)-splitMonotonic  :: (a -> Bool) -> OrdSeq a -> (OrdSeq a, OrdSeq a)-splitMonotonic p = bimap OrdSeq OrdSeq . split p . _asSeq----- monotonic split for Sequences------ \(O(\log^2 n)\)-split :: (a -> Bool) -> S.Seq a -> (S.Seq a, S.Seq a)-split = SU.splitMonotone---- Deletes all elements from the OrdDeq------ \(O(\log^2 n)\)-deleteAll :: Ord a => a -> OrdSeq a -> OrdSeq a-deleteAll = deleteAllBy compare----- | inserts all eleements in order--- \(O(n\log n)\)-fromListBy     :: Compare a -> [a] -> OrdSeq a-fromListBy cmp = foldr (insertBy cmp) mempty---- | inserts all eleements in order--- \(O(n\log n)\)-fromListByOrd :: Ord a => [a] -> OrdSeq a-fromListByOrd = fromListBy compare---- | O(n)-fromAscList' :: [a] -> OrdSeq a-fromAscList' = OrdSeq . S.fromList----- | \(O(\log^2 n)\)-lookupBy                  :: Compare a -> a -> OrdSeq a -> Maybe a-lookupBy cmp x s = let (_,m,_) = splitBy cmp x s in listToMaybe . F.toList $ m--memberBy        :: Compare a -> a -> OrdSeq a -> Bool-memberBy cmp x = isJust . lookupBy cmp x----- | Fmap, assumes the order does not change--- \(O(n)\)-mapMonotonic   :: (a -> b) -> OrdSeq a -> OrdSeq b-mapMonotonic f = fromAscList' . map f . F.toList----- | Gets the first element from the sequence--- \(O(1)\)-viewl :: OrdSeq a -> ViewL OrdSeq a-viewl = f . S.viewl . _asSeq-  where-    f S.EmptyL         = EmptyL-    f (x S.:< s)  = x :< OrdSeq s---- Last element--- \(O(1)\)-viewr :: OrdSeq a -> ViewR OrdSeq a-viewr = f . S.viewr . _asSeq-  where-    f S.EmptyR    = EmptyR-    f (s S.:> x)  = OrdSeq s :> x----- \(O(1)\)-minView   :: OrdSeq a -> Maybe (a, OrdSeq a)-minView s = case viewl s of-              EmptyL   -> Nothing-              (x :< t) -> Just (x,t)---- \(O(1)\)-lookupMin :: OrdSeq a -> Maybe a-lookupMin = fmap fst . minView---- \(O(1)\)-maxView   :: OrdSeq a -> Maybe (a, OrdSeq a)-maxView s = case viewr s of-              EmptyR   -> Nothing-              (t :> x) -> Just (x,t)---- \(O(1)\)-lookupMax :: OrdSeq a -> Maybe a-lookupMax = fmap fst . maxView

@@ -1,10 +1,15 @@ module Data.Tree.Util where -import Data.Maybe(listToMaybe,maybeToList)-import Control.Lens-import Control.Monad((>=>))-import Data.Tree+import           Data.Bifoldable+import           Data.Bifunctor+import           Data.Bitraversable+import           Control.Lens+import           Control.Monad ((>=>)) import qualified Data.List as List+import qualified Data.List.NonEmpty as NonEmpty+import           Data.List.NonEmpty (NonEmpty(..))+import           Data.Maybe (listToMaybe,maybeToList)+import           Data.Tree  -------------------------------------------------------------------------------- @@ -16,7 +21,31 @@ --                     ] -- :} + --------------------------------------------------------------------------------++-- | Nodes in a tree are typically either an internal node or a leaf node+data TreeNode v a = InternalNode v | LeafNode a deriving (Show,Eq)++instance Bifunctor TreeNode where+  bimap = bimapDefault+instance Bifoldable TreeNode where+  bifoldMap = bifoldMapDefault+instance Bitraversable TreeNode where+  bitraverse f g = \case+    InternalNode v -> InternalNode <$> f v+    LeafNode l     -> LeafNode     <$> g l++-- | A TreeNode is isomorphic to Either+_TreeNodeEither :: Iso' (TreeNode v p) (Either v p)+_TreeNodeEither = iso tne etn+  where+    tne = \case+      InternalNode v -> Left v+      LeafNode l     -> Right l+    etn = either InternalNode LeafNode++-------------------------------------------------------------------------------- -- * Zipper on rose trees  -- | Zipper for rose trees@@ -152,3 +181,27 @@   where     go t = let mh = if p t then [[]] else []            in map (rootLabel t:) $ mh <> concatMap go (children t)+++-- | BFS Traversal of the rose tree that decomposes it into levels.+--+-- running time: \(O(n)\)+levels :: Tree a -> NonEmpty (NonEmpty a)+levels = go1 . (:| [])+  where+    go0   :: [Tree a] -> [NonEmpty a]+    go0 q = case NonEmpty.nonEmpty q of+              Nothing -> []+              Just q1 -> NonEmpty.toList $ go1 q1+    {-# INLINE go0 #-}++    -- all work essentially happens here: given a bunch of trees whose+    -- root elements all have the same level, extract the values+    -- stored at these root nodes, collect all children in a big list,+    -- and explore those recursively.+    go1    :: NonEmpty (Tree a) -> NonEmpty (NonEmpty a)+    go1 qs = fmap root' qs :| go0 (concatMap children' qs)+    {-# INLINE go1 #-}++    root'     (Node x _)   = x+    children' (Node _ chs) = chs

@@ -1,11 +1,23 @@ {-# LANGUAGE TemplateHaskell   #-}+--------------------------------------------------------------------------------+-- |+-- Module      :  Data.UnBounded+-- Copyright   :  (C) Frank Staals+-- License     :  see the LICENSE file+-- Maintainer  :  Frank Staals+--+-- Add an unbounded/infintity element to a data type. Essentially,+-- 'Bottom' adds \(-\infty\) (and is pretty much identical to Maybe),+-- whereas 'Top' adds \(\infty\). The Unbounded type adds both.+--+-------------------------------------------------------------------------------- module Data.UnBounded( Top, topToMaybe                      , pattern ValT, pattern Top-                     , _ValT, _Top+                     , _ValT, _Top, _TopMaybe                       , Bottom, bottomToMaybe                      , pattern Bottom, pattern ValB-                     , _ValB, _Bottom+                     , _ValB, _Bottom, _BottomMaybe                       , UnBounded(..)                      , unUnBounded@@ -56,6 +68,21 @@ _Top :: Prism' (Top a) () _Top = prism' (const Top) (\ta -> case ta of Top -> Just () ; ValT _ -> Nothing) +-- | Iso between a 'Top a' and a 'Maybe a', interpreting a Top as a+-- Nothing and vice versa. Note that this reverses the ordering of+-- the elements.+--+-- >>> ValT 5 ^. _TopMaybe+-- Just 5+-- >>> Just 5 ^.re _TopMaybe+-- ValT 5+-- >>> Top ^. _TopMaybe+-- Nothing+-- >>> Nothing ^.re _TopMaybe+-- Top+_TopMaybe :: Iso' (Top a) (Maybe a)+_TopMaybe = iso topToMaybe GTop+ --------------------------------------------------------------------------------  -- | `Bottom a` represents the type a, together with a 'Bottom' element,@@ -83,6 +110,20 @@  _Bottom :: Prism' (Bottom a) () _Bottom = prism' (const Bottom) (\ba -> case ba of Bottom -> Just () ; ValB _ -> Nothing)++-- | Iso between a 'Bottom a' and a 'Maybe a', interpreting a Bottom as a+-- Nothing and vice versa.+--+-- >>> ValB 5 ^. _BottomMaybe+-- Just 5+-- >>> Just 5 ^.re _BottomMaybe+-- ValB 5+-- >>> Bottom ^. _BottomMaybe+-- Nothing+-- >>> Nothing ^.re _BottomMaybe+-- Bottom+_BottomMaybe :: Iso' (Bottom a) (Maybe a)+_BottomMaybe = iso bottomToMaybe GBottom  -------------------------------------------------------------------------------- 

@@ -10,17 +10,18 @@ -------------------------------------------------------------------------------- module Data.Util where -import Control.DeepSeq-import Control.Lens-import GHC.Generics (Generic)+import           Control.DeepSeq+import           Control.Lens import qualified Data.List as List+import           GHC.Generics (Generic)+import           Linear.V2 (V2(..))+import           Linear.V3 (V3(..))  -------------------------------------------------------------------------------- -- * Strict Triples  -- |  strict triple-data STR a b c = STR { fst' :: !a, snd' :: !b , trd' :: !c}-               deriving (Show,Eq,Ord,Functor,Generic)+data STR a b c = STR !a !b !c deriving (Show,Eq,Ord,Functor,Generic)  instance (Semigroup a, Semigroup b, Semigroup c) => Semigroup (STR a b c) where   (STR a b c) <> (STR d e f) = STR (a <> d) (b <> e) (c <> f)@@ -33,22 +34,28 @@ instance (NFData a, NFData b, NFData c) => NFData (STR a b c)  instance Field1 (STR a b c) (STR d b c) a d where-  _1 = lens fst' (\(STR _ b c) d -> STR d b c)+  _1 = lens (\(STR a _ _) -> a) (\(STR _ b c) d -> STR d b c)  instance Field2 (STR a b c) (STR a d c) b d where-  _2 = lens snd' (\(STR a _ c) d -> STR a d c)+  _2 = lens (\(STR _ b _) -> b) (\(STR a _ c) d -> STR a d c)  instance Field3 (STR a b c) (STR a b d) c d where-  _3 = lens trd' (\(STR a b _) d -> STR a b d)---- | Generate All unique unordered triplets.----uniqueTriplets    :: [a] -> [STR a a a]-uniqueTriplets xs = [ STR x y z | (x:ys) <- nonEmptyTails xs, SP y z <- uniquePairs ys]+  _3 = lens (\(STR _ _ c) -> c) (\(STR a b _) d -> STR a b d) +-------------------------------------------------------------------------------- +--------------------------------------------------------------------------------+-- | Strict Triple with all items the same+type Three = V3 +pattern Three :: a -> a -> a -> Three a+pattern Three a b c = V3 a b c+{-# COMPLETE Three #-} +-- | Generate All unique unordered triplets.+--+uniqueTriplets    :: [a] -> [Three a]+uniqueTriplets xs = [ Three x y z | (x:ys) <- nonEmptyTails xs, Two y z <- uniquePairs ys]  -------------------------------------------------------------------------------- -- * Strict Pairs@@ -80,10 +87,10 @@ -- | * Strict pair whose elements are of the same type.  -- | Strict pair with both items the same-type Two a = SP a a+type Two = V2  pattern Two :: a -> a -> Two a-pattern Two a b = SP a b+pattern Two a b = V2 a b {-# COMPLETE Two #-}  -- | Given a list xs, generate all unique (unordered) pairs.@@ -91,14 +98,6 @@ -- uniquePairs    :: [a] -> [Two a] uniquePairs xs = [ Two x y | (x:ys) <- nonEmptyTails xs, y <- ys ]------------------------------------------------------------------------------------- | Strict Triple with all items the same-type Three a = STR a a a--pattern Three :: a -> a -> a -> Three a-pattern Three a b c = STR a b c-{-# COMPLETE Three #-}  -------------------------------------------------------------------------------- 

@@ -0,0 +1,36 @@+module Data.IndexedDoublyLinkedListSpec where++import           Control.Monad.ST+import           Data.IndexedDoublyLinkedList+import           Data.List.NonEmpty (NonEmpty(..))+import qualified Data.Vector as V+import           Test.Hspec++--------------------------------------------------------------------------------++spec :: Spec+spec = do+  describe "IndexedDoublyLinkedList tests" $ do+    it "myTest" $+      runT myProg `shouldBe` (4 :| [2,1,0],4 :| [5,8])+    it "myTest'" $+      runT myProg' `shouldBe` ('e' :| "cba",'e' :| "fi")+++runT   :: (forall s. DLListMonad s Char a) -> a+runT c = runDLListMonad (V.fromList "abcdefghi") c++myProg :: DLListMonad s b (NonEmpty Index, NonEmpty Index)+myProg = do writeList (0 :| [2,4,6,8])+            delete 6+            insertBefore 2 1+            insertAfter 4 5+            as <- toListFromR 4+            bs <- toListFrom 4+            pure (as,bs)++myProg' :: DLListMonad s b (NonEmpty b, NonEmpty b)+myProg' = do (as,bs) <- myProg+             as' <- mapM valueAt as+             bs' <- mapM valueAt bs+             pure (as',bs')

@@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} module Data.PlanarGraphSpec where -+import Control.Lens(view,_3) import           Data.Bifunctor import qualified Data.ByteString.Char8 as B import qualified Data.Foldable as F@@ -90,7 +90,7 @@ fromAdjacencyListsOld adjM = planarGraph' . toCycleRep n $ perm   where     n    = sum . fmap length $ perm-    perm = trd' . foldr toOrbit (STR mempty 0 mempty) $ adjM+    perm = view (_3) . foldr toOrbit (STR mempty 0 mempty) $ adjM       -- | Given a vertex with its adjacent vertices (u,vs) (in CCW order) convert this