diff --git a/changelog.org b/changelog.org --- a/changelog.org +++ b/changelog.org @@ -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. diff --git a/doctests.hs b/doctests.hs --- a/doctests.hs +++ b/doctests.hs @@ -63,4 +63,8 @@ , "Data.PlanarGraph.Core" , "Data.Tree.Util" , "Data.Set.Util" + + , "Data.List.Util" + , "Data.List.Alternating" + , "Data.List.Zipper" ] diff --git a/hgeometry-combinatorial.cabal b/hgeometry-combinatorial.cabal --- a/hgeometry-combinatorial.cabal +++ b/hgeometry-combinatorial.cabal @@ -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 diff --git a/src/Algorithms/BinarySearch.hs b/src/Algorithms/BinarySearch.hs new file mode 100644 --- /dev/null +++ b/src/Algorithms/BinarySearch.hs @@ -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.!) diff --git a/src/Algorithms/DivideAndConquer.hs b/src/Algorithms/DivideAndConquer.hs --- a/src/Algorithms/DivideAndConquer.hs +++ b/src/Algorithms/DivideAndConquer.hs @@ -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 diff --git a/src/Control/CanAquire.hs b/src/Control/CanAquire.hs new file mode 100644 --- /dev/null +++ b/src/Control/CanAquire.hs @@ -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 diff --git a/src/Data/BalBST.hs b/src/Data/BalBST.hs deleted file mode 100644 --- a/src/Data/BalBST.hs +++ /dev/null @@ -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 diff --git a/src/Data/BinaryTree.hs b/src/Data/BinaryTree.hs --- a/src/Data/BinaryTree.hs +++ b/src/Data/BinaryTree.hs @@ -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 diff --git a/src/Data/Ext.hs b/src/Data/Ext.hs --- a/src/Data/Ext.hs +++ b/src/Data/Ext.hs @@ -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 #-} diff --git a/src/Data/IndexedDoublyLinkedList.hs b/src/Data/IndexedDoublyLinkedList.hs new file mode 100644 --- /dev/null +++ b/src/Data/IndexedDoublyLinkedList.hs @@ -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') diff --git a/src/Data/IndexedDoublyLinkedList/Bare.hs b/src/Data/IndexedDoublyLinkedList/Bare.hs new file mode 100644 --- /dev/null +++ b/src/Data/IndexedDoublyLinkedList/Bare.hs @@ -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' diff --git a/src/Data/LSeq.hs b/src/Data/LSeq.hs --- a/src/Data/LSeq.hs +++ b/src/Data/LSeq.hs @@ -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) diff --git a/src/Data/List/Alternating.hs b/src/Data/List/Alternating.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Alternating.hs @@ -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) diff --git a/src/Data/List/Set.hs b/src/Data/List/Set.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Set.hs @@ -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 diff --git a/src/Data/List/Util.hs b/src/Data/List/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Util.hs @@ -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 diff --git a/src/Data/List/Zipper.hs b/src/Data/List/Zipper.hs new file mode 100644 --- /dev/null +++ b/src/Data/List/Zipper.hs @@ -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) diff --git a/src/Data/Measured.hs b/src/Data/Measured.hs new file mode 100644 --- /dev/null +++ b/src/Data/Measured.hs @@ -0,0 +1,5 @@ +{-# Language FunctionalDependencies #-} +module Data.Measured( module Data.Measured.Class + ) where + +import Data.Measured.Class diff --git a/src/Data/Measured/Class.hs b/src/Data/Measured/Class.hs new file mode 100644 --- /dev/null +++ b/src/Data/Measured/Class.hs @@ -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 diff --git a/src/Data/Measured/Size.hs b/src/Data/Measured/Size.hs new file mode 100644 --- /dev/null +++ b/src/Data/Measured/Size.hs @@ -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 diff --git a/src/Data/PlanarGraph/Core.hs b/src/Data/PlanarGraph/Core.hs --- a/src/Data/PlanarGraph/Core.hs +++ b/src/Data/PlanarGraph/Core.hs @@ -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. diff --git a/src/Data/RealNumber/Rational.hs b/src/Data/RealNumber/Rational.hs new file mode 100644 --- /dev/null +++ b/src/Data/RealNumber/Rational.hs @@ -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 diff --git a/src/Data/Sequence/Util.hs b/src/Data/Sequence/Util.hs --- a/src/Data/Sequence/Util.hs +++ b/src/Data/Sequence/Util.hs @@ -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 diff --git a/src/Data/SlowSeq.hs b/src/Data/SlowSeq.hs deleted file mode 100644 --- a/src/Data/SlowSeq.hs +++ /dev/null @@ -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 diff --git a/src/Data/Tree/Util.hs b/src/Data/Tree/Util.hs --- a/src/Data/Tree/Util.hs +++ b/src/Data/Tree/Util.hs @@ -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 diff --git a/src/Data/UnBounded.hs b/src/Data/UnBounded.hs --- a/src/Data/UnBounded.hs +++ b/src/Data/UnBounded.hs @@ -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 -------------------------------------------------------------------------------- diff --git a/src/Data/Util.hs b/src/Data/Util.hs --- a/src/Data/Util.hs +++ b/src/Data/Util.hs @@ -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 #-} -------------------------------------------------------------------------------- diff --git a/test/Data/IndexedDoublyLinkedListSpec.hs b/test/Data/IndexedDoublyLinkedListSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/IndexedDoublyLinkedListSpec.hs @@ -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') diff --git a/test/Data/PlanarGraphSpec.hs b/test/Data/PlanarGraphSpec.hs --- a/test/Data/PlanarGraphSpec.hs +++ b/test/Data/PlanarGraphSpec.hs @@ -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