rbst (empty) → 0.0.0.0
raw patch · 17 files changed
+1870/−0 lines, 17 filesdep +Globdep +QuickCheckdep +basesetup-changed
Dependencies added: Glob, QuickCheck, base, bytestring, containers, deepseq, doctest, gauge, hspec, hspec-core, hspec-expectations, mersenne-random-pure64, mwc-random, rbst, text, transformers
Files
- CHANGELOG.md +11/−0
- LICENSE +21/−0
- README.md +121/−0
- Setup.hs +2/−0
- benchmark/Benchmark.hs +97/−0
- rbst.cabal +229/−0
- src/RBST.hs +111/−0
- src/RBST/Internal.hs +712/−0
- src/RBST/Pretty.hs +259/−0
- test/Doctest.hs +50/−0
- test/Spec.hs +1/−0
- test/Test/Common.hs +18/−0
- test/Test/RBST/CutsSpec.hs +53/−0
- test/Test/RBST/LawsSpec.hs +46/−0
- test/Test/RBST/QuerySpec.hs +56/−0
- test/Test/RBST/SetOpsSpec.hs +46/−0
- test/Test/RBST/UpdateSpec.hs +37/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`RBST` uses [PVP Versioning][1].+The changelog is available [on GitHub][2].++## 0.1.0.0 — Unreleased++* Work in progress.++[1]: https://pvp.haskell.org+[2]: https://github.com/monadplus/RBST/releases
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 Arnau Abella++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,121 @@+## rbst: efficient randomized binary search trees+++[](https://hackage.haskell.org/package/rbst)+[](https://travis-ci.org/monadplus/RBST)+[](LICENSE)++Efficient implementation of the [Randomized Binary Search Trees][1] data structure.++### When to use this package?++_Randomized Binary Search Trees_ are useful when you __cannot make assumptions on the input distribution__ but you still need fast (logarithmic time complexity) `insert`/`lookup`/`delete`/`at`/`union`/etc. operations. It is guaranteed efficient self-balancing. Below you can find the table of time complexity for all operations (where `n` is the size of the tree):++| Operation | Time complexity | Description |+|----------------|-----------------|------------------------------------------------|+| `size` | `O(1)` | Count elements in the tree |+| `lookup` | `O(log n)` | Access by key |+| `insert` | `O(log n)` | Insert an element with the given key |+| `delete` | `O(log n)` | Delete the element associated to the given key |+| `take` | `O(log n)` | Take first i-th elements |+| `drop` | `O(log n)` | Drop first i-th elements |+| `at` | `O(log n)` | Access by index |+| `remove` | `O(log n)` | Remove the i-th element |+| `union` | `O(m + n)` | Union of two trees |+| `intersection` | `O(m + n)` | Intersection of two trees |+| `subtraction` | `O(m + n)` | Subtraction of two trees |+| `difference` | `O(m + n)` | Symmetric difference of two trees |++### Usage example++```haskell+>>> :set -XOverlodadeLists+>>> import GHC.Exts+>>> import RBST++-- Manually created+>>> let tree = insert 'a' 1+ $ insert 'b' 2+ $ insert 'c' 3+ $ insert 'd' 4+ $ insert 'e' 5+ $ empty++-- Using 'OverloadedLists'+>>> let tree = (fromList $ zip ['a'..'e'] [1..5]) :: RBST Char Int+>>> RBST.prettyPrint tree+ ('b',2) [5]+ ╱╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+('a',1) [1] ('d',4) [3]+ ╱╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ╱ ╲+ ('c',3) [1] ('e',5) [1]++-- Queries+>>> size tree+5+>>> lookup 'd'+Just 4+>>> lookup 'a' $ insert 'a' 7 tree+Just 7+>>> lookup 'd' (delete 'd' tree)+Nothing+```++### How to use it++In order to start using `rbst` in your project, you will need to set it up with the two easy steps:++1. Add the dependency in your project's `.cabal` file:++ ```haskell+ build-depends: base ^>= 4.14+ , rbst ^>= 0.0.0.0+ ```++2. In the module where you wish to use `rbst`, add the (qualified) import:++ ```haskell+ import qualified RBST+ ```++#### Stack++1. If `rbst` is not available on your current [Stackage][3] resolver yet, you can still use it by adding the following in the `extra-deps` section of your `stack.yaml` file:++ ```haskell+ extra-deps:+ - rbst-0.0.0.0+ ```++2. Then you can add it as a dependency in your `package.yaml` file as usual:++ ```+ library:+ dependencies:+ - rbst+ ```++### Acknowledgement++To the authors [C. Martinez](https://www.cs.upc.edu/~conrado/) and [S. Roura](https://www.cs.upc.edu/~roura/).++To [D. Kovanikov](https://github.com/chshersh) and his project [implicit treap][2].++Icons designed by [Freepik](http://www.freepik.com) from [www.flaticon.com](https://www.flaticon.com/).++[1]: http://akira.ruc.dk/~keld/teaching/algoritmedesign_f08/Artikler/03/Martinez97.pdf+[2]: https://github.com/chshersh/treap+[3]: https://www.stackage.org/
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/Benchmark.hs view
@@ -0,0 +1,97 @@+import Gauge.Main++-- TODO:+-- [ ] Implement something similar to this example.++main :: IO ()+main = defaultMain []++-- {-# LANGUAGE CPP, FlexibleContexts, ScopedTypeVariables #-}+-- {-# OPTIONS_GHC -fno-warn-orphans #-}+--+-- import Criterion.Main+-- import Data.ByteString (ByteString, pack)+-- import Data.Hashable (Hashable)+-- import System.Random.MWC+-- import qualified Data.HashMap.Lazy as H+-- import qualified Data.IntMap as I+-- import qualified Data.Map as M+-- import qualified Data.Vector as V+-- import qualified Data.Vector.Algorithms.Intro as I+-- import qualified Data.Vector.Generic as G+-- import qualified Data.Vector.Unboxed as U+--+-- #if !MIN_VERSION_bytestring(0,10,0)+-- import Control.DeepSeq (NFData (..))+-- #endif+--+-- type V = U.Vector Int+-- type B = V.Vector ByteString+--+-- numbers :: IO (V, V, V)+-- numbers = do+-- random <- withSystemRandom . asGenIO $ \gen -> uniformVector gen 40000+-- let sorted = G.modify I.sort random+-- revsorted = G.reverse sorted+-- return (random, sorted, revsorted)+--+-- strings :: IO (B, B, B)+-- strings = do+-- random <- withSystemRandom . asGenIO $ \gen ->+-- V.replicateM 10000 $+-- (pack . U.toList) `fmap` (uniformVector gen =<< uniformR (1,16) gen)+-- let sorted = G.modify I.sort random+-- revsorted = G.reverse sorted+-- return (random, sorted, revsorted)+--+-- main :: IO ()+-- main = defaultMain [+-- env numbers $ \ ~(random,sorted,revsorted) ->+-- bgroup "Int" [+-- bgroup "IntMap" [+-- bench "sorted" $ whnf intmap sorted+-- , bench "random" $ whnf intmap random+-- , bench "revsorted" $ whnf intmap revsorted+-- ]+-- , bgroup "Map" [+-- bench "sorted" $ whnf mmap sorted+-- , bench "random" $ whnf mmap random+-- , bench "revsorted" $ whnf mmap revsorted+-- ]+-- , bgroup "HashMap" [+-- bench "sorted" $ whnf hashmap sorted+-- , bench "random" $ whnf hashmap random+-- , bench "revsorted" $ whnf hashmap revsorted+-- ]+-- ]+-- , env strings $ \ ~(random,sorted,revsorted) ->+-- bgroup "ByteString" [+-- bgroup "Map" [+-- bench "sorted" $ whnf mmap sorted+-- , bench "random" $ whnf mmap random+-- , bench "revsorted" $ whnf mmap revsorted+-- ]+-- , bgroup "HashMap" [+-- bench "sorted" $ whnf hashmap sorted+-- , bench "random" $ whnf hashmap random+-- , bench "revsorted" $ whnf hashmap revsorted+-- ]+-- ]+-- ]+--+-- hashmap :: (G.Vector v k, Hashable k, Eq k) => v k -> H.HashMap k Int+-- hashmap xs = G.foldl' (\m k -> H.insert k value m) H.empty xs+--+-- intmap :: G.Vector v Int => v Int -> I.IntMap Int+-- intmap xs = G.foldl' (\m k -> I.insert k value m) I.empty xs+--+-- mmap :: (G.Vector v k, Ord k) => v k -> M.Map k Int+-- mmap xs = G.foldl' (\m k -> M.insert k value m) M.empty xs+--+-- value :: Int+-- value = 31337+--+-- #if !MIN_VERSION_bytestring(0,10,0)+-- instance NFData ByteString where+-- rnf bs = bs `seq` ()+-- #endif
+ rbst.cabal view
@@ -0,0 +1,229 @@+cabal-version: >= 1.10++name: rbst+version: 0.0.0.0+build-type: Simple+license: MIT+license-file: LICENSE+author: Arnau Abella+maintainer: arnauabella@gmail.com+copyright: 2020 Arnau Abella+homepage: https://github.com/monadplus/rbst+bug-reports: https://github.com/monadplus/rbst/issues+synopsis: Randomized Binary Search Trees+description:+ .+ This package contains an implementation of a [Randomized+ Binary Search Tree](http://akira.ruc.dk/~keld/teaching/algoritmedesign_f08/Artikler/03/Martinez97.pdf).+ .+ Randomized Binary Search Trees are guaranteed to be /Random BST/ irrespective of the number+ of @'insert'@ \/ @'delete'@ operations. This guarantees logarithmic time operations (with a constant factor) in the worst case.+category: Data Structures+extra-source-files: README.md+ CHANGELOG.md+tested-with: GHC == 8.8.3++source-repository head+ type: git+ location: https://github.com/monadplus/rbst.git++Library+ default-language: Haskell2010+ hs-source-dirs: src++ exposed-modules: RBST+ RBST.Pretty++ other-modules: RBST.Internal++ build-depends: base >=4.12 && <4.14,+ bytestring >=0.10.8.2 && <0.11.0.0,+ containers >=0.5.0.1 && <0.7,+ deepseq >=1.4 && <1.5,+ mersenne-random-pure64 >=0.2.2.0 && <0.3,+ text >=1.2.3.0 && <2.0.0.0,+ transformers >=0.5.0.0 && <0.6.0.0++ ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -Wpartial-fields+ -fhide-source-paths+ -freverse-errors+ if impl(ghc >= 8.8.1)+ ghc-options: -Wmissing-deriving-strategies+ -Werror=missing-deriving-strategies++ default-extensions: AllowAmbiguousTypes+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ EmptyCase+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ NamedFieldPuns+ OverloadedLists+ OverloadedStrings+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ RoleAnnotations++Test-suite rbst-tests+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Test.Common+ Test.RBST.CutsSpec+ Test.RBST.LawsSpec+ Test.RBST.QuerySpec+ Test.RBST.SetOpsSpec+ Test.RBST.UpdateSpec++ build-depends: rbst,+ base >=4.12 && <4.14,+ hspec >=2.6.0 && <2.8,+ hspec-expectations >=0.8.0 && <0.9,+ hspec-core >=2.6.0 && <2.8,+ QuickCheck >=2.12 && <2.14++ ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -Wpartial-fields+ -fhide-source-paths+ -freverse-errors+ if impl(ghc >= 8.8.1)+ ghc-options: -Wmissing-deriving-strategies+ -Werror=missing-deriving-strategies++ default-extensions: AllowAmbiguousTypes+ BangPatterns+ ConstraintKinds+ DataKinds+ DefaultSignatures+ DeriveAnyClass+ DeriveDataTypeable+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DerivingStrategies+ DerivingVia+ DuplicateRecordFields+ EmptyCase+ EmptyDataDecls+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ GeneralizedNewtypeDeriving+ InstanceSigs+ KindSignatures+ LambdaCase+ NamedFieldPuns+ OverloadedLists+ OverloadedStrings+ PolyKinds+ QuasiQuotes+ RankNTypes+ RecordWildCards+ ScopedTypeVariables+ StandaloneDeriving+ TemplateHaskell+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UndecidableInstances+ RoleAnnotations+++Test-suite rbst-doctest+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Doctest.hs++ build-depends: base >=4.12 && <4.14,+ doctest >=0.16 && <0.17,+ Glob >=0.9 && <0.11++ ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -Wpartial-fields+ -fhide-source-paths+ -freverse-errors++ -threaded+ if impl(ghc >= 8.8.1)+ ghc-options: -Wmissing-deriving-strategies+ -Werror=missing-deriving-strategies++++Benchmark rbst-bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmark+ main-is: Benchmark.hs++ build-depends: rbst,+ base >=4.12 && <4.14,+ gauge >=0.2.4 && <0.3,+ mwc-random >= 0.14.0 && <0.15++ ghc-options: -Wall+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wcompat+ -Widentities+ -Wredundant-constraints+ -Wpartial-fields+ -fhide-source-paths+ -freverse-errors++ -O2+ -threaded+ -rtsopts+ -with-rtsopts=-N+ if impl(ghc >= 8.8.1)+ ghc-options: -Wmissing-deriving-strategies+ -Werror=missing-deriving-strategies
+ src/RBST.hs view
@@ -0,0 +1,111 @@+--------------------------------------------------------------------+-- |+-- Module : RBST+-- Copyright : (c) Arnau Abella 2020+-- License : MIT (see the file LICENSE)+-- Maintainer : Arnau Abella arnauabell@gmail.com+-- Stability : experimental+-- Portability : non-portable+--+-- == General description+--+-- Package @rbst@ implements a self-balancing-tree-like data structure called /Randomized Binary Search Tree/. This data structure behave exactly like a <https://en.wikipedia.org/wiki/Random_binary_tree random_binary_search_tree>, irrespectively of the input data distribution, with fast (logarithmic time complexity) @'RBST.insert'@ \/ @'RBST.delete'@ \/ @'lookup'@ \/ @'union'@ \/ etc. operations.+--+-- == Package structure+--+-- This package contains the following modules:+--+-- * __"RBST.Pretty"__: pretty-printer for the tree.+--+-- Module __"RBST"__ reexports ony __"RBST.Pretty"__ and exports all 'RBST' functionalities.+--+-- == Usage example+--+-- A balanced 'Tree' can be created from a list of keys/values:+--+-- >>> import GHC.Exts (IsList (..))+-- >>> let empty = empty :: RBST Int String+-- >>> let single = one 1 'v'+-- >>> let tree = fromList [("x", 2),("y", 3), ("z", 1)] :: RBST String Int+-- >>> prettyPrint tree+-- ("y",3) [3]+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ("x",2) [1] ("z",1) [1]+--+-- Each node shows:+--+-- 1. The key.+-- 2. The associated value.+-- 3. The size of the tree.+--+-- You can try it yourself:+--+-- @+-- > insert "w" 5 tree+-- > delete "u" tree+-- @+--+-- >>> lookup "y" tree+-- Just 3+--+-- >>> lookup "w" tree+-- Nothing+--+-- >>> compactPrint tree+-- ("y",3) [3]+-- |+-- |-- ("z",1) [1]+-- |+-- \__ ("x",2) [1]+-- <BLANKLINE>+--+-- == Implementation+--+-- The implementation of /Randomized Binary Search Trees/ is based on:+--+-- * Conrado Martinez and Salvador Roura, \"/Randomized Binary Search Trees/\", January 1997, <http://akira.ruc.dk/~keld/teaching/algoritmedesign_f08/Artikler/03/Martinez97.pdf>.+--+--------------------------------------------------------------------+module RBST (++ -- * Data structure & Instances+ Size(..)+ , Tree(..)+ , RBST(..)++ -- * Construction functions+ , empty+ , one++ -- * Query functions+ , size+ , height+ , lookup+ , at++ -- * Modification functions+ , insert+ , delete+ , remove+ , take+ , drop++ -- * Set operations+ , union+ , intersection+ , subtraction+ , difference++ -- * Reexports+ , module RBST++ ) where++import Prelude hiding (drop, lookup, take)+import RBST.Internal as Internal+import RBST.Pretty as RBST
+ src/RBST/Internal.hs view
@@ -0,0 +1,712 @@+--------------------------------------------------------------------+-- |+-- Module : RBST.Internal+-- Copyright : (c) Arnau Abella 2020+-- License : MIT+-- Maintainer : arnauabell@gmail.com+-- Stability : experimental+-- Portability : non-portable+--+-- Efficient implementation of a /Randomized Binary Search Tree/.+--+-- The implementation uses the /Mersenne twister/, a pure pseudo-random number generator (Matsumoto and Nishimura).+--+-- __NOTE__: the computational complexity of each operation is annotated in the documentation and it is guaranteed, irrespectively of the input distribution (with a small constant factor overhead).+--+--------------------------------------------------------------------+module RBST.Internal (+ -- * Types, Constructors & Instances+ Size(..)+ , Tree(..)+ , RBST(..)+ , MonadRandT+ , MonadRand++ -- * Construction functions+ , empty+ , emptyWithGen+ , one+ , oneWithGen+ -- ** Random Generators+ , defaultRandomGenerator+ , clockRandomGenerator++ -- * Query functions+ , size+ , sizeTree+ , height+ , lookup+ , at++ -- * Modification functions+ , insert+ , delete+ , remove+ , take+ , drop++ -- * Set operations+ , union+ , intersection+ , subtraction+ , difference++ -- * Randomization functions+ , uniformR++ -- * Internals functions+ , withTree++ ) where++import Control.DeepSeq (NFData (..), rnf)+import Control.Monad.Trans.State.Strict (StateT)+import qualified Control.Monad.Trans.State.Strict as State+import Data.Coerce (coerce)+import Data.Foldable (foldl')+import Data.Functor.Identity (Identity)+import Data.Word (Word64)+import GHC.Exts (IsList (..))+import GHC.Generics (Generic)+import Prelude hiding (drop, lookup, take)+import qualified System.Random.Mersenne.Pure64 as Random++-- $setup+-- >>> import qualified RBST.Pretty as Pretty+-- >>> import GHC.Exts++-----------------------------------------+-- Data Structure and Instances+-----------------------------------------++-- | Size of the 'Tree' data structure.+newtype Size = Size+ { unSize :: Word64+ } deriving stock (Show, Read, Generic)+ deriving newtype (Eq, Ord, Num, NFData)++-- | 'Tree' data structure. The node contains the rank of the tree.+data Tree k a+ = Node !Size !k !(Tree k a) !a !(Tree k a)+ | Empty+ deriving stock (Show, Read, Eq, Generic, Foldable)+ deriving anyclass (NFData)++-- | 'RBST' data structure.+data RBST k a = RBST+ { rbstGen :: !Random.PureMT+ , rbstTree :: !(Tree k a)+ } deriving stock (Show, Generic, Foldable)++-- | (<>) is implemented via 'merge'.+--+-- __Note__: Unlawful instance.+--+-- TODO: require Semigroup a and use 'unionWith'+instance Ord k => Semigroup (RBST k a) where+ (<>) = union++-- | mempty is implemented via 'empty'.+instance Ord k => Monoid (RBST k a) where+ mempty = empty++-- | (==) is implemented via (==) of the underlying 'Tree'.+instance (Eq k, Eq a) => Eq (RBST k a) where+ (RBST _ tree1) == (RBST _ tree2) = tree1 == tree2++-- | Create a tree from a list of key\/value pairs, and viceversa.+--+-- __NOTE__: This requires /-XOverloadedLists/ enabled.+--+-- Functions have the following time complexity:+--+-- 1. 'fromList': \( O(n \cdot \log \ n) \)+-- 2. 'toList': \( O(n) \).+--+-- >>> import GHC.Exts+-- >>> let tree = (fromList $ zip ['a'..'e'] [1..5]) :: RBST Char Int+-- >>> Pretty.prettyPrint tree+-- ('d',4) [5]+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ('b',2) [3] ('e',5) [1]+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ('a',1) [1] ('c',3) [1]+--+-- >>> toList tree+-- [('a',1),('b',2),('c',3),('d',4),('e',5)]+instance Ord k => IsList (RBST k a) where+ type Item (RBST k a) = (k,a)++ fromList :: [(k,a)] -> RBST k a+ fromList = foldl' ins empty where+ ins tree (!k,!x) = insert k x tree+ {-# INLINEABLE fromList #-}++ -- | Inorder traversal.+ toList :: RBST k a -> [(k,a)]+ toList RBST{..} = toListTree rbstTree+ where+ toListTree Empty = []+ toListTree (Node _ k l x r) = toListTree l ++ (k,x) : toListTree r+ {-# INLINEABLE toList #-}+-- Note, a pure fromList could be created using a triplet including a random number.++instance (NFData k, NFData a) => NFData (RBST k a) where+ rnf RBST{..} = rnf rbstTree `seq` ()++-- | A random state transformer for the pseudo-random bits.+type MonadRandT m a = StateT Random.PureMT m a++-- | A random state in the 'Data.Functor.Identity' monad.+type MonadRand a = StateT Random.PureMT Identity a++----------------------------------------+-- Construction+----------------------------------------++-- | A pure mersenne twister pseudo-random number generator.+--+-- It is created using a __fixed__ seed.+defaultRandomGenerator :: Random.PureMT+defaultRandomGenerator = Random.pureMT 0+{-# INLINE defaultRandomGenerator #-}++-- | A pure mersenne twister pseudo-random number generator.+--+-- It is created using a pseudo-random seed from the internal clock.+clockRandomGenerator :: IO Random.PureMT+clockRandomGenerator = Random.newPureMT+{-# INLINE clockRandomGenerator #-}++-- | The empty 'Tree'.+--+-- @+-- > empty == fromList []+-- > size empty == 0+-- @+empty :: RBST k a+empty = emptyWithGen defaultRandomGenerator+{-# INLINE empty #-}++-- | Returns an empty 'RBST' from a 'Random.PureMT'.+emptyWithGen :: Random.PureMT -> RBST k a+emptyWithGen gen = RBST gen Empty+{-# INLINE emptyWithGen #-}++-- | Single node 'RBST'.+--+-- >>> size (one 1 'a')+-- 1+one :: k -> a -> RBST k a+one = oneWithGen defaultRandomGenerator+{-# INLINE one #-}++-- | Returns a single node 'RBST' from a 'Random.PureMT'.+oneWithGen :: Random.PureMT -> k -> a -> RBST k a+oneWithGen gen = (RBST gen .) . oneTree+{-# INLINE oneWithGen #-}++-- | Single node 'Tree'.+oneTree :: k -> a -> Tree k a+oneTree k x = Node 1 k Empty x Empty+{-# INLINE oneTree #-}++----------------------------------------------+-- Query+----------------------------------------------++-- | \( O(1) \). Return the size of the 'RBST'.+size :: RBST k a -> Int+size = withTree sizeTreeInt+{-# INLINE size #-}++-- | \( O(1) \). Return the 'Size' of the 'Tree'.+sizeTree :: Tree k a -> Size+sizeTree Empty = 0+sizeTree (Node !s _ _ _ _) = s+{-# INLINE sizeTree #-}++-- | \( O(1) \). Return the size of the 'Tree'.+sizeTreeInt :: Tree k a -> Int+sizeTreeInt Empty = 0+sizeTreeInt (Node !s _ _ _ _) = fromIntegral (coerce s :: Word64)+{-# INLINE sizeTreeInt #-}++-- | \( O(n) \). Height of the tree.+--+-- >>> height (empty :: RBST Char Int)+-- -1+--+-- >>> height (one 'x' 1)+-- 0+--+-- >>> height (one 'x' 1 <> one 'y' 2)+-- 1+height :: RBST k a -> Int+height = withTree height'+ where+ height' :: Tree k a -> Int+ height' Empty = -1+ height' (Node _ _ l _ r) = 1 + max (height' l) (height' r)+{-# INLINEABLE height #-}++-- | \( O(\log \ n) \). Lookup the value at the key in the tree.+--+-- >>> lookup 'A' (empty :: RBST Char Int)+-- Nothing+--+-- >>> lookup 'A' (one 'A' 7)+-- Just 7+lookup :: Ord k => k -> RBST k a -> Maybe a+lookup k1 = withTree lookup'+ where+ lookup' Empty = Nothing+ lookup' (Node _ k2 l a r)+ | k1 == k2 = Just a+ | k1 < k2 = lookup' l+ | otherwise = lookup' r+{-# INLINEABLE lookup #-}++----------------------------------------------+-- Insertion+----------------------------------------------++-- | \( O(\log \ n) \). Insert a new key\/value pair in the tree.+--+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value.+--+-- @+-- > insert 'x' 1 empty == one 'x' 1+-- @+insert :: Ord k => k -> a -> RBST k a -> RBST k a+insert k x RBST{..} = runRand (insert' k x rbstTree) rbstGen+{-# INLINEABLE insert #-}++-- | 'insert' for 'Tree'\'s in the 'MonadRand'.+insert' :: Ord k => k -> a -> Tree k a -> MonadRand (Tree k a)+insert' k x Empty = return (oneTree k x)+insert' k x node@(Node s !k2 l _ r) = do+ guess <- uniformR (0, coerce s)+ if guess == 0+ then do (rep, tree) <- insertRoot k x node+ if rep then pushDown tree+ else pure tree+ else if k < k2+ then updateL node <$> insert' k x l+ else+ updateR node <$> insert' k x r+{-# INLINEABLE insert' #-}++----------------------------------------------+-- Deletion+----------------------------------------------++-- | \( O(\log \ n) \). Delete a key and its value from the map. When the key is not a member of the map, the original map is returned.+--+-- @+-- > delete 1 (one (1, "A")) == empty+-- @+delete :: Ord k => k -> RBST k a -> RBST k a+delete k RBST{..} = runRand (delete' k rbstTree) rbstGen+{-# INLINEABLE delete #-}++-- | 'delete' for 'Tree'\'s in the 'MonadRand'.+delete' :: Ord k => k -> Tree k a -> MonadRand (Tree k a)+delete' _ Empty = return Empty+delete' k node@(Node _ k2 l _ r)+ | k == k2 = join l r+ | k < k2 = updateL node <$> delete' k l+ | otherwise = updateR node <$> delete' k r+{-# INLINEABLE delete' #-}++----------------------------------------+-- Query by Rank+----------------------------------------++-- | \( O(\log \ n) \). Get the i-th element of the tree.+--+-- __NOTE__: \(0 \leq i \leq n\), where /n/ is the size of the tree.+--+-- >>> let tree = fromList [('a',1), ('b', 2), ('c',3)] :: RBST Char Int+-- >>> at 0 tree+-- Just ('a',1)+-- >>> at 2 tree+-- Just ('c',3)+at :: Int -> RBST k a -> Maybe (k, a)+at ith = withTree (at' ith)+ where+ at' _ Empty = Nothing+ at' i (Node _ k l x r)+ | i < sizeL = at' i l+ | i == sizeL = Just (k, x)+ | otherwise = at' (i - (sizeL + 1)) r+ where sizeL = sizeTreeInt l+{-# INLINEABLE at #-}++-- | \( O(\log \ n) \). Delete the i-th element of the tree.+--+-- __NOTE__: \(0 \leq i \leq n\), where /n/ is the size of the tree.+--+-- >>> let tree = fromList [('a',1), ('b', 2), ('c',3)] :: RBST Char Int+-- >>> toList $ remove 0 tree+-- [('b',2),('c',3)]+remove :: Int -> RBST k a -> RBST k a+remove n rbst@RBST{..}+ | n < 0 = rbst+ | n >= size rbst = rbst+ | otherwise = runRand (go n rbstTree) rbstGen+ where+ go _ Empty = return Empty+ go !i node@(Node _ _ l _ r)+ | i < sizeL = updateL node <$> (go i l)+ | i == sizeL = l `join` r+ | otherwise = updateR node <$> (go (i - (sizeL + 1)) r)+ where sizeL = sizeTreeInt l+{-# INLINEABLE remove #-}++-- | \( O(\log n) \). Returns the first @i@-th elements of the given tree @t@ of size @n@.+--+-- __Note__:+--+-- 1. If \( i \leq 0 \), then the result is 'empty'.+-- 2. If \( i \geq n \), then the result is @t@.+take :: Int -> RBST k a -> RBST k a+take n rbst@RBST{..}+ | n <= 0 = RBST rbstGen Empty+ | n >= size rbst = rbst+ | otherwise = RBST rbstGen (go n rbstTree)+ where+ go _ Empty = Empty+ go 0 _ = Empty+ go i node@(Node _ _ l _ r)+ | i < sizeL = go i l+ | i == sizeL = l+ | otherwise = updateR node (go (i - (sizeL + 1)) r)+ where sizeL = sizeTreeInt l+{-# INLINEABLE take #-}++-- | \( O(\log n) \). Returns the tree @t@ without the first @i@-th elements.+--+-- __Note__:+--+-- 1. If \( i \leq 0 \), then the result is @t@.+-- 2. If \( i \geq n \), then the result is 'empty'.+drop :: Int -> RBST k a -> RBST k a+drop n rbst@RBST{..}+ | n <= 0 = rbst+ | n >= size rbst = RBST rbstGen Empty+ | otherwise = RBST rbstGen (go n rbstTree)+ where+ go _ Empty = Empty+ go !0 t = t+ go !i node@(Node _ _ l _ r)+ | i < sizeL = updateL node (go i l)+ | i == sizeL = updateL node Empty+ | otherwise = go (i - (sizeL + 1)) r+ where sizeL = sizeTreeInt l+{-# INLINEABLE drop #-}++----------------------------------------------+-- Set operations+----------------------------------------------++-- TODO: 'unionWith' that uses a Semigroup on a.++-- | \( \theta(m + n) \). Union of two 'RBST'.+--+-- In case of duplication, only one key remains by a random choice.+union :: Ord k => RBST k a -> RBST k a -> RBST k a+union (RBST s tree1) (RBST _ tree2) = runRand (union' tree1 tree2) s+ where+ union' t1 t2 = do+ let m = fromIntegral $ sizeTreeInt t1+ n = fromIntegral $ sizeTreeInt t2+ total = m + n+ if total == 0+ then return Empty+ else do+ u <- uniformR (1, total)+ let (a,b) = if u <= m then (t1,t2) else (t2,t1)+ (Node _ aKey aL x aR) = a -- Ignore warning: checked at u <= m+ (rep, bL, bR) <- split aKey b+ l <- union' aL bL+ r <- union' aR bR+ let randomize = if rep then pushDown else pure+ randomize (recomputeSize (Node 0 aKey l x r))+{-# INLINEABLE union #-}+++-- | \( \theta(m + n) \). Intersection of two 'RBST'.+intersection :: Ord k => RBST k a -> RBST k a -> RBST k a+intersection (RBST s t1) (RBST _ t2) = runRand (intersect' t1 t2) s+ where+ intersect' Empty _ = return Empty+ intersect' (Node _ k l x r) b = do+ (rep, bL, bR) <- split k b+ iL <- intersect' l bL+ iR <- intersect' r bR+ if rep then pure $ recomputeSize (Node 0 k iL x iR)+ else join iL iR+{-# INLINEABLE intersection #-}++-- | \( \theta(m + n) \). Difference (subtraction) of two 'RBST'.+subtraction :: Ord k => RBST k a -> RBST k a -> RBST k a+subtraction (RBST s t1) (RBST _ t2) = runRand (subtraction' t1 t2) s+ where+ subtraction' Empty _ = return Empty+ subtraction' (Node _ k l x r) b = do+ (rep, bL, bR) <- split k b+ dL <- subtraction' l bL+ dR <- subtraction' r bR+ if rep then join dL dR+ else pure $ recomputeSize (Node 0 k dL x dR)+{-# INLINEABLE subtraction #-}++-- | \( \theta(m + n) \). Difference (disjunctive union) of two 'RBST'.+difference :: Ord k => RBST k a -> RBST k a -> RBST k a+difference (RBST s t1) (RBST _ t2) = runRand (diff t1 t2) s+ where+ diff Empty b = return b+ diff (Node _ k l x r) b = do+ (rep, bL, bR) <- split k b+ dL <- diff l bL+ dR <- diff r bR+ if rep then join dL dR+ else pure $ recomputeSize (Node 0 k dL x dR)+{-# INLINEABLE difference #-}+-- I think this requires rebalancing to be truly random.++----------------------------------------------+-- Random+----------------------------------------------++-- | Return a uniformly random 'Word64' in the given range.+uniformR :: (Word64, Word64) -> MonadRand Word64+uniformR (x1, x2)+ | n == 0 = error "Check uniformR"+ | otherwise = loop+ where+ -- Unboxed tuples give me errors when loaded with ghci/ghcid.+ -- (# i,j #) | x1 < x2 = (# x1, x2 #)+ -- | otherwise = (# x2, x1 #)+ (i,j) | x1 < x2 = (x1, x2)+ | otherwise = (x2, x1)+ n = 1 + (j - i)+ buckets = maxBound `div` n+ maxN = buckets * n -- rounding+ loop = do+ gen <- State.get+ let (!x, nextGen) = Random.randomWord64 gen+ if x < maxN+ then State.put nextGen >> return (i + (x `div` buckets))+ else State.put nextGen >> loop+{-# INLINE uniformR #-}++----------------------------------------------+-- Core internal functions+----------------------------------------------++-- | Given a random computation 'Tree' and an initial state, returns a 'RBST'.+runRand :: MonadRand (Tree k a) -> Random.PureMT -> RBST k a+runRand r s = let (tree, s') = State.runState r s in RBST s' tree++-- | Returns the key of the 'Node' or 'Nothing'.+-- getKey :: Tree k a -> Maybe k+-- getKey Empty = Nothing+-- getKey (Node _ k _ _ _) = Just k+-- {-# INLINE getKey #-}++-- | Return the left subtree or empty.+getL :: Tree k a -> Tree k a+getL Empty = Empty+getL (Node _ _ l _ _) = l+{-# INLINE getL #-}++-- | Return the right subtree or empty.+getR :: Tree k a -> Tree k a+getR Empty = Empty+getR (Node _ _ _ _ r) = r+{-# INLINE getR #-}++-- | 'fmap' over 'rbstGen'.+-- overGen :: (Random.PureMT -> Random.PureMT) -> RBST k a -> RBST k a+-- overGen f RBST{..} = RBST (f rbstGen) rbstTree+-- {-# INLINE overGen #-}++-- | Set a new 'rbstGen'.+-- setGen :: Random.PureMT -> RBST k a -> RBST k a+-- setGen newGen = overGen (const newGen)+-- {-# INLINE setGen #-}++-- | Lift a function from 'Tree' to 'RBST'.+withTree :: (Tree k a -> r) -> (RBST k a -> r)+withTree f = f . rbstTree+{-# INLINE withTree #-}++-- overTree :: (Tree k a -> Tree k a) -> (RBST k a -> RBST k a)+-- overTree f RBST{..} = RBST rbstGen (f rbstTree)+-- {-# INLINE overTree #-}++-- | \( O(1) \). Recompute tree size after modification+recomputeSize :: Tree k a -> Tree k a+recomputeSize Empty = Empty+recomputeSize (Node _ k l c r) =+ let !s = sizeTree l + sizeTree r + 1 in Node s k l c r+{-# INLINE recomputeSize #-}++-- | \( O(1) \). Rotate tree to the left.+--+-- Before+--+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱╲ C+-- ╱ ╲+-- ╱ ╲+-- A B+--+-- After+--+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- A ╱╲+-- ╱ ╲+-- ╱ ╲+-- B C+--+-- rotateR :: Tree k a -> Tree k a+-- rotateR Empty = Empty+-- rotateR node@(Node _ _ Empty _ _) = node+-- rotateR (Node s k (Node _ k2 l2 c2 r2) c r) =+-- Node s k2 l2 c2 newR+-- where+-- newR = recomputeSize $ Node s k r2 c r+-- {-# INLINEABLE rotateR #-}++-- | \( O(1) \). Rotate tree to the left.+--+--+-- Before+--+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- A ╱╲+-- ╱ ╲+-- ╱ ╲+-- B C+--+-- After+--+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱╲ C+-- ╱ ╲+-- ╱ ╲+-- A B+--+-- rotateL :: Tree k a -> Tree k a+-- rotateL Empty = Empty+-- rotateL node@(Node _ _ _ _ Empty) = node+-- rotateL (Node s k l c (Node _ k2 l2 c2 r2)) =+-- Node s k2 newL c2 r2+-- where+-- newL = recomputeSize $ Node s k l c l2+-- {-# INLINE rotateL #-}++-- | \( O(1) \). Update the left node with the given subtree.+--+-- Notice, the size is not recomputed so you+-- will probably need to call 'recomputeSize'.+updateL :: Tree k a -> Tree k a -> Tree k a+updateL Empty newL = newL+updateL (Node s k _ c r) newL = recomputeSize (Node s k newL c r)+{-# INLINE updateL #-}++-- | \( O(1) \). Update the right node with the given subtree.+--+-- Notice, the size is not recomputed so you+-- will probably need to call 'recomputeSize'.+updateR :: Tree k a -> Tree k a -> Tree k a+updateR Empty newR = newR+updateR (Node s k l c _) newR = recomputeSize (Node s k l c newR)+{-# INLINE updateR #-}++-- | \(O(\log \n )\). Insert node at root using 'split' and recompute the size.+--+-- __NOTE__: duplicated keys are removed by randomly picking one of them.+insertRoot :: Ord k => k -> a -> Tree k a -> MonadRand (Bool, Tree k a)+insertRoot k x Empty = return (False, oneTree k x)+insertRoot k x tree = do+ (rep, l, r) <- split k tree+ return (rep, recomputeSize (Node 0 k l x r))+{-# INLINE insertRoot #-}++-- | \(O(\log \n )\. Split the tree \( T \) into two trees \( T_< \) and \( T_> \), which contain the keys of \( T \) that are smaller than x and larger than x, respectively.+--+-- This is a sligh variant which removes any duplicate of 'k' and returns a bool indicating so.+split :: Ord k => k -> Tree k a -> MonadRand (Bool, Tree k a, Tree k a)+split _ Empty = return (False, Empty, Empty)+split k node@(Node _ k2 l _ r)+ | k < k2 = do+ (b, t1, t2) <- split k l+ return (b, t1, updateL node t2)+ | k == k2 = do+ (_, t1, t2) <- split k r+ newT1 <- join l t1+ return (True, newT1, t2)+ | otherwise = do+ (b, t1, t2) <- split k r+ return (b, updateR node t1, t2)+{-# INLINE split #-}++-- | Given a BST where left and right subtrees are random BST, returns a completly random BST.+--+-- __NOTE__: the input can't be 'Empty'.+pushDown :: Tree k a -> MonadRand (Tree k a)+pushDown Empty = error "The input of pushDown can be an empty tree."+pushDown tree@(Node _ _ l _ r) = do+ let !m = fromIntegral $ sizeTreeInt l+ !n = fromIntegral $ sizeTreeInt r+ !total = m + n+ u <- uniformR (0, total)+ if u < m+ then updateR l <$> (pushDown $ updateL tree (getR l))+ else if u < total+ then updateL r <$> (pushDown $ updateR tree (getL r))+ else+ return tree++-- | \(O(\log \ n )\). Invariant: : All keys from p must be strictly smaller than any key of q.+--+-- Theorem. The join of two independent random binary search tree is a random binary search tree.+join :: Tree k a -> Tree k a -> MonadRand (Tree k a)+join Empty q = return q+join p Empty = return p+join p@(Node s _ _ _ pR) q@(Node s2 _ qL _ _) = do+ guess <- uniformR (0, unSize (s + s2))+ if guess < unSize s+ then updateR p <$> join pR q+ else updateL q <$> join p qL+{-# INLINE join #-}
+ src/RBST/Pretty.hs view
@@ -0,0 +1,259 @@+--------------------------------------------------------------------+-- |+-- Module : RBST.Pretty+-- Copyright : (C) Arnau Abella 2020+-- License : MIT (see the file LECENSE)+-- Maintainer : Arnau Abella arnauabell@gmail.com+-- Stability : experimental+-- Portability : non-portable+--+-- 'RBST' visualization.+--+--------------------------------------------------------------------+module RBST.Pretty (+ -- * Printing+ -- ** Pretty printing+ pretty+ , prettyPrint++ -- ** Compact printing+ , compact+ , compactPrint+ ) where++import Data.Char (isSpace)+import Data.List (dropWhileEnd, intercalate)+import RBST.Internal (RBST (..), Size (..), Tree (..), withTree)++-- $setup+-- >>> import GHC.Exts++-- | Pretty 2-dimensional ASCII drawing of a 'RBST'.+--+-- See 'RBST.Pretty.prettyPrint' for an example.+pretty :: (Show k, Show a) => RBST k a -> String+pretty = withTree drawPretty++-- | Call 'pretty' function and output the result directly to @stdout@.+--+-- >>> let tree = (fromList $ zip ['a'..'e'] [1..5]) :: RBST Char Int+-- >>> prettyPrint tree+-- ('d',4) [5]+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ('b',2) [3] ('e',5) [1]+-- ╱╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ╱ ╲+-- ('a',1) [1] ('c',3) [1]+prettyPrint :: (Show k, Show a) => RBST k a -> IO ()+prettyPrint = putStrLn . pretty++-- | Comptact 2-dimensional ASCII drawing of a 'RBST'.+--+-- See 'RBST.Pretty.comptactPrint' for an example.+compact :: (Show k, Show a) => RBST k a -> String+compact = withTree drawComptact++-- | Call 'comptact' function and output the result directly to @stdout@.+--+-- >>> let tree = (fromList $ zip ['a'..'e'] [1..5]) :: RBST Char Int+-- >>> compactPrint tree+-- ('d',4) [5]+-- |+-- |-- ('e',5) [1]+-- |+-- \__ ('b',2) [3]+-- |+-- |-- ('c',3) [1]+-- |+-- \__ ('a',1) [1]+-- <BLANKLINE>+compactPrint :: (Show k, Show a) => RBST k a -> IO ()+compactPrint = putStrLn . compact++----------------------------------------------+-- Internal functions+----------------------------------------------++-- | Shows a 'RBST.Internal.Node' with the size attached to it.+showNode :: (Show k, Show a) => Size -> k -> a -> String+showNode s k x = "(" ++ show k ++ "," ++ show x ++ ") [" ++ (show (unSize s)) ++ "]"++-- | Draw a 'Tree' using one of the visualization modes.+drawComptact, drawPretty :: (Show k, Show a) => Tree k a -> String+drawComptact = unlines . comptactWith showNode+drawPretty = prettyWith showNode++-- | Show 'Tree' in a comptact way using given function to display node.+comptactWith+ :: forall k a .+ (Size -> k -> a -> String)+ -> Tree k a+ -> [String]+comptactWith _ Empty = []+comptactWith display (Node s k Empty x Empty) = [display s k x]+comptactWith display (Node s k l x r) = [nodeASCII] ++ drawSubTrees+ where+ nodeASCII = display s k x++ drawSubTrees =+ let drawR = ws "|" : shift (ws "|-- ") (ws "| ") (comptactWith display r)+ drawL = ws "|" : shift (ws "\\__ ") (ws " ") (comptactWith display l)+ in drawR ++ drawL++ ws = (++) (spaces (length nodeASCII `div` 2))++ shift first other = zipWith (++) (first : repeat other)++--------------------------------------------------------------------------------+-- The following code is copied from 'Treap.Pretty.+--+-- All credit to the authors.+--------------------------------------------------------------------------------++-- | Show 'Tree' in a pretty way using given function to display node.+prettyWith+ :: forall k a.+ (Size -> k -> a -> String)+ -> Tree k a+ -> String+prettyWith display = showTree . toBinTree+ where+ toBinTree :: Tree k a -> BinTree+ toBinTree Empty = Leaf+ toBinTree (Node s k l x r) = Branch (display s k x) (toBinTree l) (toBinTree r)++-- | Intermidiate structure to help string conversion.+data BinTree+ = Leaf+ | Branch String BinTree BinTree++-- | Hardcore function responsible for pretty showing of the 'BinTree' data type.+showTree :: BinTree -> String+showTree Leaf = ""+showTree (Branch label left right) = case (left, right) of+ (Leaf, Leaf) -> label++ (_, Leaf) -> toLines $+ [ spaces rootShiftOnlyLeft ++ label+ , spaces branchShiftOnlyLeft ++ "╱"+ ] ++ map (spaces leftShiftOnlyLeft ++) leftLines++ (Leaf, _) -> toLines $+ [ spaces rootShiftOnlyRight ++ label+ , spaces branchShiftOnlyRight ++ "╲"+ ] ++ map (spaces rightShiftOnlyRight ++) rightLines++ (_, _) -> toLines $+ [ spaces rootOffset ++ label+ ]+ ++ map (spaces rootOffset ++ ) (branchLines branchHeight)+ ++ map (spaces childrenOffset ++) (zipChildren leftLines rightLines)+ where+ leftStr, rightStr :: String+ leftStr = showTree left+ rightStr = showTree right++ leftLines :: [String]+ leftLines = lines leftStr+ rightLines = lines rightStr++ rootLabelMiddle, leftLabelMiddle, rightLabelMiddle :: Int+ rootLabelMiddle = middleLabelPos label+ leftLabelMiddle = middleLabelPos $ head leftLines+ rightLabelMiddle = middleLabelPos $ head rightLines++ -- Case 1: all offsets when node has only left branch+ rootShiftOnlyLeft, leftShiftOnlyLeft, branchShiftOnlyLeft :: Int+ (rootShiftOnlyLeft, leftShiftOnlyLeft) = case compare rootLabelMiddle leftLabelMiddle of+ EQ -> (1, 0)+ GT -> (0, rootLabelMiddle - leftLabelMiddle - 1)+ LT -> (leftLabelMiddle - rootLabelMiddle + 1, 0)+ branchShiftOnlyLeft = rootLabelMiddle + rootShiftOnlyLeft - 1++ -- Case 2: all offsets when node has only right branch+ rootShiftOnlyRight, rightShiftOnlyRight, branchShiftOnlyRight :: Int+ (rootShiftOnlyRight, rightShiftOnlyRight) = case compare rootLabelMiddle rightLabelMiddle of+ EQ -> (0, 1)+ GT -> (0, rootLabelMiddle - rightLabelMiddle + 1)+ LT -> (rightLabelMiddle - rootLabelMiddle - 1, 0)+ branchShiftOnlyRight = rootLabelMiddle + rootShiftOnlyRight + 1++ -- Case 3: both+ leftWidth, rightOffMiddle, childDistance, branchHeight, rootMustMiddle :: Int+ leftWidth = 1 + maximum (map length leftLines)+ rightOffMiddle = leftWidth + rightLabelMiddle+ childDistance = rightOffMiddle - leftLabelMiddle+ branchHeight = childDistance `div` 2+ rootMustMiddle = (leftLabelMiddle + rightOffMiddle) `div` 2++ rootOffset, childrenOffset :: Int+ (rootOffset, childrenOffset) = case compare rootLabelMiddle rootMustMiddle of+ EQ -> (0, 0)+ LT -> (rootMustMiddle - rootLabelMiddle, 0)+ GT -> (0, rootLabelMiddle - rootMustMiddle)++ zipChildren :: [String] -> [String] -> [String]+ zipChildren l [] = l+ zipChildren [] r = map (spaces leftWidth ++ ) r+ zipChildren (x:xs) (y:ys) =+ let xLen = length x+ newX = x ++ spaces (leftWidth - xLen)+ in (newX ++ y) : zipChildren xs ys++-- | Generates strings containing of @n@ spaces.+spaces :: Int -> String+spaces n = replicate n ' '++{- | Calculates position of middle of non-space part of the string.++>>> s = " abc "+>>> length s+7+>>> middleLabelPos s+4+-}+middleLabelPos :: String -> Int+middleLabelPos s =+ let (spacePrefix, rest) = span isSpace s+ in length spacePrefix + (length (dropWhileEnd isSpace rest) `div` 2)++-- | Like 'unlines' but doesn't add "\n" to the end.+toLines :: [String] -> String+toLines = intercalate "\n"++{- | Draws branches of the given height.++>>> putStrLn $ toLines $ branchLines 1+╱╲++>>> putStrLn $ toLines $ branchLines 2+ ╱╲+╱ ╲++>>> putStrLn $ toLines $ branchLines 3+ ╱╲+ ╱ ╲+╱ ╲+-}+branchLines :: Int -> [String]+branchLines n = go 0+ where+ go :: Int -> [String]+ go i+ | i == n = []+ | otherwise = line : go (i + 1)+ where+ line :: String+ line = spaces (n - i - 1) ++ "╱" ++ spaces (2 * i) ++ "╲"
+ test/Doctest.hs view
@@ -0,0 +1,50 @@+module Main (main) where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = do+ sourceFiles <- glob "src/**/*.hs"+ doctest+ $ "-XAllowAmbiguousTypes"+ : "-XBangPatterns"+ : "-XConstraintKinds"+ : "-XDataKinds"+ : "-XDefaultSignatures"+ : "-XDeriveAnyClass"+ : "-XDeriveDataTypeable"+ : "-XDeriveFoldable"+ : "-XDeriveFunctor"+ : "-XDeriveGeneric"+ : "-XDeriveTraversable"+ : "-XDerivingStrategies"+ : "-XDerivingVia"+ : "-XDuplicateRecordFields"+ : "-XEmptyCase"+ : "-XEmptyDataDecls"+ : "-XFlexibleContexts"+ : "-XFlexibleInstances"+ : "-XFunctionalDependencies"+ : "-XGADTs"+ : "-XGeneralizedNewtypeDeriving"+ : "-XInstanceSigs"+ : "-XKindSignatures"+ : "-XLambdaCase"+ : "-XNamedFieldPuns"+ : "-XOverloadedStrings"+ : "-XPolyKinds"+ : "-XQuasiQuotes"+ : "-XRankNTypes"+ : "-XRecordWildCards"+ : "-XScopedTypeVariables"+ : "-XStandaloneDeriving"+ : "-XTemplateHaskell"+ : "-XTupleSections"+ : "-XTypeApplications"+ : "-XTypeFamilies"+ : "-XTypeOperators"+ : "-XUndecidableInstances"+ : "-XRoleAnnotations"+ : sourceFiles+
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Test/Common.hs view
@@ -0,0 +1,18 @@+module Test.Common (+ TestRBST+ , smallRBST+ , describedAs+ ) where++import GHC.Exts (IsList (..))+import RBST (RBST)+import Test.Hspec.Expectations (Expectation, shouldBe)++type TestRBST = RBST Char Int++smallRBST :: TestRBST+smallRBST = fromList $ zip ['A'..'E'] [1..5]++describedAs :: TestRBST -> [(Char, Int)] -> Expectation+describedAs tree expectedTreeNodes = toList tree `shouldBe` expectedTreeNodes+infixr 8 `describedAs`
+ test/Test/RBST/CutsSpec.hs view
@@ -0,0 +1,53 @@+module Test.RBST.CutsSpec (+ spec+ ) where++import Test.Common (describedAs, smallRBST)+import Test.Hspec (Spec, describe, it, shouldBe)++import qualified RBST++spec :: Spec+spec = describe "Cuts tests" $ do+ takeSpec+ dropSpec+ removeSpec++takeSpec :: Spec+takeSpec = describe "take" $ do+ it "take negative returns an empty tree" $+ RBST.take (-1) smallRBST `shouldBe` RBST.empty+ it "take 0 returns an empty tree" $+ RBST.take 0 smallRBST `shouldBe` RBST.empty+ it "take size returns tree itself" $+ RBST.take 5 smallRBST `shouldBe` smallRBST+ it "take 2 returns first two elements" $+ RBST.take 2 smallRBST `describedAs` [('A', 1), ('B', 2)]+ it "take 4 returns first four elements" $+ RBST.take 4 smallRBST `describedAs` [('A', 1), ('B', 2), ('C', 3), ('D', 4)]++dropSpec :: Spec+dropSpec = describe "drop" $ do+ it "drop negative returns tree itself" $+ RBST.drop (-1) smallRBST `shouldBe` smallRBST+ it "drop 0 returns tree itself" $+ RBST.drop 0 smallRBST `shouldBe` smallRBST+ it "drop size returns empty tree" $+ RBST.drop 5 smallRBST `shouldBe` RBST.empty+ it "drop 2 returns first two elements" $+ RBST.drop 2 smallRBST `describedAs` [('C', 3), ('D', 4), ('E', 5)]+ it "drop 4 returns first four elements" $+ RBST.drop 4 smallRBST `describedAs` [('E', 5)]++removeSpec :: Spec+removeSpec = describe "remove" $ do+ it "remove negative returns the tree itself" $+ RBST.remove (-1) smallRBST `shouldBe` smallRBST+ it "remove size returns the tree itself" $+ RBST.remove 5 smallRBST `shouldBe` smallRBST+ it "remove 0 removes the first element of the tree" $+ RBST.remove 0 smallRBST `describedAs` [('B', 2), ('C', 3), ('D', 4), ('E', 5)]+ it "remove 2 removes the 2th element of the tree" $+ RBST.remove 2 smallRBST `describedAs` [('A', 1), ('B', 2), ('D', 4), ('E', 5)]+ it "remove 4 removes the 4th element of the tree" $+ RBST.remove 4 smallRBST `describedAs` [('A', 1), ('B', 2), ('C', 3), ('D', 4)]
+ test/Test/RBST/LawsSpec.hs view
@@ -0,0 +1,46 @@+module Test.RBST.LawsSpec (+ spec+ ) where++import GHC.Exts (IsList (..))+import Test.Common (TestRBST)+import Test.Hspec (Spec, describe)+import Test.Hspec.QuickCheck (prop)+import Test.QuickCheck+import RBST.Pretty (compact)++spec :: Spec+spec = describe "Law abiding instances" $ do+ --semigroupSpec+ monoidSpec++-- | Semigroup is not lawful until unionWith is implemented.++-- semigroupSpec :: Spec+-- semigroupSpec = describe "Semigroup" $+-- prop "associativity" $+-- forAllShow arbitraryTree compact $ \a -> do+-- forAllShow arbitraryTree compact $ \b -> do+-- forAllShow arbitraryTree compact $ \c -> do+-- (a <> b) <> c `iso` a <> (b <> c)++monoidSpec :: Spec+monoidSpec = describe "Monoid" $+ prop "identity" $+ forAllShow arbitraryTree compact $ \a -> do+ (a <> mempty) `iso` a .&&. (mempty <> a) `iso` a+++----------------------------------------+----------------------------------------++arbitraryTree :: Gen TestRBST+arbitraryTree = do+ n <- choose (0, 100)+ xs <- vectorOf n arbitrary+ return $ fromList xs++-- | '(===)' for trees.+iso :: TestRBST -> TestRBST -> Property+t1 `iso` t2 = toList t1 === toList t2+infix 4 `iso`
+ test/Test/RBST/QuerySpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TupleSections #-}+module Test.RBST.QuerySpec (+ spec+ ) where++import GHC.Exts (IsList (..))+import Test.Common (TestRBST, smallRBST)+import Test.Hspec (Spec, describe, it, shouldBe)++import qualified RBST++spec :: Spec+spec = describe "Query tests" $ do+ sizeSpec+ heightSpec+ isListSpec+ lookupSpec+ atSpec++sizeSpec :: Spec+sizeSpec = describe "size" $ do+ it "size of empty RBST is 0" $+ RBST.size (RBST.empty :: TestRBST) `shouldBe` 0+ it "size of single node RBST is 1" $+ RBST.size (RBST.one 'A' 0 :: TestRBST) `shouldBe` 1+ it "size of smallRBST is 5" $+ RBST.size smallRBST `shouldBe` 5++heightSpec :: Spec+heightSpec = describe "height" $ do+ it "height of empty RBST is -1" $+ RBST.height (RBST.empty :: TestRBST) `shouldBe` -1+ it "height of single node RBST is 0" $+ RBST.height (RBST.one 'A' 0 :: TestRBST) `shouldBe` 0+ it "height of smallRBST is 2" $+ RBST.height smallRBST `shouldBe` 2++isListSpec :: Spec+isListSpec = describe "fromList/toList" $ do+ it "toList smallRBST is [1..5]" $+ toList smallRBST `shouldBe` zip ['A'..'E'] [1..5 :: Int]+ it "toList should sort by key" $+ let sort = fmap fst . toList @(RBST.RBST Int ()) . fromList . fmap (,())+ in sort [2,5,1,4,3] `shouldBe` [1..5 :: Int]++lookupSpec :: Spec+lookupSpec = describe "lookup" $ do+ it "lookup by keys are correct" $+ map (`RBST.lookup` smallRBST) ['A'..'F'] `shouldBe`+ [Just 1, Just 2, Just 3, Just 4, Just 5, Nothing]++atSpec :: Spec+atSpec = describe "at" $ do+ it "elements by indices are correct" $+ map (`RBST.at` smallRBST) [-1..5] `shouldBe`+ [Nothing, Just ('A',1), Just ('B',2), Just ('C',3), Just ('D',4), Just ('E',5), Nothing]
+ test/Test/RBST/SetOpsSpec.hs view
@@ -0,0 +1,46 @@+module Test.RBST.SetOpsSpec (+ spec+ ) where++import Test.Hspec (Spec, describe, it)+import Test.Common (TestRBST, describedAs)+import GHC.Exts (IsList(..))++import RBST (union)+import qualified RBST++spec :: Spec+spec = describe "Set operations tests" $ do+ unionSpec+ intersectionSpec+ subtractionSpec+ differenceSpec++unionSpec :: Spec+unionSpec = describe "union" $ do+ it "union of two trees works" $+ tree1 `union` tree2 `describedAs` [('A', 1), ('B', 0), ('C', 3), ('D', 4)]++intersectionSpec :: Spec+intersectionSpec = describe "intersection" $ do+ it "intersection of two trees works" $+ RBST.intersection tree1 tree2 `describedAs` [('B', 2)]++subtractionSpec :: Spec+subtractionSpec = describe "subtraction" $ do+ it "subtraction of two trees works" $+ RBST.subtraction tree1 tree2 `describedAs` [('A', 1)]++differenceSpec :: Spec+differenceSpec = describe "difference" $ do+ it "difference of two trees works" $+ RBST.difference tree1 tree2 `describedAs` [('A', 1), ('C', 3), ('D', 4)]++--------------------------------------------------------+--------------------------------------------------------++tree1 :: TestRBST+tree1 = fromList [('A', 1), ('B', 2)]++tree2 :: TestRBST+tree2 = fromList [('B', 0), ('C', 3), ('D', 4)]
+ test/Test/RBST/UpdateSpec.hs view
@@ -0,0 +1,37 @@+module Test.RBST.UpdateSpec (+ spec+ ) where++import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Common (smallRBST, describedAs)++import qualified RBST++spec :: Spec+spec = describe "Modification operations tests" $ do+ insertSpec+ deleteSpec++insertSpec :: Spec+insertSpec = describe "insert" $ do+ it "insert on empty tree works" $+ RBST.insert 'A' 1 RBST.empty `describedAs` [('A', 1)]+ it "insert on test tree works" $+ RBST.insert 'F' 6 smallRBST `describedAs` [('A', 1), ('B', 2), ('C', 3), ('D', 4), ('E', 5), ('F', 6)]+ it "insert a repeated key should update the item" $+ RBST.insert 'E' 0 smallRBST `describedAs` [('A', 1), ('B', 2), ('C', 3), ('D', 4), ('E', 0)]++deleteSpec :: Spec+deleteSpec = describe "delete" $ do+ it "delete removes a key from the tree" $+ RBST.delete 'E' smallRBST `describedAs` [('A', 1), ('B', 2), ('C', 3), ('D', 4)]+ it "delete a missing key has no effect" $+ RBST.delete 'F' smallRBST `shouldBe` smallRBST+ it "delete should work on empty trees" $+ ( RBST.delete 'A'+ $ RBST.delete 'B'+ $ RBST.delete 'C'+ $ RBST.delete 'D'+ $ RBST.delete 'E'+ $ RBST.delete 'E'+ smallRBST ) `shouldBe` RBST.empty