uniquely-represented-sets (empty) → 0.1.0.0
raw patch · 14 files changed
+1500/−0 lines, 14 filesdep +QuickCheckdep +basedep +checkerssetup-changed
Dependencies added: QuickCheck, base, checkers, containers, criterion, deepseq, doctest, random, uniquely-represented-sets
Files
- LICENSE +21/−0
- README.md +7/−0
- Setup.hs +2/−0
- bench/bench.hs +43/−0
- src/Data/Set/Unique.hs +242/−0
- src/Data/Set/Unique/Properties.hs +45/−0
- src/Data/Tree/Binary.hs +296/−0
- src/Data/Tree/Braun.hs +257/−0
- src/Data/Tree/Braun/Internal.hs +17/−0
- src/Data/Tree/Braun/Properties.hs +11/−0
- src/Data/Tree/Braun/Sized.hs +289/−0
- src/Data/Tree/Braun/Sized/Properties.hs +24/−0
- test/Spec.hs +169/−0
- uniquely-represented-sets.cabal +77/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2018 Donnacha Oisín Kidney++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,7 @@+[](https://travis-ci.org/oisdk/uniquely-represented-sets)++# uniquely-represented-sets++This package provides a set with a unique representation.++This package is based on code by Jim Apple (https://github.com/jbapple/unique). The license for that code is available in PRIORLICENSE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench.hs view
@@ -0,0 +1,43 @@+module Main (main) where++import Control.Monad (replicateM)+import Criterion.Main+import Data.Foldable+import Data.Set.Unique+import System.Random++insert'+ :: Ord a+ => a -> [a] -> [a]+insert' x (y:ys)+ | x > y = y : insert' x ys+insert' x ys = x : ys++member' :: Ord a => a -> [a] -> Bool+member' x = foldr f False where+ f y ys = case compare x y of+ LT -> False+ GT -> ys+ EQ -> True++intr :: Int -> IO Int+intr u = randomRIO (0,u)++atSize :: Int -> Benchmark+atSize n =+ env+ ((,,) <$> replicateM n (intr n) <*>+ fmap fromList (replicateM n (intr n)) <*> fmap (foldr insert' []) (replicateM n (intr n))) $+ \ ~(xs,ys,zs) ->+ bgroup+ (show n)+ [ bench "member" $ nf (length . filter (`member` ys)) xs+ , bench "listMember" $ nf (length . filter (`member'` zs)) xs+ , bench "insert" $ nf (foldl' (flip insert) empty) xs+ , bench "listInsert" $ nf (foldl' (flip insert') []) xs+ , bench "fromList" $ nf fromList xs+ , bench "fromListBy" $ nf (fromListBy compare) xs]+++main :: IO ()+main = defaultMain (map atSize [1000, 10000])
+ src/Data/Set/Unique.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++-- | This module provides a uniquely-represented Set type.+--+-- Uniquely represented sets means that elements inserted in any order+-- are represented by the same set. This makes it useful for+-- type-level programming, and some security applications.+module Data.Set.Unique+ (+ -- * Set type+ Set(..)+ ,+ -- * Construction+ fromList+ ,fromListBy+ ,empty+ ,singleton+ ,fromDistinctAscList+ ,+ -- ** Building+ Builder+ ,consB+ ,nilB+ ,runB+ ,+ -- * Modification+ insert+ ,insertBy+ ,delete+ ,deleteBy+ ,+ -- * Querying+ lookupBy+ ,member+ ,+ -- * Size invariant+ szfn)+ where++import Control.DeepSeq (NFData (rnf))+import Data.Data (Data)+import Data.Foldable+import Data.List (sortBy)+import Data.Maybe (isJust)+import qualified Data.Set as Set+import Data.Tree.Binary (Tree (..))+import Data.Tree.Braun.Sized (Braun (Braun))+import qualified Data.Tree.Braun.Sized as Braun+import Data.Typeable (Typeable)+import GHC.Base (build)+import GHC.Generics (Generic, Generic1)++-- | A uniquely-represented set.+newtype Set a = Set+ { tree :: Braun (Braun a)+ } deriving (Show,Read,Eq,Ord,Functor,Typeable,Generic,Generic1,Data)++instance NFData a => NFData (Set a) where+ rnf (Set xs) = rnf xs++-- | A type suitable for building a 'Set' by repeated applications+-- of 'consB'.+type Builder a b c = Int -> Int -> (Braun.Builder a (Braun a) -> Braun.Builder (Braun a) b -> c) -> c++-- | The size invariant. The nth Braun tree in the set has size+-- szfn n.+szfn :: Int -> Int+szfn i = max 1 (round (j * sqrt (logBase 2 j)))+ where+ !j = toEnum i :: Double+{-# INLINE szfn #-}++-- | /O(n log n)/. Create a set from a list.+fromList :: Ord a => [a] -> Set a+fromList xs = runB (Set.foldr consB nilB (Set.fromList xs))+{-# INLINE fromList #-}++-- | /O(n log n)/. Create a set from a list, using the supplied+-- ordering function.+--+-- prop> fromListBy compare xs === fromList xs+fromListBy :: (a -> a -> Ordering) -> [a] -> Set a+fromListBy cmp xs = runB (foldr f (const nilB) (sortBy cmp xs) (const False))+ where+ f x a q+ | q x = zs+ | otherwise = consB x zs+ where+ zs = a ((EQ ==) . cmp x)++-- | /O(1)/. Push an element to the front of a 'Builder'.+consB :: a -> Builder a c d -> Builder a c d+consB e a !k 1 p =+ a+ (k + 1)+ (szfn k)+ (\ys zs ->+ p Braun.nilB (Braun.consB (Braun.runB (Braun.consB e ys)) zs))+consB e a !k !i p = a k (i - 1) (p . Braun.consB e)+{-# INLINE consB #-}++-- | An empty 'Builder'.+nilB :: Builder a b c+nilB _ _ p = p Braun.nilB Braun.nilB+{-# INLINE nilB #-}++-- | Convert a 'Builder' to a 'Set'.+runB :: Builder a (Braun (Braun a)) (Set a)-> Set a+runB xs = xs 1 1 (const (Set . Braun.runB))+{-# INLINE runB #-}++-- | The empty set.+empty :: Set a+empty = Set (Braun 0 Leaf)+{-# INLINE empty #-}++-- | Create a set with one element.+singleton :: a -> Set a+singleton x = Set (Braun 1 (Node (Braun 1 (Node x Leaf Leaf)) Leaf Leaf))+{-# INLINE singleton #-}++-- | 'toList' is /O(n)/.+--+-- prop> toList (fromDistinctAscList xs) === xs+instance Foldable Set where+ foldr f b (Set xs) = foldr (flip (foldr f)) b xs+ {-# INLINE foldr #-}+ toList (Set xs) = build (\c n -> foldr (flip (foldr c)) n xs)+ {-# INLINABLE toList #-}+ length (Set (Braun _ xs)) = foldl' (\a e -> a + Braun.size e) 0 xs++instance Traversable Set where+ traverse f (Set xs) = fmap Set ((traverse . traverse) f xs)++-- | /O(n)/. Create a set from a list of ordered, distinct elements.+--+-- prop> fromDistinctAscList (toList xs) === xs+fromDistinctAscList :: [a] -> Set a+fromDistinctAscList xs = runB (foldr consB nilB xs)+{-# INLINABLE fromDistinctAscList #-}++-- | /sqrt(n log n)/. Insert an element into the set.+--+-- >>> toList (foldr insert empty [3,1,2,5,4,3,6])+-- [1,2,3,4,5,6]+insert :: Ord a => a -> Set a -> Set a+insert = insertBy compare+{-# INLINE insert #-}++-- | /sqrt(n log n)/. Insert an element into the set, using the+-- supplied ordering function.+--+-- prop> insert x xs === insertBy compare x xs+insertBy :: (a -> a -> Ordering) -> a -> Set a -> Set a+insertBy cmp x pr@(Set xs) =+ case ys of+ [] -> singleton x+ (y:yys) ->+ case breakThree (Braun.ltRoot cmp x) ys of+ Nothing ->+ Set (Braun.runB (foldr fixf fixb yys 1 (Braun.cons x y)))+ Just (lt,eq,i,gt)+ | Braun.size eq == Braun.size new -> pr+ | otherwise ->+ Set+ (Braun.runB+ (foldr Braun.consB (foldr fixf fixb gt i new) lt))+ where new = Braun.insertBy cmp x eq+ where+ ys = toList xs+ fixf z zs !i y =+ let (q,qs) = Braun.unsnoc' y+ in Braun.consB qs (zs (i + 1) (Braun.cons q z))+ {-# INLINE fixf #-}+ fixb !i y+ | Braun.size y > szfn i =+ let (q,qs) = Braun.unsnoc' y+ in Braun.consB qs (Braun.consB (Braun.singleton q) Braun.nilB)+ | otherwise = Braun.consB y Braun.nilB+ {-# INLINE fixb #-}+{-# INLINE insertBy #-}++-- | /sqrt(n log n)/. Delete an element from the set.+delete :: Ord a => a -> Set a -> Set a+delete = deleteBy compare++-- | /sqrt(n log n)/. Delete an element from the set, using the+-- supplied ordering function.+--+-- prop> delete x xs === deleteBy compare x xs+deleteBy :: (a -> a -> Ordering) -> a -> Set a -> Set a+deleteBy cmp x pr@(Set xs) =+ case breakThree (Braun.ltRoot cmp x) (toList xs) of+ Nothing -> pr+ Just (lt,eq,_,gt)+ | Braun.size eq == Braun.size new -> pr+ | otherwise -> Set (Braun.runB (foldr Braun.consB (foldr fixf fixb gt new) lt))+ where new = Braun.deleteBy cmp x eq+ fixb (Braun _ Leaf) = Braun.nilB+ fixb y = Braun.consB y Braun.nilB+ fixf z zs y =+ let (p,ps) = Braun.uncons' z+ in Braun.snoc p y `Braun.consB` zs ps++-- | /O(log^2 n)/. Lookup an element according to the supplied+-- ordering function in the set.+lookupBy :: (a -> a -> Ordering) -> a -> Set a -> Maybe a+lookupBy cmp x (Set xs) = do+ ys <- Braun.glb (Braun.cmpRoot cmp) x xs+ y <- Braun.glb cmp x ys+ case cmp x y of+ EQ -> pure y+ _ -> Nothing++-- | /O(log^2 n)/. Find if an element is a member of the set.+member :: Ord a => a -> Set a -> Bool+member x xs = isJust (lookupBy compare x xs)+{-# INLINE member #-}++breakThree :: (a -> Bool) -> [a] -> Maybe ([a], a, Int, [a])+breakThree _ [] = Nothing+breakThree p (x:xs)+ | p x = Nothing+ | otherwise = Just (go 1 id p x xs)+ where+ go !i k p' y zs@(z:zs')+ | p' z = (k [],y,i, zs)+ | otherwise = go (i+1) (k . (y:)) p' z zs'+ go !i k _ y [] = (k [],y,i,[])+{-# INLINE breakThree #-}++-- $setup+-- >>> import Test.QuickCheck+-- >>> :{+-- instance (Arbitrary a, Ord a) =>+-- Arbitrary (Set a) where+-- arbitrary = fmap fromList arbitrary+-- shrink = fmap fromList . shrink . toList+-- :}
+ src/Data/Set/Unique/Properties.hs view
@@ -0,0 +1,45 @@+-- | This module provides functions for testing invariants and+-- properties on the uniquely-represented sets.+module Data.Set.Unique.Properties where++import Data.Set.Unique+import qualified Data.Tree.Braun.Sized as Braun+import qualified Data.Tree.Braun.Sized.Properties as Braun++import Data.Foldable++import Data.List (sortBy)+import Data.Functor.Classes++-- | Check that the sizes of the inner Braun trees obey the size+-- bound.+sizesInBound :: Set a -> Bool+sizesInBound (Set b) = null xs || it && re where+ xs = toList b+ it = and $ zipWith (\x y -> Braun.size x == szfn y) (safeInit xs) [1..]+ safeInit [] = []+ safeInit ys = init ys+ re = Braun.size (last xs) <= szfn (length xs)++-- | Check that all inner trees are Braun trees.+allBraun :: Set a -> Bool+allBraun (Set b) = Braun.isBraun b && all Braun.isBraun b++-- | Check that the elements are stored in the correct order.+inOrder :: (a -> a -> Ordering) -> Set a -> Bool+inOrder cmp xs =+ liftEq+ (\x y ->+ cmp x y == EQ)+ ys+ (sortBy cmp ys)+ where+ ys = toList xs++-- | Check that all inner trees store the correct size.+allCorrectSizes :: Set a -> Bool+allCorrectSizes (Set b) = Braun.validSize b && all Braun.validSize b++-- | Check that the stored size is correct.+validSize :: Set a -> Bool+validSize s = length s == foldl' (\a _ -> a + 1) 0 s
+ src/Data/Tree/Binary.hs view
@@ -0,0 +1,296 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE Safe #-}++-- | A simple, generic binary tree and some operations.+module Data.Tree.Binary+ (+ -- * The tree type+ Tree(..)+ ,+ -- * Construction+ unfoldTree+ ,replicate+ ,replicateA+ ,singleton+ ,empty+ ,fromList+ ,+ -- * Consumption+ foldTree+ ,zygoTree+ ,+ -- * Display+ drawBinaryTree)+ where++import Control.DeepSeq (NFData (..))+import Data.Data (Data)+import Data.Functor.Classes+import Data.Monoid+import Data.Typeable (Typeable)+import GHC.Generics (Generic, Generic1)++import Control.Applicative hiding (empty)+import Data.Functor.Identity+import Data.List (uncons)+import Data.Maybe (fromMaybe)+import Text.Read+import Text.Read.Lex++import Prelude hiding (replicate)++-- | A simple binary tree.+data Tree a+ = Leaf+ | Node a+ (Tree a)+ (Tree a)+ deriving (Show,Read,Eq,Ord,Functor,Foldable,Traversable,Typeable+ ,Generic,Generic1,Data)++-- | A binary tree with one element.+singleton :: a -> Tree a+singleton x = Node x Leaf Leaf+{-# INLINE singleton #-}++-- | A binary tree with no elements.+empty :: Tree a+empty = Leaf+{-# INLINE empty #-}++instance NFData a =>+ NFData (Tree a) where+ rnf Leaf = ()+ rnf (Node x l r) = rnf x `seq` rnf l `seq` rnf r++instance Eq1 Tree where+ liftEq _ Leaf Leaf = True+ liftEq eq (Node x xl xr) (Node y yl yr) =+ eq x y && liftEq eq xl yl && liftEq eq xr yr+ liftEq _ _ _ = False++instance Ord1 Tree where+ liftCompare _ Leaf Leaf = EQ+ liftCompare cmp (Node x xl xr) (Node y yl yr) =+ cmp x y <> liftCompare cmp xl yl <> liftCompare cmp xr yr+ liftCompare _ Leaf _ = LT+ liftCompare _ _ Leaf = GT++instance Show1 Tree where+ liftShowsPrec s _ = go where+ go _ Leaf = showString "Leaf"+ go d (Node x l r)+ = showParen (d >= 11)+ $ showString "Node "+ . s 11 x+ . showChar ' '+ . go 11 l+ . showChar ' '+ . go 11 r++instance Read1 Tree where+ liftReadPrec rp _ = go+ where+ go =+ parens $+ prec 10 (Leaf <$ expect' (Ident "Leaf")) ++++ prec+ 10+ (expect' (Ident "Node") *>+ liftA3 Node (step rp) (step go) (step go))+ expect' = lift . expect++-- | Fold over a tree.+--+-- prop> foldTree Leaf Node xs === xs+foldTree :: b -> (a -> b -> b -> b) -> Tree a -> b+foldTree b f = go where+ go Leaf = b+ go (Node x l r) = f x (go l) (go r)++-- | A zygomorphism over a tree. Used if you want perform two folds+-- over a tree in one pass.+--+-- As an example, checking if a tree is balanced can be performed like+-- this using explicit recursion:+--+-- @+-- isBalanced :: 'Tree' a -> Bool+-- isBalanced 'Leaf' = True+-- isBalanced ('Node' _ l r)+-- = 'length' l == 'length' r && isBalanced l && isBalanced r+-- @+--+-- However, this algorithm performs several extra passes over the+-- tree. A more efficient version is much harder to read, however:+--+-- @+-- isBalanced :: Tree a -> Bool+-- isBalanced = snd . go where+-- go 'Leaf' = (0 :: Int,True)+-- go ('Node' _ l r) =+-- let (llen,lbal) = go l+-- (rlen,rbal) = go r+-- in (llen + rlen + 1, llen == rlen && lbal && rbal)+-- @+--+-- This same algorithm (the one pass version) can be expressed as a+-- zygomorphism:+--+-- @+-- isBalanced :: 'Tree' a -> Bool+-- isBalanced =+-- 'zygoTree'+-- (0 :: Int)+-- (\\_ x y -> 1 + x + y)+-- True+-- go+-- where+-- go _ llen lbal rlen rbal = llen == rlen && lbal && rbal+-- @+zygoTree+ :: p+ -> (a -> p -> p -> p)+ -> b+ -> (a -> p -> b -> p -> b -> b)+ -> Tree a+ -> b+zygoTree p f1 b f = snd . go where+ go Leaf = (p,b)+ go (Node x l r) =+ let (lr1,lr) = go l+ (rr1,rr) = go r+ in (f1 x lr1 rr1, f x lr1 lr rr1 rr)++-- | Unfold a tree from a seed.+unfoldTree :: (b -> Maybe (a, b, b)) -> b -> Tree a+unfoldTree f = go where+ go = maybe Leaf (\(x,l,r) -> Node x (go l) (go r)) . f++-- | @'replicate' n a@ creates a tree of size @n@ filled @a@.+--+-- >>> putStr (drawBinaryTree (replicate 4 ()))+-- ()+-- () ()+-- ()+--+-- prop> \(NonNegative n) -> length (replicate n ()) === n+replicate :: Int -> a -> Tree a+replicate n x = runIdentity (replicateA n (Identity x))++-- | @'replicateA' n a@ replicates the action @a@ @n@ times, trying+-- to balance the result as much as possible. The actions are executed+-- in a preorder traversal (same as the 'Foldable' instance.)+--+-- >>> toList (evalState (replicateA 10 (State (\s -> (s, s + 1)))) 1)+-- [1,2,3,4,5,6,7,8,9,10]+replicateA :: Applicative f => Int -> f a -> f (Tree a)+replicateA n x = go n+ where+ go m+ | m <= 0 = pure Leaf+ | even m = Node <$> x <*> r <*> go (d-1)+ | otherwise = Node <$> x <*> r <*> r+ where+ d = m `div` 2+ r = go d+{-# SPECIALIZE replicateA :: Int -> Identity a -> Identity (Tree a) #-}++-- | This instance is necessarily inefficient, to obey the monoid laws.+--+-- >>> putStr (drawBinaryTree (fromList [1..6]))+-- 1+-- 2 5+-- 3 4 6+--+-- >>> putStr (drawBinaryTree (fromList [1..6] `mappend` singleton 7))+-- 1+-- 2 5+-- 3 4 6 7+--+-- 'mappend' distributes over 'toList':+--+-- prop> toList (mappend xs (ys :: Tree Int)) === mappend (toList xs) (toList ys)+instance Monoid (Tree a) where+ mappend Leaf y = y+ mappend (Node x l r) y = Node x l (mappend r y)+ mempty = Leaf++-- | Construct a tree from a list, in an preorder fashion.+--+-- prop> toList (fromList xs) === xs+fromList :: [a] -> Tree a+fromList xs = evalState (replicateA n u) xs+ where+ n = length xs+ u = State (fromMaybe (error "Data.Tree.Binary.fromList: bug!") . uncons)++-- | Pretty-print a tree.+--+-- >>> putStr (drawBinaryTree (fromList [1..7]))+-- 1+-- 2 5+-- 3 4 6 7+drawBinaryTree :: Show a => Tree a -> String+drawBinaryTree = foldr (. (:) '\n') "" . snd . foldTree (0, []) f+ where+ f el (llen,lb) (rlen,rb) =+ ( llen + rlen + xlen+ , pad llen . (xshw ++) . pad rlen :+ zipLongest (pad llen) (pad rlen) join' lb rb)+ where+ xshw = show el+ xlen = length xshw+ join' x y = x . pad xlen . y+ pad 0 = id+ pad n = (' ' :) . pad (n - 1)++zipLongest :: a -> b -> (a -> b -> c) -> [a] -> [b] -> [c]+zipLongest ldef rdef fn = go+ where+ go (x:xs) (y:ys) = fn x y : go xs ys+ go [] ys = map (fn ldef) ys+ go xs [] = map (`fn` rdef) xs++newtype State s a = State+ { runState :: s -> (a, s)+ } deriving (Functor)++instance Applicative (State s) where+ pure x = State (\s -> (x, s))+ fs <*> xs =+ State+ (\s ->+ case runState fs s of+ (f,s') ->+ case runState xs s' of+ (x,s'') -> (f x, s''))++evalState :: State s a -> s -> a+evalState xs s = fst (runState xs s)++-- $setup+-- >>> :set -XDeriveFunctor+-- >>> import Test.QuickCheck+-- >>> import Data.Foldable+-- >>> :{+-- instance Arbitrary a =>+-- Arbitrary (Tree a) where+-- arbitrary = sized go+-- where+-- go 0 = pure Leaf+-- go n+-- | n <= 0 = pure Leaf+-- | otherwise = oneof [pure Leaf, liftA3 Node arbitrary sub sub]+-- where+-- sub = go (n `div` 2)+-- shrink Leaf = []+-- shrink (Node x l r) =+-- Leaf : l : r :+-- [ Node x' l' r'+-- | (x',l',r') <- shrink (x, l, r) ]+-- :}
+ src/Data/Tree/Braun.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE BangPatterns #-}++-- | This module provides functions for manipulating and using Braun+-- trees.+module Data.Tree.Braun+ (+ -- * Construction+ fromList+ ,replicate+ ,singleton+ ,empty+ -- ** Building+ ,Builder+ ,consB+ ,nilB+ ,runB+ ,+ -- * Modification+ cons+ ,uncons+ ,uncons'+ ,tail+ ,+ -- * Consuming+ foldrBraun+ ,toList+ ,+ -- * Querying+ (!)+ ,(!?)+ ,size+ ,UpperBound(..)+ ,ub)+ where++import Data.Tree.Binary (Tree (..))+import qualified Data.Tree.Binary as Binary+import GHC.Base (build)+import Prelude hiding (tail, replicate)+import Data.Tree.Braun.Internal (zipLevels)+import GHC.Stack++-- | A Braun tree with one element.+singleton :: a -> Tree a+singleton = Binary.singleton+{-# INLINE singleton #-}++-- | A Braun tree with no elements.+empty :: Tree a+empty = Leaf+{-# INLINE empty #-}++-- | /O(n)/. Create a Braun tree (in order) from a list. The algorithm+-- is similar to that in:+--+-- Okasaki, Chris. ‘Three Algorithms on Braun Trees’. Journal of+-- Functional Programming 7, no. 6 (November 1997): 661–666.+-- https://doi.org/10.1017/S0956796897002876.+--+-- However, it uses a fold rather than explicit recursion, allowing+-- fusion.+--+-- Inlined sufficiently, the implementation is:+--+-- @+-- fromList :: [a] -> 'Tree' a+-- fromList xs = 'foldr' f b xs 1 1 ('const' 'head') where+-- f e a !k 1 p = a (k'*'2) k (\ys zs -> p n (g e ys zs ('drop' k zs)))+-- f e a !k !m p = a k (m'-'1) (p . g e)+--+-- g x a (y:ys) (z:zs) = 'Node' x y z : a ys zs+-- g x a [] (z:zs) = 'Node' x 'Leaf' z : a [] zs+-- g x a (y:ys) [] = 'Node' x y 'Leaf' : a ys []+-- g x a [] [] = 'Node' x 'Leaf' 'Leaf' : a [] []+-- {-\# NOINLINE g #-}+--+-- n _ _ = []+-- b _ _ p = p n [Leaf]+-- {-\# INLINABLE fromList #-}+-- @+--+-- prop> toList (fromList xs) == xs+fromList :: [a] -> Tree a+fromList xs = runB (foldr consB nilB xs)+{-# INLINABLE fromList #-}++-- | A type suitable for building a Braun tree by repeated applications+-- of 'consB'.+type Builder a b = (Int -> Int -> (([Tree a] -> [Tree a] -> [Tree a]) -> [Tree a] -> b) -> b)++-- | /O(1)/. Push an element to the front of a 'Builder'.+consB :: a -> Builder a b -> Builder a b+consB e a !k 1 p = a (k*2) k (\ys zs -> p (\_ _ -> []) (zipLevels e ys zs (drop k zs)))+consB e a !k !m p = a k (m-1) (p . zipLevels e)+{-# INLINE consB #-}++-- | An empty 'Builder'.+nilB :: Builder a b+nilB _ _ p = p (\_ _ -> []) [Leaf]+{-# INLINE nilB #-}++-- | Convert a 'Builder' to a Braun tree.+runB :: Builder a (Tree a) -> Tree a+runB b = b 1 1 (const head)+{-# INLINE runB #-}+++-- | Perform a right fold, in Braun order, over a tree.+foldrBraun :: Tree a -> (a -> b -> b) -> b -> b+foldrBraun tr c n =+ case tr of+ Leaf -> n+ _ -> tol [tr]+ where tol [] = n+ tol xs = foldr (c . root) (tol (children xs id)) xs+ children [] k = k []+ children (Node _ Leaf _:_) k = k []+ children (Node _ l Leaf:ts) k =+ l : foldr leftChildren (k []) ts+ children (Node _ l r:ts) k = l : children ts (k . (:) r)+ children _ _ =+ errorWithoutStackTrace "Data.Tree.Braun.toList: bug!"+ leftChildren (Node _ Leaf _) _ = []+ leftChildren (Node _ l _) a = l : a+ leftChildren _ _ =+ errorWithoutStackTrace "Data.Tree.Braun.toList: bug!"+ root (Node x _ _) = x+ root _ = errorWithoutStackTrace "Data.Tree.Braun.toList: bug!"+{-# INLINE foldrBraun #-}++-- | /O(n)/. Convert a Braun tree to a list.+--+-- prop> fromList (toList xs) === xs+toList :: Tree a -> [a]+toList tr = build (foldrBraun tr)+{-# INLINABLE toList #-}++-- | /O(log^2 n)/. Calculate the size of a Braun tree.+size :: Tree a -> Int+size Leaf = 0+size (Node _ l r) = 1 + 2 * m + diff l m where+ m = size r+ diff Leaf 0 = 0+ diff (Node _ Leaf Leaf) 0 = 1+ diff (Node _ s t) k+ | odd k = diff s (k `div` 2)+ | otherwise = diff t ((k `div` 2) - 1)+ diff Leaf _ = errorWithoutStackTrace "Data.Tree.Braun.size: bug!"++-- | /O(log^2 n)/. @'replicate' n x@ creates a Braun tree from @n@+-- copies of @x@.+--+-- prop> \(NonNegative n) -> size (replicate n ()) == n+replicate :: Int -> a -> Tree a+replicate m x = go m (const id)+ where+ go 0 k = k (Node x Leaf Leaf) Leaf+ go n k+ | odd n = go (pred n `div` 2) $ \s t -> k (Node x s t) (Node x t t)+ | otherwise = go (pred n `div` 2) $ \s t -> k (Node x s s) (Node x s t)++-- | /O(log n)/. Retrieve the element at the specified position,+-- raising an error if it's not present.+--+-- prop> \(NonNegative n) xs -> n < length xs ==> fromList xs ! n == xs !! n+(!) :: HasCallStack => Tree a -> Int -> a+(!) (Node x _ _) 0 = x+(!) (Node _ y z) i+ | odd i = y ! j+ | otherwise = z ! j+ where j = (i-1) `div` 2+(!) _ _ = error "Data.Tree.Braun.!: index out of range"++-- | /O(log n)/. Retrieve the element at the specified position, or+-- 'Nothing' if the index is out of range.+(!?) :: Tree a -> Int -> Maybe a+(!?) (Node x _ _) 0 = Just x+(!?) (Node _ y z) i+ | odd i = y !? j+ | otherwise = z !? j+ where j = (i-1) `div` 2+(!?) _ _ = Nothing++-- | Result of an upper bound operation.+data UpperBound a = Exact a+ | TooHigh Int+ | Finite++-- | Find the upper bound for a given element.+ub :: (a -> b -> Ordering) -> a -> Tree b -> UpperBound b+ub f x t = go f x t 0 1+ where+ go _ _ Leaf !_ !_ = Finite+ go _ _ (Node hd _ ev) !n !k =+ case f x hd of+ LT -> TooHigh n+ EQ -> Exact hd+ GT -> go f x ev (n+2*k) (2*k)++-- | /O(log n)/. Returns the first element in the array and the rest+-- the elements, if it is nonempty, or 'Nothing' if it is empty.+--+-- >>> uncons empty+-- Nothing+--+-- prop> uncons (cons x xs) === Just (x,xs)+-- prop> unfoldr uncons (fromList xs) === xs+uncons :: Tree a -> Maybe (a, Tree a)+uncons (Node x Leaf Leaf) = Just (x, Leaf)+uncons (Node x y z) = Just (x, Node lp z q)+ where+ Just (lp,q) = uncons y+uncons Leaf = Nothing++-- | /O(log n)/. Returns the first element in the array and the rest+-- the elements, if it is nonempty, failing with an error if it is+-- empty.+--+-- prop> uncons' (cons x xs) === (x,xs)+uncons' :: HasCallStack => Tree a -> (a, Tree a)+uncons' (Node x Leaf Leaf) = (x, Leaf)+uncons' (Node x y z) = (x, Node lp z q)+ where+ (lp,q) = uncons' y+uncons' Leaf = error "Data.Tree.Braun.uncons': empty tree"++-- | /O(log n)/. Append an element to the beginning of the Braun tree.+--+-- prop> uncons' (cons x xs) === (x,xs)+cons :: a -> Tree a -> Tree a+cons x Leaf = Node x Leaf Leaf+cons x (Node y p q) = Node x (cons y q) p++-- | /O(log n)/. Get all elements except the first from the Braun+-- tree. Returns an empty tree when called on an empty tree.+--+-- >>> tail empty+-- Leaf+--+-- prop> tail (cons x xs) === xs+-- prop> tail (cons undefined xs) === xs+tail :: Tree a -> Tree a+tail (Node _ Leaf Leaf) = Leaf+tail (Node _ y z) = Node lp z q+ where+ (lp,q) = uncons' y+tail Leaf = Leaf++-- $setup+-- >>> import Test.QuickCheck+-- >>> import Data.List (unfoldr)+-- >>> import qualified Data.Tree.Binary as Binary+-- >>> :{+-- instance Arbitrary a => Arbitrary (Tree a) where+-- arbitrary = fmap fromList arbitrary+-- shrink = fmap fromList . shrink . toList+-- :}
+ src/Data/Tree/Braun/Internal.hs view
@@ -0,0 +1,17 @@+-- | Internal functions, subject to change.+module Data.Tree.Braun.Internal where++import Data.Tree.Binary (Tree(..))++-- | A specialised zip-like function which takes a continuation+-- rather than using explicit recursion.+zipLevels :: a+ -> ([Tree a] -> [Tree a] -> [Tree a])+ -> [Tree a]+ -> [Tree a]+ -> [Tree a]+zipLevels x a (y:ys) (z:zs) = Node x y z : a ys zs+zipLevels x a [] (z:zs) = Node x Leaf z : a [] zs+zipLevels x a (y:ys) [] = Node x y Leaf : a ys []+zipLevels x a [] [] = Node x Leaf Leaf : a [] []+{-# NOINLINE zipLevels #-}
+ src/Data/Tree/Braun/Properties.hs view
@@ -0,0 +1,11 @@+-- | This module provides functions to test invariants of Braun trees.+module Data.Tree.Braun.Properties where++import Data.Tree.Binary++-- | Returns true iff the tree is a Braun tree.+isBraun :: Tree a -> Bool+isBraun = zygoTree (0 :: Int) (\_ l r -> 1 + l + r) True alg+ where+ alg _ lsize lbrn rsize rbrn =+ lbrn && rbrn && (lsize == rsize || lsize - 1 == rsize)
+ src/Data/Tree/Braun/Sized.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}++-- | This module provides a Braun tree which keeps track of its size,+-- and associated functions.+module Data.Tree.Braun.Sized+ (-- * Braun type+ Braun(..)+ -- * Construction+ ,fromList+ ,empty+ ,singleton+ -- ** Building+ ,Builder+ ,consB+ ,nilB+ ,runB+ -- * Modification+ -- ** At ends+ ,snoc+ ,unsnoc+ ,unsnoc'+ ,cons+ ,uncons+ ,uncons'+ -- ** As set+ ,insertBy+ ,deleteBy+ -- * Querying+ ,glb+ ,cmpRoot+ ,ltRoot+ )+ where++import Data.Tree.Binary (Tree (..))+import Data.Tree.Braun (UpperBound (..))+import qualified Data.Tree.Braun as Unsized+import Data.Tree.Braun.Internal (zipLevels)++import Control.DeepSeq (NFData (rnf))+import Data.Data (Data)+import Data.Typeable (Typeable)+import GHC.Generics (Generic, Generic1)++import Control.Applicative hiding (empty)++import GHC.Stack+import Data.Foldable++-- | A Braun tree which keeps track of its size.+data Braun a = Braun+ { size :: {-# UNPACK #-} !Int+ , tree :: Tree a+ } deriving (Show,Read,Eq,Ord,Functor,Typeable,Generic,Generic1+ ,Data)++instance NFData a => NFData (Braun a) where+ rnf (Braun _ tr) = rnf tr++-- | 'toList' is /O(n)/.+--+-- prop> fromList (toList xs) === xs+instance Foldable Braun where+ foldr f b (Braun _ xs) = Unsized.foldrBraun xs f b+ length = size+ toList (Braun _ xs) = Unsized.toList xs+ {-# INLINABLE toList #-}++instance Traversable Braun where+ traverse f (Braun n tr) = fmap k (Unsized.foldrBraun tr c b)+ where+ c = liftA2 Unsized.consB . f+ b = pure Unsized.nilB+ k = Braun n . Unsized.runB++-- | /O(log n)/. Append an item to the end of a Braun tree.+--+-- prop> x `snoc` fromList xs === fromList (xs ++ [x])+snoc :: a -> Braun a -> Braun a+snoc x (Braun 0 Leaf) = Braun 1 (Node x Leaf Leaf)+snoc x (Braun n (Node y z w))+ | even n = Braun (n + 1) (Node y z (tree (snoc x (Braun (m - 1) w))))+ | otherwise = Braun (n + 1) (Node y (tree (snoc x (Braun m z))) w)+ where+ m = n `div` 2+snoc _ (Braun _ Leaf) = errorWithoutStackTrace "Data.Tree.Braun.Sized.snoc: bug!"++-- | A type suitable for building a Braun tree by repeated applications+-- of 'consB'.+type Builder a b = (Int -> Int -> Int -> (([Tree a] -> [Tree a] -> [Tree a]) -> [Tree a] -> Int -> b) -> b)++-- | /O(1)/. Push an element to the front of a 'Builder'.+consB :: a -> Builder a b -> Builder a b+consB e a !k 1 !s p = a (k*2) k (s+1) (\ys zs -> p (\_ _ -> []) (zipLevels e ys zs (drop k zs)))+consB e a !k !m !s p = a k (m-1) (s+1) (p . zipLevels e)+{-# INLINE consB #-}++-- | An empty 'Builder'.+nilB :: Builder a b+nilB _ _ s p = p (\_ _ -> []) [Leaf] s+{-# INLINE nilB #-}++-- | Convert a 'Builder' to a Braun tree.+runB :: Builder a (Braun a) -> Braun a+runB xs = xs 1 1 0 (const (flip Braun . head))+{-# INLINE runB #-}++-- | /O(n)/. Create a Braun tree (in order) from a list. The algorithm+-- is similar to that in:+--+-- Okasaki, Chris. ‘Three Algorithms on Braun Trees’. Journal of+-- Functional Programming 7, no. 6 (November 1997): 661–666.+-- https://doi.org/10.1017/S0956796897002876.+--+-- However, it uses a fold rather than explicit recursion, allowing+-- fusion.+--+-- prop> toList (fromList xs) === xs+fromList :: [a] -> Braun a+fromList xs = runB (foldr consB nilB xs)+{-# INLINABLE fromList #-}++-- | A Braun tree with no elements.+empty :: Braun a+empty = Braun 0 Leaf+{-# INLINE empty #-}++-- | A Braun tree with one element.+singleton :: a -> Braun a+singleton x = Braun 1 (Node x Leaf Leaf)+{-# INLINE singleton #-}++-- | /O(n)/. Insert an element into the Braun tree, using the+-- comparison function provided.+insertBy :: (a -> a -> Ordering) -> a -> Braun a -> Braun a+insertBy cmp x b@(Braun s xs) =+ case break+ (\y ->+ cmp x y /= GT)+ (Unsized.toList xs) of+ (_,[]) -> snoc x b+ (lt,gte@(y:_)) ->+ if cmp x y == EQ+ then b+ else Braun+ (s + 1)+ (Unsized.runB+ (foldr+ Unsized.consB+ (Unsized.consB+ x+ (foldr Unsized.consB Unsized.nilB gte))+ lt))++-- | /O(n)/. Delete an element from the Braun tree, using the+-- comparison function provided.+deleteBy :: (a -> a -> Ordering) -> a -> Braun a -> Braun a+deleteBy cmp x b@(Braun s xs) =+ case break+ (\y -> cmp x y /= GT)+ (Unsized.toList xs) of+ (_,[]) -> b+ (lt,y:gt) ->+ if cmp x y /= EQ+ then b+ else Braun+ (s - 1)+ (Unsized.runB (foldr Unsized.consB (foldr Unsized.consB Unsized.nilB gt) lt))++-- | /O(log^2 n)/. Find the greatest lower bound for an element.+glb :: (a -> b -> Ordering) -> a -> Braun b -> Maybe b+glb _ _ (Braun _ Leaf) = Nothing+glb cmp x (Braun n ys@(Node h _ _)) =+ case cmp x h of+ LT -> Nothing+ EQ -> Just h+ GT ->+ case Unsized.ub cmp x ys of+ Exact ans -> Just ans+ Finite+ | cmp x final == LT -> go 0 (n - 1)+ | otherwise -> Just final+ where final = ys Unsized.! (n - 1)+ TooHigh m -> go 0 m+ where+ go _ 0 = Nothing+ go i j+ | j <= i = Just $ ys Unsized.! (j - 1)+ | i + 1 == j = Just $ ys Unsized.! i+ | otherwise =+ case cmp x middle of+ LT -> go i k+ EQ -> Just middle+ GT -> go k j+ where+ k = (i + j) `div` 2+ middle = ys Unsized.! k+++-- | /O(log n)/. Append an element to the beginning of the Braun tree.+--+-- prop> uncons' (cons x xs) === (x,xs)+cons :: a -> Braun a -> Braun a+cons x (Braun n xs) = Braun (n+1) (Unsized.cons x xs)++-- | /O(log n)/. Returns the first element in the array and the rest+-- the elements, if it is nonempty, or 'Nothing' if it is empty.+--+-- >>> uncons empty+-- Nothing+--+-- prop> uncons (cons x xs) === Just (x,xs)+-- prop> unfoldr uncons (fromList xs) === xs+uncons :: Braun a -> Maybe (a, Braun a)+uncons (Braun n tr) = (fmap.fmap) (Braun (n-1)) (Unsized.uncons tr)++-- | /O(log n)/. Returns the first element in the array and the rest+-- the elements, if it is nonempty, failing with an error if it is+-- empty.+--+-- prop> uncons' (cons x xs) === (x,xs)+uncons' :: HasCallStack => Braun a -> (a, Braun a)+uncons' (Braun n tr) = fmap (Braun (n-1)) (Unsized.uncons' tr)++-- | Use a comparison function to compare an element to the root+-- element in a Braun tree, failing if the tree is empty.+cmpRoot :: (a -> b -> Ordering) -> a -> Braun b -> Ordering+cmpRoot cmp x (Braun _ (Node y _ _)) = cmp x y+cmpRoot _ _ _ = error "Data.Tree.Braun.Sized.compRoot: empty tree"+{-# INLINE cmpRoot #-}++-- | Use a comparison function to see if an element is less than+-- the root element in a Braun tree, failing if the tree is empty.+ltRoot :: (a -> b -> Ordering) -> a -> Braun b -> Bool+ltRoot cmp x (Braun _ (Node y _ _)) = cmp x y == LT+ltRoot _ _ _ = error "Data.Tree.Braun.Sized.ltRoot: empty tree"+{-# INLINE ltRoot #-}++-- | /O(log n)/. Returns the last element in the list and the other+-- elements, if present, or 'Nothing' if the tree is empty.+--+-- >>> unsnoc empty+-- Nothing+--+-- prop> unsnoc (snoc x xs) === Just (x, xs)+-- prop> unfoldr unsnoc (fromList xs) === reverse xs+unsnoc :: Braun a -> Maybe (a, Braun a)+unsnoc (Braun _ (Node x Leaf Leaf)) = Just (x, Braun 0 Leaf)+unsnoc (Braun n (Node x y z))+ | odd n =+ let Just (p,Braun _ q) = unsnoc (Braun m z)+ in Just (p, Braun (n - 1) (Node x y q))+ | otherwise =+ let Just (p,Braun _ q) = unsnoc (Braun m y)+ in Just (p, Braun (n - 1) (Node x q z))+ where+ m = n `div` 2+unsnoc (Braun _ Leaf) = Nothing++-- | /O(log n)/. Returns the last element in the list and the other+-- elements, if present, or raises an error if the tree is empty.+--+-- prop> isBraun (snd (unsnoc' (fromList (1:xs))))+-- prop> fst (unsnoc' (fromList (1:xs))) == last (1:xs)+unsnoc' :: HasCallStack => Braun a -> (a, Braun a)+unsnoc' (Braun _ (Node x Leaf Leaf)) = (x, Braun 0 Leaf)+unsnoc' (Braun n (Node x y z))+ | odd n =+ let (p,Braun _ q) = unsnoc' (Braun m z)+ in (p, Braun (n - 1) (Node x y q))+ | otherwise =+ let (p,Braun _ q) = unsnoc' (Braun m y)+ in (p, Braun (n - 1) (Node x q z))+ where+ m = n `div` 2+unsnoc' (Braun _ Leaf) = error "Data.Tree.Braun.Sized.unsnoc': empty tree"++-- $setup+-- >>> import Data.List (sort, nub, unfoldr)+-- >>> import Test.QuickCheck+-- >>> import Data.Tree.Braun.Sized.Properties+-- >>> :{+-- instance Arbitrary a => Arbitrary (Braun a) where+-- arbitrary = fmap fromList arbitrary+-- shrink = fmap fromList . shrink . toList+-- :}
+ src/Data/Tree/Braun/Sized/Properties.hs view
@@ -0,0 +1,24 @@+-- | This module provides functions to test Braun trees for invariants+-- and properties.+module Data.Tree.Braun.Sized.Properties where++import qualified Data.Tree.Braun.Properties as Unsized+import Data.Tree.Braun.Sized++import Data.Foldable+import Data.List (sortBy)+import Data.Functor.Classes++-- | Returns True iff the stored size in the Braun tree is its actual+-- size.+validSize :: Braun a -> Bool+validSize (Braun n xs) = n == length xs++-- | Returns True iff the tree is a proper Braun tree.+isBraun :: Braun a -> Bool+isBraun (Braun _ xs) = Unsized.isBraun xs++-- | Returns True iff the elements of the tree are in order.+inOrder :: (a -> a -> Ordering) -> Braun a -> Bool+inOrder cmp b = liftCompare cmp (sortBy cmp xs) xs == EQ where+ xs = toList b
+ test/Spec.hs view
@@ -0,0 +1,169 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Applicative+import Data.Foldable+import Data.Functor.Classes+import qualified Data.Set as Set+import qualified Data.Set.Unique as Unique+import qualified Data.Set.Unique.Properties as Unique+import Data.Tree.Binary+import qualified Data.Tree.Braun as Braun+import qualified Data.Tree.Braun.Sized as Sized+import qualified Data.Tree.Braun.Sized.Properties as Sized+import Test.DocTest+import Test.QuickCheck+import Test.QuickCheck.Checkers+import Test.QuickCheck.Classes+import Test.QuickCheck.Poly++toUniqOrdList :: Ord a => [a] -> [a]+toUniqOrdList = Set.toList . Set.fromList++instance Arbitrary a =>+ Arbitrary (Tree a) where+ arbitrary = sized go+ where+ go 0 = pure Leaf+ go n+ | n <= 0 = pure Leaf+ | otherwise = oneof [pure Leaf, liftA3 Node arbitrary sub sub]+ where+ sub = go (n `div` 2)+ shrink Leaf = []+ shrink (Node x l r) =+ Leaf : l : r :+ [ Node x' l' r'+ | (x',l',r') <- shrink (x, l, r) ]++instance Arbitrary a =>+ Arbitrary (Sized.Braun a) where+ arbitrary = fmap Sized.fromList arbitrary+ shrink = fmap Sized.fromList . shrink . toList++instance (Show a, Eq a) =>+ EqProp (Tree a) where+ x =-= y =+ whenFail+ (putStrLn (drawBinaryTree x ++ "\n/=\n" ++ drawBinaryTree y))+ (x == y)++instance (Arbitrary a, Ord a) =>+ Arbitrary (Unique.Set a) where+ arbitrary = fmap Unique.fromList arbitrary+ shrink = fmap Unique.fromList . shrink . toList++eq1Prop+ :: (Eq (f a), Eq1 f, Show (f a), Eq a)+ => Gen (f a) -> (f a -> [f a]) -> Property+eq1Prop arb shrnk =+ forAllShrink arb shrnk $+ \xs ->+ forAllShrink (oneof [pure xs, arb]) shrnk $+ \ys ->+ liftEq (==) xs ys === (xs == ys)++validSized :: Show a => Sized.Braun a -> Property+validSized br =+ whenFail+ (putStrLn+ ("Not a valid Braun tree:\n" ++ drawBinaryTree (Sized.tree br)))+ (Sized.isBraun br) .&&.+ counterexample "Invalid size" (Sized.validSize br)++validUnique :: Show a => Unique.Set a -> Property+validUnique s =+ conjoin+ [ counterexample "sizes not in bounds" $ Unique.sizesInBound s+ , counterexample "subtrees not braun" $ Unique.allBraun s+ , counterexample "subtrees not correct sizes" $ Unique.allCorrectSizes s+ , counterexample "incorrect size" $ Unique.validSize s]++validSetOpsProp :: [OrdA] -> OrdA -> Unique.Set OrdA -> Property+validSetOpsProp xs x s =+ conjoin+ [ validUnique s+ , counterexample "after insert" $ validUnique (Unique.insert x s)+ , counterexample "after delete" $ validUnique (Unique.delete x s)+ , counterexample "after fromAscList" $ validUnique (Unique.fromDistinctAscList xs)+ ]++validOpsProp :: Show a => a -> Sized.Braun a -> Property+validOpsProp x br =+ conjoin+ [ validSized br+ , counterexample "after snoc" (validSized (Sized.snoc x br))+ , counterexample "after cons" (validSized (Sized.cons x br))+ , counterexample+ "after uncons"+ (conjoin $ fmap (validSized . snd) (toList (Sized.uncons br)))+ , counterexample+ "after unsnoc"+ (conjoin $ fmap (validSized . snd) (toList (Sized.uncons br)))]++setMemberProp :: Property+setMemberProp =+ property $+ do xs <- arbitrary :: Gen [OrdA]+ x <- arbitrary :: Gen OrdA+ ys <- shuffle (x : xs)+ pure+ (Unique.member x (Unique.fromList ys) &&+ not (Unique.member x (Unique.fromList (filter (x /=) ys))))++setShuffleProp :: Property+setShuffleProp = property $ do+ xs <- arbitrary :: Gen [OrdA]+ ys <- shuffle xs+ pure (Unique.fromList xs === Unique.fromList ys)++setFromListWithProp :: Property+setFromListWithProp = property $ do+ xs <- arbitrary :: Gen [OrdA]+ pure (Unique.fromList xs === Unique.fromListBy compare xs)+++insertSizedProp :: [OrdA] -> Property+insertSizedProp xs =+ foldr (Sized.insertBy compare) Sized.empty xs ===+ Sized.fromList (toUniqOrdList xs)++deleteSizedProp :: OrdA -> [OrdA] -> Property+deleteSizedProp x xs = Sized.fromList setwo === deled .&&. validSized deled+ where+ setwi = toUniqOrdList (x : xs)+ setwo =+ toUniqOrdList+ [ y+ | y <- xs+ , y /= x ]+ deled = Sized.deleteBy compare x (Sized.fromList setwi)++main :: IO ()+main = do+ quickCheck (eq1Prop (arbitrary :: Gen (Tree Int)) shrink)+ quickBatch+ (ord+ (\x ->+ oneof [pure (x :: Tree Int), arbitrary]))+ quickBatch+ (ordRel+ (\x y ->+ liftCompare compare x y /= GT)+ (\x ->+ oneof [pure (x :: Tree Int), arbitrary]))+ quickCheck+ (\xs ->+ show (xs :: Tree Int) ===+ liftShowsPrec showsPrec showList 0 xs "")+ quickCheck+ (\xs ->+ Braun.size (fromList xs) === length (xs :: [Int]))+ quickCheck (validOpsProp (1 :: Int))+ quickCheck insertSizedProp+ quickCheck deleteSizedProp+ quickCheck validSetOpsProp+ quickCheck setMemberProp+ quickCheck setShuffleProp+ quickCheck setFromListWithProp+ quickBatch (monoid (Leaf :: Tree Int))+ doctest ["-isrc", "src/"]
+ uniquely-represented-sets.cabal view
@@ -0,0 +1,77 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 4010f54263b452aa6b55a31956d531f30317c733d7cefd79daaf11cb65070308++name: uniquely-represented-sets+version: 0.1.0.0+description: Please see the README on Github at <https://github.com/oisdk/uniquely-represented-sets#readme>+homepage: https://github.com/oisdk/uniquely-represented-sets#readme+bug-reports: https://github.com/oisdk/uniquely-represented-sets/issues+author: Donnacha Oisín Kidney+maintainer: mail@doisinkidney.com+copyright: 2018 Donnacha Oisín Kidney+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10++extra-source-files:+ README.md++source-repository head+ type: git+ location: https://github.com/oisdk/uniquely-represented-sets++library+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , containers+ , deepseq+ exposed-modules:+ Data.Set.Unique+ Data.Set.Unique.Properties+ Data.Tree.Binary+ Data.Tree.Braun+ Data.Tree.Braun.Internal+ Data.Tree.Braun.Properties+ Data.Tree.Braun.Sized+ Data.Tree.Braun.Sized.Properties+ other-modules:+ Paths_uniquely_represented_sets+ default-language: Haskell2010++test-suite uniquely-represented-sets-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , checkers+ , containers+ , doctest+ , uniquely-represented-sets+ other-modules:+ Paths_uniquely_represented_sets+ default-language: Haskell2010++benchmark bench+ type: exitcode-stdio-1.0+ main-is: bench.hs+ hs-source-dirs:+ bench+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2+ build-depends:+ base >=4.7 && <5+ , criterion+ , random+ , uniquely-represented-sets+ other-modules:+ Paths_uniquely_represented_sets+ default-language: Haskell2010