diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +[![Build Status](https://travis-ci.org/oisdk/uniquely-represented-sets.svg)](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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/bench.hs b/bench/bench.hs new file mode 100644 --- /dev/null +++ b/bench/bench.hs @@ -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]) diff --git a/src/Data/Set/Unique.hs b/src/Data/Set/Unique.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Unique.hs @@ -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 +-- :} diff --git a/src/Data/Set/Unique/Properties.hs b/src/Data/Set/Unique/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Unique/Properties.hs @@ -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 diff --git a/src/Data/Tree/Binary.hs b/src/Data/Tree/Binary.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Binary.hs @@ -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) ] +-- :} diff --git a/src/Data/Tree/Braun.hs b/src/Data/Tree/Braun.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Braun.hs @@ -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 +-- :} diff --git a/src/Data/Tree/Braun/Internal.hs b/src/Data/Tree/Braun/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Braun/Internal.hs @@ -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 #-} diff --git a/src/Data/Tree/Braun/Properties.hs b/src/Data/Tree/Braun/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Braun/Properties.hs @@ -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) diff --git a/src/Data/Tree/Braun/Sized.hs b/src/Data/Tree/Braun/Sized.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Braun/Sized.hs @@ -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 +-- :} diff --git a/src/Data/Tree/Braun/Sized/Properties.hs b/src/Data/Tree/Braun/Sized/Properties.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Braun/Sized/Properties.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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/"] diff --git a/uniquely-represented-sets.cabal b/uniquely-represented-sets.cabal new file mode 100644 --- /dev/null +++ b/uniquely-represented-sets.cabal @@ -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 +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