EdisonCore 1.2.2.1 → 1.3.3.3
raw patch · 29 files changed
Files
- CHANGES.md +123/−0
- COPYRIGHT +25/−23
- EdisonCore.cabal +81/−67
- src/Data/Edison/Assoc/AssocList.hs +628/−624
- src/Data/Edison/Assoc/Defaults.hs +315/−312
- src/Data/Edison/Assoc/PatriciaLoMap.hs +854/−847
- src/Data/Edison/Assoc/StandardMap.hs +362/−368
- src/Data/Edison/Assoc/TernaryTrie.hs +1300/−1165
- src/Data/Edison/Coll/Defaults.hs +249/−246
- src/Data/Edison/Coll/EnumSet.hs +808/−798
- src/Data/Edison/Coll/LazyPairingHeap.hs +572/−565
- src/Data/Edison/Coll/LeftistHeap.hs +497/−491
- src/Data/Edison/Coll/MinHeap.hs +410/−406
- src/Data/Edison/Coll/SkewHeap.hs +465/−458
- src/Data/Edison/Coll/SplayHeap.hs +498/−494
- src/Data/Edison/Coll/StandardSet.hs +265/−272
- src/Data/Edison/Coll/UnbalancedSet.hs +444/−438
- src/Data/Edison/Concrete/FingerTree.hs +788/−787
- src/Data/Edison/Seq/BankersQueue.hs +440/−422
- src/Data/Edison/Seq/BinaryRandList.hs +468/−452
- src/Data/Edison/Seq/BraunSeq.hs +567/−552
- src/Data/Edison/Seq/Defaults.hs +516/−512
- src/Data/Edison/Seq/FingerSeq.hs +402/−385
- src/Data/Edison/Seq/JoinList.hs +443/−426
- src/Data/Edison/Seq/MyersStack.hs +453/−438
- src/Data/Edison/Seq/RandList.hs +500/−482
- src/Data/Edison/Seq/RevSeq.hs +399/−382
- src/Data/Edison/Seq/SimpleQueue.hs +391/−374
- src/Data/Edison/Seq/SizedSeq.hs +373/−355
+ CHANGES.md view
@@ -0,0 +1,123 @@+# Edison + +Changelog of EdisonAPI and EdisonCore. + +[Latest CHANGES.md](https://github.com/robdockins/edison/blob/master/CHANGES.md) + +## 1.3.3.3 +* Compatibility with GHC 9.14 +* Fix balance of TernaryTrie (fixes performance in pathological cases) +* Resolve warnings and remove spurious array dependency + +## 1.3.3.2 +* Compatibility with GHC 9.10 and 9.12 + +## 1.3.3.1 +* Remove mtl dependency (removed unnecessary imports which were incompatible with mtl 2.3) +* Fix implementation of little-endian PatriciaTrees + +## 1.3.3 +* Updates to handle MonadFail changes in GHC 8.x +* Updates to fix compile issues in GHC 9 + +## 1.3.2.1 +* Fix compile problems on GHC 7.10 + +## 1.3.2 +* Add Semigroup instances for all types that previously had Monoid instances. +* Remove use of depreciated functions in Data.Edison.Assoc.StandardMap + +## 1.3.1 +* Remove Arbitrary and Coarbitrary instances for Data.Set + and Data.Map. These are now provided by QuickCheck >= 2.8.2 + +## 1.3 +* Updates to compile with GHC 7.10 + - Added Applicative and Alternative instances as required + - Disambiguate the types of some operations + - Resolve namespace clashes +* Added stack.yaml file to build with stack + +## 1.2.2 + * Update edison-core to use QuickCheck version 2.* + * Likewise update the test suite + +## 1.2.1.3 +* Minor fix to the StandardMap module to handle the API change in GHC 6.10 + +## 1.2.1.2 +* Build system changes to remove mostly-superfulous dependency on + haskell98, and to force dependence on the 1.x branch of QuickCheck. + +## 1.2.1.1 +* Build system changes to make GHC 6.8 and cabal >= 1.2.2 happy + +## 1.2.1 +* New sequence implementation based on Finger Trees +* Add the 'Measured' class to the Data.Edison.Prelude +* Addition of methods to EnumSet to project to a bit-encoded word and to + create an EnumSet from a bit-encoded word +* Additional minor changes to EnumSet +* Fix a boneheaded mistake I made where I claimed most of Edison was + licensed under BSD3, when it is in fact licensed under the MIT license. + The practical differences are minor, and I hope this will not cause too + many problems. + +## 1.2.0.1 +* Change use more efficient operations for StandardSet.{filterGT,filterLT} + and StandardMap.{filterLE,filterGE,partitionLE_GT,partitionLT_GE} + +## 1.2 final +* Fix documentation for sequences to reflect correct + time complexities + +## 1.2rc4 +* introduce strict/strictWith operations for all APIs +* add Ord* instances for PatriciaLoMap and TernaryTrie +* add David F. Place's EnumSet implementation +* complete the FiniteMap unit test coverage and fix a bunch + of bugs in finite map implementations +* add 'symmetricDifference' to Collection and + Associated Collection APIs +* add Ord instances for data structures +* add Monoid instances for data structures + + +## 1.2rc3 +* introduce the ambiguous/unambiguous concept and document + all API operations +* factor out methods which "mirror" superclass methods and + make them alises instead +* add lookupAndDelete* methods to associated collections +* change the type of adjustOrDelete* in associated collections +* rename subset/subsetEq to properSubset/subset +* add matching Read and Show instances for all concrete datastructures +* add properSubmap{By} submap{By} and sameMap{By} to the + associated collection API +* add Eq instances for concrete associated collections +* break out the test suite into a separate sub-package + + +## 1.2rc2 +* add strict variants of all folds and reduces +* reverse argument orders to 'rcons' and 'lookup*' in Sequence +* add symbolic operators for lcons, rcons, append, and lookup + from the Sequence API +* add symbolic operators for subsetEq, difference, intersection + and union from the set API +* rename 'single' to 'singleton' in all APIs +* reaame 'intersect' to 'intersection' in Collection and + Associated Collection APIs +* add 'adjustOrInsert' to the Associated Collection API + + +## 1.2rc1 +* modules re-organized into a hierarchy +* user's guide distributed throughout source code as Haddock comments +* use cabal for build system +* add Data.Edison module to re-export typeclasses +* reorder 'lookup*' and 'find*' methods for + Collections and Associated Collections +* add 'unsafeMapMonotonic' to main Collection API +* organize QuickCheck properties into a full test suite +* add a 'structuralInvariant' method to all APIs, for unit testing
COPYRIGHT view
@@ -1,23 +1,25 @@-Copyright (c) 1998-1999 Chris Okasaki-Portions Copyright (c) 2002 Andrew Bromage-Portions Copyright (c) 2006-2007 Robert Dockins-Portions Copyright (c) 2006 David F. Place-Portions Copyright (c) 2006 Ross Paterson and Ralf Hinze--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.+Copyright (c) 1998-1999 Chris Okasaki +Portions Copyright (c) 2002 Andrew Bromage +Portions Copyright (c) 2006-2007 Robert Dockins +Portions Copyright (c) 2006 David F. Place +Portions Copyright (c) 2006 Ross Paterson and Ralf Hinze +Portions Copyright (c) 2006-2022 Robert Dockins +Portions Copyright (c) 2022-2025 Li-yao Xia + +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.
EdisonCore.cabal view
@@ -1,67 +1,81 @@-Name: EdisonCore-Cabal-Version: >= 1.2.3-Build-Type: Simple-Version: 1.2.2.1-License: OtherLicense-License-File: COPYRIGHT-Author: Chris Okasaki-Maintainer: robdockins AT fastmail DOT fm-Synopsis: A library of efficent, purely-functional data structures (Core Implementations)-Category: Data Structures-Homepage: http://rwd.rdockins.name/edison/home/-Stability: Stable-Description:- This package provides the core Edison data structure implementations,- including multiple sequence, set, bag, and finite map concrete- implementations with various performance characteristics. The- implementations in this package have no dependencies other than those- commonly bundled with Haskell compilers.--Library- Hs-Source-Dirs: src- Exposed-modules:- Data.Edison.Assoc.Defaults- Data.Edison.Assoc.AssocList- Data.Edison.Assoc.PatriciaLoMap- Data.Edison.Assoc.StandardMap- Data.Edison.Assoc.TernaryTrie- Data.Edison.Concrete.FingerTree- Data.Edison.Coll.Defaults- Data.Edison.Coll.LazyPairingHeap- Data.Edison.Coll.LeftistHeap- Data.Edison.Coll.MinHeap- Data.Edison.Coll.SkewHeap- Data.Edison.Coll.SplayHeap- Data.Edison.Coll.StandardSet- Data.Edison.Coll.EnumSet- Data.Edison.Coll.UnbalancedSet- Data.Edison.Seq.Defaults- Data.Edison.Seq.BankersQueue- Data.Edison.Seq.BinaryRandList- Data.Edison.Seq.BraunSeq- Data.Edison.Seq.FingerSeq- Data.Edison.Seq.JoinList- Data.Edison.Seq.MyersStack- Data.Edison.Seq.RandList- Data.Edison.Seq.RevSeq- Data.Edison.Seq.SimpleQueue- Data.Edison.Seq.SizedSeq- Build-Depends:- base < 5,- mtl,- QuickCheck >= 2.0 && < 3,- EdisonAPI == 1.2.2.1- if impl( ghc >= 6.8 )- Build-Depends:- containers, array- Extensions:- MultiParamTypeClasses- FunctionalDependencies- UndecidableInstances- FlexibleInstances- CPP- MagicHash- ScopedTypeVariables- GeneralizedNewtypeDeriving- FlexibleContexts- Ghc-Options: -funbox-strict-fields -fwarn-incomplete-patterns+Name: EdisonCore +Cabal-Version: >= 1.10 +Build-Type: Simple +Version: 1.3.3.3 +License: MIT +License-File: COPYRIGHT +Author: Chris Okasaki +Maintainer: lysxia@gmail.com +Synopsis: A library of efficient, purely-functional data structures (Core Implementations) +Category: Data Structures +Homepage: https://github.com/robdockins/edison +Stability: Stable +Description: + This package provides the core Edison data structure implementations, + including multiple sequence, set, bag, and finite map concrete + implementations with various performance characteristics. The + implementations in this package have no dependencies other than those + commonly bundled with Haskell compilers. +Extra-Source-Files: CHANGES.md +tested-with: GHC == 8.10.7, GHC == 9.6.7, GHC == 9.12.1, GHC == 9.14.1 + +Source-Repository head + Type: git + Location: https://github.com/robdockins/edison/ + Subdir: edison-core + +Library + Hs-Source-Dirs: src + Exposed-modules: + Data.Edison.Assoc.Defaults + Data.Edison.Assoc.AssocList + Data.Edison.Assoc.PatriciaLoMap + Data.Edison.Assoc.StandardMap + Data.Edison.Assoc.TernaryTrie + Data.Edison.Concrete.FingerTree + Data.Edison.Coll.Defaults + Data.Edison.Coll.LazyPairingHeap + Data.Edison.Coll.LeftistHeap + Data.Edison.Coll.MinHeap + Data.Edison.Coll.SkewHeap + Data.Edison.Coll.SplayHeap + Data.Edison.Coll.StandardSet + Data.Edison.Coll.EnumSet + Data.Edison.Coll.UnbalancedSet + Data.Edison.Seq.Defaults + Data.Edison.Seq.BankersQueue + Data.Edison.Seq.BinaryRandList + Data.Edison.Seq.BraunSeq + Data.Edison.Seq.FingerSeq + Data.Edison.Seq.JoinList + Data.Edison.Seq.MyersStack + Data.Edison.Seq.RandList + Data.Edison.Seq.RevSeq + Data.Edison.Seq.SimpleQueue + Data.Edison.Seq.SizedSeq + Build-Depends: + base >= 4.12 && < 4.23, + QuickCheck >= 2.8.2 && < 3, + EdisonAPI >= 1.3.3 && < 1.4, + containers < 0.8 + + if impl(ghc < 8.0) + Build-Depends: + fail < 5, + -- Provide/emulate Data.Semigroups` API for pre-GHC-8 + semigroups == 0.18.* + + Default-Language: Haskell2010 + Default-Extensions: + MultiParamTypeClasses + FunctionalDependencies + UndecidableInstances + FlexibleInstances + CPP + MagicHash + ScopedTypeVariables + GeneralizedNewtypeDeriving + FlexibleContexts + Ghc-Options: -funbox-strict-fields -Wall -Wno-name-shadowing -Wno-noncanonical-monad-instances + if impl(ghc >= 8.0) + Ghc-Options: -Wcompat
src/Data/Edison/Assoc/AssocList.hs view
@@ -1,624 +1,628 @@--- |--- Module : Data.Edison.Assoc.AssocList--- Copyright : Copyright (c) 1998, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ This module implements finite maps as simple association lists.------ Duplicates are removed conceptually, but not physically. The first--- occurrence of a given key is the one that is considered to be in the map.------ The list type is mildly customized to prevent boxing the pairs.--module Data.Edison.Assoc.AssocList (- -- * Type of simple association lists- FM, -- instance of Assoc(X), FiniteMap(X)- -- also instance of Functor-- -- * AssocX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,- lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,- lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,- adjustOrDelete,adjustOrDeleteAll,strict,strictWith,- map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,-- -- * OrdAssocX operations- minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,- unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',- foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend,- filterLT, filterLE, filterGT, filterGE,- partitionLT_GE, partitionLE_GT, partitionLT_GT,-- -- * Assoc operations- toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,-- -- * OrdAssoc operations- minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,- foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,-- -- * FiniteMapX operations- fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,- insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,- difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,- properSubmap,submap,sameMap,-- -- * FiniteMap operations- unionWithKey,unionSeqWithKey,intersectionWithKey,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)-import qualified Prelude-import Data.Monoid-import Control.Monad.Identity-import qualified Data.Edison.Assoc as A-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.BinaryRandList as RL-import Data.Edison.Assoc.Defaults-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant)---- signatures for exported functions-moduleName :: String-empty :: Eq k => FM k a-singleton :: Eq k => k -> a -> FM k a-fromSeq :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a-insert :: Eq k => k -> a -> FM k a -> FM k a-insertSeq :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a-union :: Eq k => FM k a -> FM k a -> FM k a-unionSeq :: (Eq k,S.Sequence seq) => seq (FM k a) -> FM k a-delete :: Eq k => k -> FM k a -> FM k a-deleteAll :: Eq k => k -> FM k a -> FM k a-deleteSeq :: (Eq k,S.Sequence seq) => seq k -> FM k a -> FM k a-null :: Eq k => FM k a -> Bool-size :: Eq k => FM k a -> Int-member :: Eq k => k -> FM k a -> Bool-count :: Eq k => k -> FM k a -> Int-lookup :: Eq k => k -> FM k a -> a-lookupM :: (Eq k, Monad rm) => k -> FM k a -> rm a-lookupAll :: (Eq k,S.Sequence seq) => k -> FM k a -> seq a-lookupAndDelete :: Eq k => k -> FM k a -> (a,FM k a)-lookupAndDeleteM :: (Eq k,Monad rm) => k -> FM k a -> rm (a,FM k a)-lookupAndDeleteAll :: (Eq k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)-lookupWithDefault :: Eq k => a -> k -> FM k a -> a-adjust :: Eq k => (a -> a) -> k -> FM k a -> FM k a-adjustAll :: Eq k => (a -> a) -> k -> FM k a -> FM k a-adjustOrInsert :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustAllOrInsert :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustOrDelete :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a-adjustOrDeleteAll :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a-strict :: FM k a -> FM k a-strictWith :: (a -> b) -> FM k a -> FM k a-map :: Eq k => (a -> b) -> FM k a -> FM k b-fold :: Eq k => (a -> b -> b) -> b -> FM k a -> b-fold1 :: Eq k => (a -> a -> a) -> FM k a -> a-fold' :: Eq k => (a -> b -> b) -> b -> FM k a -> b-fold1' :: Eq k => (a -> a -> a) -> FM k a -> a-filter :: Eq k => (a -> Bool) -> FM k a -> FM k a-partition :: Eq k => (a -> Bool) -> FM k a -> (FM k a, FM k a)-elements :: (Eq k,S.Sequence seq) => FM k a -> seq a--fromSeqWith :: (Eq k,S.Sequence seq) =>- (a -> a -> a) -> seq (k,a) -> FM k a-fromSeqWithKey :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a-insertWith :: Eq k => (a -> a -> a) -> k -> a -> FM k a -> FM k a-insertWithKey :: Eq k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a-insertSeqWith :: (Eq k,S.Sequence seq) =>- (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a-insertSeqWithKey :: (Eq k,S.Sequence seq) =>- (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a-unionl :: Eq k => FM k a -> FM k a -> FM k a-unionr :: Eq k => FM k a -> FM k a -> FM k a-unionWith :: Eq k => (a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWith :: (Eq k,S.Sequence seq) =>- (a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWith :: Eq k => (a -> b -> c) -> FM k a -> FM k b -> FM k c-difference :: Eq k => FM k a -> FM k b -> FM k a-properSubset :: Eq k => FM k a -> FM k b -> Bool-subset :: Eq k => FM k a -> FM k b -> Bool-properSubmapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-submapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-sameMapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-properSubmap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool-submap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool-sameMap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool--toSeq :: (Eq k,S.Sequence seq) => FM k a -> seq (k,a)-keys :: (Eq k,S.Sequence seq) => FM k a -> seq k-mapWithKey :: Eq k => (k -> a -> b) -> FM k a -> FM k b-foldWithKey :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-foldWithKey' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-filterWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> FM k a-partitionWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> (FM k a, FM k a)--unionWithKey :: Eq k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWithKey :: (Eq k,S.Sequence seq) =>- (k -> a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWithKey :: Eq k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c--minView :: (Ord k,Monad m) => FM k a -> m (a,FM k a)-minElem :: Ord k => FM k a -> a-deleteMin :: Ord k => FM k a -> FM k a-unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a-maxView :: (Ord k,Monad m) => FM k a -> m (a,FM k a)-maxElem :: Ord k => FM k a -> a-deleteMax :: Ord k => FM k a -> FM k a-unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a-foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a-foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a-foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a-foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a-unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a-unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a-filterLT :: Ord k => k -> FM k a -> FM k a-filterLE :: Ord k => k -> FM k a -> FM k a-filterGT :: Ord k => k -> FM k a -> FM k a-filterGE :: Ord k => k -> FM k a -> FM k a-partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a)--minViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)-minElemWithKey :: Ord k => FM k a -> (k,a)-maxViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)-maxElemWithKey :: Ord k => FM k a -> (k,a)-foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b-foldrWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey' :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b-toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)---moduleName = "Data.Edison.Assoc.AssocList"---data FM k a = E | I k a (FM k a)---- no invariants-structuralInvariant :: Eq k => FM k a -> Bool-structuralInvariant = const True-------------------------------------------- some unexported utility functions---- uncurried insert.-uinsert :: (t, t1) -> FM t t1 -> FM t t1-uinsert (k,x) = I k x----- left biased merge.-mergeFM :: (Ord t) => FM t t1 -> FM t t1 -> FM t t1-mergeFM E m = m-mergeFM m E = m-mergeFM o1@(I k1 a1 m1) o2@(I k2 a2 m2) =- case compare k1 k2 of- LT -> I k1 a1 (mergeFM m1 o2)- GT -> I k2 a2 (mergeFM o1 m2)- EQ -> I k1 a1 (mergeFM m1 m2)--toRandList :: FM t t1 -> RL.Seq (FM t t1)-toRandList E = RL.empty-toRandList (I k a m) = RL.lcons (I k a E) (toRandList m)--mergeSortFM :: (Ord t) => FM t t1 -> FM t t1-mergeSortFM m = RL.reducer mergeFM E (toRandList m)--foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b-foldrFM _ z E = z-foldrFM f z (I k a m) = f a (foldrFM f z (delete k m))--foldr1FM :: Eq k => (a -> a -> a) -> FM k a -> a-foldr1FM _ (I _ a E) = a-foldr1FM f (I k a m) = f a (foldr1FM f (delete k m))-foldr1FM _ _ = error "invalid call to foldr1FM on empty map"--foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b-foldrFM' _ z E = z-foldrFM' f z (I k a m) = f a $! (foldrFM' f z (delete k m))--foldr1FM' :: Eq k => (a -> a -> a) -> FM k a -> a-foldr1FM' _ (I _ a E) = a-foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m))-foldr1FM' _ _ = error "invalid call to foldr1FM' on empty map"--foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b-foldlFM _ x E = x-foldlFM f x (I k a m) = foldlFM f (f x a) (delete k m)--foldlFM' :: Eq k => (b -> a -> b) -> b -> FM k a -> b-foldlFM' _ x E = x-foldlFM' f x (I k a m) = x `seq` foldlFM' f (f x a) (delete k m)--foldrWithKeyFM :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-foldrWithKeyFM _ z E = z-foldrWithKeyFM f z (I k a m) = f k a (foldrWithKeyFM f z (delete k m))--foldrWithKeyFM' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b-foldrWithKeyFM' _ z E = z-foldrWithKeyFM' f z (I k a m) = f k a $! (foldrWithKeyFM' f z (delete k m))--foldlWithKeyFM :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b-foldlWithKeyFM _ x E = x-foldlWithKeyFM f x (I k a m) = foldlWithKeyFM f (f x k a) (delete k m)--foldlWithKeyFM' :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b-foldlWithKeyFM' _ x E = x-foldlWithKeyFM' f x (I k a m) = x `seq` foldlWithKeyFM' f (f x k a) (delete k m)--takeWhileFM :: (k -> Bool) -> FM k a -> FM k a-takeWhileFM _ E = E-takeWhileFM p (I k a m)- | p k = I k a (takeWhileFM p m)- | otherwise = E--dropWhileFM :: (k -> Bool) -> FM k a -> FM k a-dropWhileFM _ E = E-dropWhileFM p o@(I k _ m)- | p k = dropWhileFM p m- | otherwise = o--spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a)-spanFM _ E = (E,E)-spanFM p o@(I k a m)- | p k = let (x,y) = spanFM p m in (I k a x,y)- | otherwise = (E,o)--------------------------------------------------------- interface functions--empty = E-singleton k x = I k x E-insert = I-insertSeq kxs m = S.foldr uinsert m kxs-fromSeq = S.foldr uinsert E--union m E = m-union E m = m-union (I k x m1) m2 = I k x (union m1 m2)--unionSeq = S.foldr union E--deleteAll _ E = E-deleteAll key (I k x m) | key == k = deleteAll key m- | otherwise = I k x (deleteAll key m)--delete = deleteAll--null E = True-null (I _ _ _) = False--size E = 0-size (I k _ m) = 1 + size (delete k m)--member _ E = False-member key (I k _ m) = key == k || member key m--count _ E = 0-count key (I k _ m) | key == k = 1- | otherwise = count key m--lookup key m = runIdentity (lookupM key m)--lookupM _ E = fail "AssocList.lookup: lookup failed"-lookupM key (I k x m) | key == k = return x- | otherwise = lookupM key m--lookupAll _ E = S.empty-lookupAll key (I k x m) | key == k = S.singleton x- | otherwise = lookupAll key m--lookupAndDelete key m = runIdentity (lookupAndDeleteM key m)--lookupAndDeleteM _ E = fail "AssocList.lookupAndDeleteM: lookup failed"-lookupAndDeleteM key (I k x m)- | key == k = return (x,delete k m)- | otherwise = lookupAndDeleteM key m >>=- \ (z, m') -> return (z, I k x m')--lookupAndDeleteAll key m =- case lookupAndDeleteM key m of- Nothing -> (S.empty,m)- Just (z,m') -> (S.singleton z,m')---lookupWithDefault d _ E = d-lookupWithDefault d key (I k x m) | key == k = x- | otherwise = lookupWithDefault d key m--elements E = S.empty-elements (I k x m) = S.lcons x (elements (delete k m))--adjust _ _ E = E-adjust f key (I k x m) | key == k = I key (f x) m- | otherwise = I k x (adjust f key m)--adjustAll = adjust--adjustOrInsert _ z key E = singleton key z-adjustOrInsert f z key (I k x m)- | key == k = I key (f x) m- | otherwise = I k x (adjustOrInsert f z key m)--adjustAllOrInsert = adjustOrInsert--adjustOrDelete = adjustOrDeleteDefault-adjustOrDeleteAll = adjustOrDeleteAllDefault--map _ E = E-map f (I k x m) = I k (f x) (map f m)--fold _ c E = c-fold f c (I k x m) = fold f (f x c) (delete k m)--fold' _ c E = c-fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m)--fold1 _ E = error "AssocList.fold1: empty map"-fold1 f (I k x m) = fold f x (delete k m)--fold1' _ E = error "AssocList.fold1': empty map"-fold1' f (I k x m) = fold' f x (delete k m)--filter _ E = E-filter p (I k x m) | p x = I k x (filter p (delete k m))- | otherwise = filter p (delete k m)--partition _ E = (E, E)-partition p (I k x m)- | p x = (I k x m1,m2)- | otherwise = (m1,I k x m2)- where (m1,m2) = partition p (delete k m)---toSeq E = S.empty-toSeq (I k x m) = S.lcons (k,x) (toSeq (delete k m))--keys E = S.empty-keys (I k _ m) = S.lcons k (keys (delete k m))--mapWithKey _ E = E-mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m)--foldWithKey _ c E = c-foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m)--foldWithKey' _ c E = c-foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m)--filterWithKey _ E = E-filterWithKey p (I k x m)- | p k x = I k x (filterWithKey p (delete k m))- | otherwise = filterWithKey p (delete k m)--partitionWithKey _ E = (E, E)-partitionWithKey p (I k x m)- | p k x = (I k x m1,m2)- | otherwise = (m1,I k x m2)- where (m1,m2) = partitionWithKey p (delete k m)--unionl = union-unionr = flip union---findMin :: (Ord t) => t -> t1 -> FM t t1 -> (t, t1)-findMin k0 x E = (k0,x)-findMin k0 a0 (I k a m)- | k < k0 = findMin k a (delete k m)- | otherwise = findMin k0 a0 (delete k m)--findMax ::( Ord t) => t -> t1 -> FM t t1 -> (t, t1)-findMax k0 x E = (k0,x)-findMax k0 a0 (I k a m)- | k > k0 = findMax k a (delete k m)- | otherwise = findMax k0 a0 (delete k m)--minView E = fail (moduleName++".minView: empty map")-minView n@(I k a m) = let (k',x) = findMin k a m in return (x,delete k' n)--minElem E = error (moduleName++".minElem: empty map")-minElem (I k a m) = let (_,x) = findMin k a m in x--deleteMin E = error (moduleName++".deleteMin: empty map")-deleteMin n@(I k a m) = let (k',_) = findMin k a m in delete k' n--unsafeInsertMin = insert--maxView E = fail (moduleName++".maxView: empty map")-maxView n@(I k a m) = let (k',x) = findMax k a m in return (x,delete k' n)--maxElem E = error (moduleName++".maxElem: empty map")-maxElem (I k a m) = let (_,x) = findMax k a m in x--deleteMax E = error (moduleName++".deleteMax: empty map")-deleteMax n@(I k a m) = let (k',_) = findMax k a m in delete k' n--unsafeInsertMax = insert--foldr f z m = foldrFM f z (mergeSortFM m)-foldr' f z m = foldrFM' f z (mergeSortFM m)--foldr1 f m =- case mergeSortFM m of- E -> error $ moduleName++".foldlr1: empty map"- n -> foldr1FM f n--foldr1' f m =- case mergeSortFM m of- E -> error $ moduleName++".foldlr1': empty map"- n -> foldr1FM' f n--foldl f x m = foldlFM f x (mergeSortFM m)-foldl' f x m = foldlFM' f x (mergeSortFM m)--foldl1 f m =- case mergeSortFM m of- E -> error $ moduleName++".foldl1: empty map"- I k a n -> foldlFM f a (delete k n)--foldl1' f m =- case mergeSortFM m of- E -> error $ moduleName++".foldl1': empty map"- I k a n -> foldlFM' f a (delete k n)--unsafeFromOrdSeq = fromSeq-unsafeAppend = union-filterLT k = takeWhileFM (<k) . mergeSortFM-filterLE k = takeWhileFM (<=k) . mergeSortFM-filterGT k = dropWhileFM (<=k) . mergeSortFM-filterGE k = dropWhileFM (<k) . mergeSortFM-partitionLT_GE k = spanFM (<k) . mergeSortFM-partitionLE_GT k = spanFM (<=k) . mergeSortFM-partitionLT_GT k = (\(x,y) -> (x,delete k y)) . spanFM (<k) . mergeSortFM--minViewWithKey E = fail $ moduleName++".minViewWithKey: empty map"-minViewWithKey n@(I k a m) = let (k',x) = findMin k a m in return ((k',x),delete k' n)--minElemWithKey E = error $ moduleName++".minElemWithKey: empty map"-minElemWithKey (I k a m) = findMin k a m--maxViewWithKey E = fail $ moduleName++".maxViewWithKey: empty map"-maxViewWithKey n@(I k a m) = let (k',x) = findMax k a m in return ((k',x),delete k' n)--maxElemWithKey E = error $ moduleName++".maxElemWithKey: empty map"-maxElemWithKey (I k a m) = findMax k a m--foldrWithKey f z = foldrWithKeyFM f z . mergeSortFM-foldrWithKey' f z = foldrWithKeyFM' f z . mergeSortFM-foldlWithKey f x = foldlWithKeyFM f x . mergeSortFM-foldlWithKey' f x = foldlWithKeyFM' f x . mergeSortFM-toOrdSeq = toSeq . mergeSortFM---strict n@E = n-strict n@(I _ _ m) = strict m `seq` n--strictWith _ n@E = n-strictWith f n@(I _ a m) = f a `seq` strictWith f m `seq` n----- defaults--deleteSeq = deleteSeqUsingFoldr-insertWith = insertWithUsingLookupM-insertSeqWith = insertSeqWithUsingInsertWith-insertWithKey = insertWithKeyUsingInsertWith-insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey-unionWith = unionWithUsingInsertWith-unionSeqWith = unionSeqWithUsingFoldr-fromSeqWith = fromSeqWithUsingInsertSeqWith-fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey-intersectionWith = intersectionWithUsingLookupM-difference = differenceUsingDelete-properSubset = properSubsetUsingSubset-subset = subsetUsingMember-properSubmapBy = properSubmapByUsingSubmapBy-submapBy = submapByUsingLookupM-sameMapBy = sameMapByUsingSubmapBy-properSubmap = A.properSubmap-submap = A.submap-sameMap = A.sameMap-unionWithKey = unionWithKeyUsingInsertWithKey-unionSeqWithKey = unionSeqWithKeyUsingFoldr-intersectionWithKey = intersectionWithKeyUsingLookupM---- instance declarations--instance Eq k => A.AssocX (FM k) k where- {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; union = union; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;- lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;- lookupAndDeleteAll = lookupAndDeleteAll;- lookupWithDefault = lookupWithDefault; adjust = adjust;- adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;- adjustAllOrInsert = adjustAllOrInsert;- adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; elements = elements;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord k => A.OrdAssocX (FM k) k where- {minView = minView; minElem = minElem; deleteMin = deleteMin;- unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;- deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Eq k => A.FiniteMapX (FM k) k where- {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;- insertWith = insertWith; insertWithKey = insertWithKey;- insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;- unionl = unionl; unionr = unionr; unionWith = unionWith;- unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;- difference = difference; properSubset = properSubset; subset = subset;- properSubmapBy = properSubmapBy; submapBy = submapBy;- sameMapBy = sameMapBy}--instance Ord k => A.OrdFiniteMapX (FM k) k--instance Eq k => A.Assoc (FM k) k where- {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;- foldWithKey = foldWithKey; foldWithKey' = foldWithKey';- filterWithKey = filterWithKey;- partitionWithKey = partitionWithKey}--instance Ord k => A.OrdAssoc (FM k) k where- {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;- maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;- foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';- foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';- toOrdSeq = toOrdSeq}--instance Eq k => A.FiniteMap (FM k) k where- {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;- intersectionWithKey = intersectionWithKey}--instance Ord k => A.OrdFiniteMap (FM k) k--instance Eq k => Functor (FM k) where- fmap = map--instance (Eq k,Eq a) => Eq (FM k a) where- (==) = sameMap--instance (Ord k, Ord a) => Ord (FM k a) where- compare = compareUsingToOrdList--instance (Eq k,Show k,Show a) => Show (FM k a) where- showsPrec = showsPrecUsingToList--instance (Eq k,Read k,Read a) => Read (FM k a) where- readsPrec = readsPrecUsingFromList--instance (Eq k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where- arbitrary = do xs <- arbitrary- return (Prelude.foldr (uncurry insert) empty xs)--instance (Eq k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where- coarbitrary E = variant 0- coarbitrary (I k a m) = variant 1 . coarbitrary k- . coarbitrary a . coarbitrary m---instance Eq k => Monoid (FM k a) where- mempty = empty- mappend = union- mconcat = unionSeq+-- | +-- Module : Data.Edison.Assoc.AssocList +-- Copyright : Copyright (c) 1998, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module implements finite maps as simple association lists. +-- +-- Duplicates are removed conceptually, but not physically. The first +-- occurrence of a given key is the one that is considered to be in the map. +-- +-- The list type is mildly customized to prevent boxing the pairs. + +module Data.Edison.Assoc.AssocList ( + -- * Type of simple association lists + FM, -- instance of Assoc(X), FiniteMap(X) + -- also instance of Functor + + -- * AssocX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, + lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, + lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, + adjustOrDelete,adjustOrDeleteAll,strict,strictWith, + map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, + + -- * OrdAssocX operations + minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, + unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1', + foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend, + filterLT, filterLE, filterGT, filterGE, + partitionLT_GE, partitionLE_GT, partitionLT_GT, + + -- * Assoc operations + toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, + + -- * OrdAssoc operations + minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, + foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, + + -- * FiniteMapX operations + fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, + insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, + difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, + properSubmap,submap,sameMap, + + -- * FiniteMap operations + unionWithKey,unionSeqWithKey,intersectionWithKey, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter) +import qualified Prelude +import Data.Monoid +import Data.Semigroup as SG +import qualified Control.Monad.Fail as Fail +import qualified Data.Edison.Assoc as A +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.BinaryRandList as RL +import Data.Edison.Assoc.Defaults +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant) + +-- signatures for exported functions +moduleName :: String +empty :: Eq k => FM k a +singleton :: Eq k => k -> a -> FM k a +fromSeq :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a +insert :: Eq k => k -> a -> FM k a -> FM k a +insertSeq :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a +union :: Eq k => FM k a -> FM k a -> FM k a +unionSeq :: (Eq k,S.Sequence seq) => seq (FM k a) -> FM k a +delete :: Eq k => k -> FM k a -> FM k a +deleteAll :: Eq k => k -> FM k a -> FM k a +deleteSeq :: (Eq k,S.Sequence seq) => seq k -> FM k a -> FM k a +null :: Eq k => FM k a -> Bool +size :: Eq k => FM k a -> Int +member :: Eq k => k -> FM k a -> Bool +count :: Eq k => k -> FM k a -> Int +lookup :: Eq k => k -> FM k a -> a +lookupM :: (Eq k, Fail.MonadFail rm) => k -> FM k a -> rm a +lookupAll :: (Eq k,S.Sequence seq) => k -> FM k a -> seq a +lookupAndDelete :: Eq k => k -> FM k a -> (a,FM k a) +lookupAndDeleteM :: (Eq k, Fail.MonadFail rm) => k -> FM k a -> rm (a,FM k a) +lookupAndDeleteAll :: (Eq k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a) +lookupWithDefault :: Eq k => a -> k -> FM k a -> a +adjust :: Eq k => (a -> a) -> k -> FM k a -> FM k a +adjustAll :: Eq k => (a -> a) -> k -> FM k a -> FM k a +adjustOrInsert :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a +adjustAllOrInsert :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a +adjustOrDelete :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a +adjustOrDeleteAll :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a +strict :: FM k a -> FM k a +strictWith :: (a -> b) -> FM k a -> FM k a +map :: Eq k => (a -> b) -> FM k a -> FM k b +fold :: Eq k => (a -> b -> b) -> b -> FM k a -> b +fold1 :: Eq k => (a -> a -> a) -> FM k a -> a +fold' :: Eq k => (a -> b -> b) -> b -> FM k a -> b +fold1' :: Eq k => (a -> a -> a) -> FM k a -> a +filter :: Eq k => (a -> Bool) -> FM k a -> FM k a +partition :: Eq k => (a -> Bool) -> FM k a -> (FM k a, FM k a) +elements :: (Eq k,S.Sequence seq) => FM k a -> seq a + +fromSeqWith :: (Eq k,S.Sequence seq) => + (a -> a -> a) -> seq (k,a) -> FM k a +fromSeqWithKey :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a +insertWith :: Eq k => (a -> a -> a) -> k -> a -> FM k a -> FM k a +insertWithKey :: Eq k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a +insertSeqWith :: (Eq k,S.Sequence seq) => + (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a +insertSeqWithKey :: (Eq k,S.Sequence seq) => + (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a +unionl :: Eq k => FM k a -> FM k a -> FM k a +unionr :: Eq k => FM k a -> FM k a -> FM k a +unionWith :: Eq k => (a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWith :: (Eq k,S.Sequence seq) => + (a -> a -> a) -> seq (FM k a) -> FM k a +intersectionWith :: Eq k => (a -> b -> c) -> FM k a -> FM k b -> FM k c +difference :: Eq k => FM k a -> FM k b -> FM k a +properSubset :: Eq k => FM k a -> FM k b -> Bool +subset :: Eq k => FM k a -> FM k b -> Bool +properSubmapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +submapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +sameMapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +properSubmap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool +submap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool +sameMap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool + +toSeq :: (Eq k,S.Sequence seq) => FM k a -> seq (k,a) +keys :: (Eq k,S.Sequence seq) => FM k a -> seq k +mapWithKey :: Eq k => (k -> a -> b) -> FM k a -> FM k b +foldWithKey :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b +foldWithKey' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b +filterWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> FM k a +partitionWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> (FM k a, FM k a) + +unionWithKey :: Eq k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWithKey :: (Eq k,S.Sequence seq) => + (k -> a -> a -> a) -> seq (FM k a) -> FM k a +intersectionWithKey :: Eq k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c + +minView :: (Ord k, Fail.MonadFail m) => FM k a -> m (a,FM k a) +minElem :: Ord k => FM k a -> a +deleteMin :: Ord k => FM k a -> FM k a +unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a +maxView :: (Ord k, Fail.MonadFail m) => FM k a -> m (a,FM k a) +maxElem :: Ord k => FM k a -> a +deleteMax :: Ord k => FM k a -> FM k a +unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a +foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b +foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a +foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b +foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a +unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a +unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a +filterLT :: Ord k => k -> FM k a -> FM k a +filterLE :: Ord k => k -> FM k a -> FM k a +filterGT :: Ord k => k -> FM k a -> FM k a +filterGE :: Ord k => k -> FM k a -> FM k a +partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a) +partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) +partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) + +minViewWithKey :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a) +minElemWithKey :: Ord k => FM k a -> (k,a) +maxViewWithKey :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a) +maxElemWithKey :: Ord k => FM k a -> (k,a) +foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b +foldrWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey' :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b +toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) + + +moduleName = "Data.Edison.Assoc.AssocList" + + +data FM k a = E | I k a (FM k a) + +-- no invariants +structuralInvariant :: Eq k => FM k a -> Bool +structuralInvariant = const True + +--------------------------------------- +-- some unexported utility functions + +-- uncurried insert. +uinsert :: (t, t1) -> FM t t1 -> FM t t1 +uinsert (k,x) = I k x + + +-- left biased merge. +mergeFM :: (Ord t) => FM t t1 -> FM t t1 -> FM t t1 +mergeFM E m = m +mergeFM m E = m +mergeFM o1@(I k1 a1 m1) o2@(I k2 a2 m2) = + case compare k1 k2 of + LT -> I k1 a1 (mergeFM m1 o2) + GT -> I k2 a2 (mergeFM o1 m2) + EQ -> I k1 a1 (mergeFM m1 m2) + +toRandList :: FM t t1 -> RL.Seq (FM t t1) +toRandList E = RL.empty +toRandList (I k a m) = RL.lcons (I k a E) (toRandList m) + +mergeSortFM :: (Ord t) => FM t t1 -> FM t t1 +mergeSortFM m = RL.reducer mergeFM E (toRandList m) + +foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b +foldrFM _ z E = z +foldrFM f z (I k a m) = f a (foldrFM f z (delete k m)) + +foldr1FM :: Eq k => (a -> a -> a) -> FM k a -> a +foldr1FM _ (I _ a E) = a +foldr1FM f (I k a m) = f a (foldr1FM f (delete k m)) +foldr1FM _ _ = error "invalid call to foldr1FM on empty map" + +foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b +foldrFM' _ z E = z +foldrFM' f z (I k a m) = f a $! (foldrFM' f z (delete k m)) + +foldr1FM' :: Eq k => (a -> a -> a) -> FM k a -> a +foldr1FM' _ (I _ a E) = a +foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m)) +foldr1FM' _ _ = error "invalid call to foldr1FM' on empty map" + +foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b +foldlFM _ x E = x +foldlFM f x (I k a m) = foldlFM f (f x a) (delete k m) + +foldlFM' :: Eq k => (b -> a -> b) -> b -> FM k a -> b +foldlFM' _ x E = x +foldlFM' f x (I k a m) = x `seq` foldlFM' f (f x a) (delete k m) + +foldrWithKeyFM :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b +foldrWithKeyFM _ z E = z +foldrWithKeyFM f z (I k a m) = f k a (foldrWithKeyFM f z (delete k m)) + +foldrWithKeyFM' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b +foldrWithKeyFM' _ z E = z +foldrWithKeyFM' f z (I k a m) = f k a $! (foldrWithKeyFM' f z (delete k m)) + +foldlWithKeyFM :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b +foldlWithKeyFM _ x E = x +foldlWithKeyFM f x (I k a m) = foldlWithKeyFM f (f x k a) (delete k m) + +foldlWithKeyFM' :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b +foldlWithKeyFM' _ x E = x +foldlWithKeyFM' f x (I k a m) = x `seq` foldlWithKeyFM' f (f x k a) (delete k m) + +takeWhileFM :: (k -> Bool) -> FM k a -> FM k a +takeWhileFM _ E = E +takeWhileFM p (I k a m) + | p k = I k a (takeWhileFM p m) + | otherwise = E + +dropWhileFM :: (k -> Bool) -> FM k a -> FM k a +dropWhileFM _ E = E +dropWhileFM p o@(I k _ m) + | p k = dropWhileFM p m + | otherwise = o + +spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a) +spanFM _ E = (E,E) +spanFM p o@(I k a m) + | p k = let (x,y) = spanFM p m in (I k a x,y) + | otherwise = (E,o) + + +--------------------------------------------------- +-- interface functions + +empty = E +singleton k x = I k x E +insert = I +insertSeq kxs m = S.foldr uinsert m kxs +fromSeq = S.foldr uinsert E + +union m E = m +union E m = m +union (I k x m1) m2 = I k x (union m1 m2) + +unionSeq = S.foldr union E + +deleteAll _ E = E +deleteAll key (I k x m) | key == k = deleteAll key m + | otherwise = I k x (deleteAll key m) + +delete = deleteAll + +null E = True +null (I _ _ _) = False + +size E = 0 +size (I k _ m) = 1 + size (delete k m) + +member _ E = False +member key (I k _ m) = key == k || member key m + +count _ E = 0 +count key (I k _ m) | key == k = 1 + | otherwise = count key m + +lookup key m = runFail_ (lookupM key m) + +lookupM _ E = fail "AssocList.lookup: lookup failed" +lookupM key (I k x m) | key == k = return x + | otherwise = lookupM key m + +lookupAll _ E = S.empty +lookupAll key (I k x m) | key == k = S.singleton x + | otherwise = lookupAll key m + +lookupAndDelete key m = runFail_ (lookupAndDeleteM key m) + +lookupAndDeleteM _ E = fail "AssocList.lookupAndDeleteM: lookup failed" +lookupAndDeleteM key (I k x m) + | key == k = return (x,delete k m) + | otherwise = lookupAndDeleteM key m >>= + \ (z, m') -> return (z, I k x m') + +lookupAndDeleteAll key m = + case lookupAndDeleteM key m of + Nothing -> (S.empty,m) + Just (z,m') -> (S.singleton z,m') + + +lookupWithDefault d _ E = d +lookupWithDefault d key (I k x m) | key == k = x + | otherwise = lookupWithDefault d key m + +elements E = S.empty +elements (I k x m) = S.lcons x (elements (delete k m)) + +adjust _ _ E = E +adjust f key (I k x m) | key == k = I key (f x) m + | otherwise = I k x (adjust f key m) + +adjustAll = adjust + +adjustOrInsert _ z key E = singleton key z +adjustOrInsert f z key (I k x m) + | key == k = I key (f x) m + | otherwise = I k x (adjustOrInsert f z key m) + +adjustAllOrInsert = adjustOrInsert + +adjustOrDelete = adjustOrDeleteDefault +adjustOrDeleteAll = adjustOrDeleteAllDefault + +map _ E = E +map f (I k x m) = I k (f x) (map f m) + +fold _ c E = c +fold f c (I k x m) = fold f (f x c) (delete k m) + +fold' _ c E = c +fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m) + +fold1 _ E = error "AssocList.fold1: empty map" +fold1 f (I k x m) = fold f x (delete k m) + +fold1' _ E = error "AssocList.fold1': empty map" +fold1' f (I k x m) = fold' f x (delete k m) + +filter _ E = E +filter p (I k x m) | p x = I k x (filter p (delete k m)) + | otherwise = filter p (delete k m) + +partition _ E = (E, E) +partition p (I k x m) + | p x = (I k x m1,m2) + | otherwise = (m1,I k x m2) + where (m1,m2) = partition p (delete k m) + + +toSeq E = S.empty +toSeq (I k x m) = S.lcons (k,x) (toSeq (delete k m)) + +keys E = S.empty +keys (I k _ m) = S.lcons k (keys (delete k m)) + +mapWithKey _ E = E +mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m) + +foldWithKey _ c E = c +foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m) + +foldWithKey' _ c E = c +foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m) + +filterWithKey _ E = E +filterWithKey p (I k x m) + | p k x = I k x (filterWithKey p (delete k m)) + | otherwise = filterWithKey p (delete k m) + +partitionWithKey _ E = (E, E) +partitionWithKey p (I k x m) + | p k x = (I k x m1,m2) + | otherwise = (m1,I k x m2) + where (m1,m2) = partitionWithKey p (delete k m) + +unionl = union +unionr = flip union + + +findMin :: (Ord t) => t -> t1 -> FM t t1 -> (t, t1) +findMin k0 x E = (k0,x) +findMin k0 a0 (I k a m) + | k < k0 = findMin k a (delete k m) + | otherwise = findMin k0 a0 (delete k m) + +findMax ::( Ord t) => t -> t1 -> FM t t1 -> (t, t1) +findMax k0 x E = (k0,x) +findMax k0 a0 (I k a m) + | k > k0 = findMax k a (delete k m) + | otherwise = findMax k0 a0 (delete k m) + +minView E = fail (moduleName++".minView: empty map") +minView n@(I k a m) = let (k',x) = findMin k a m in return (x,delete k' n) + +minElem E = error (moduleName++".minElem: empty map") +minElem (I k a m) = let (_,x) = findMin k a m in x + +deleteMin E = error (moduleName++".deleteMin: empty map") +deleteMin n@(I k a m) = let (k',_) = findMin k a m in delete k' n + +unsafeInsertMin = insert + +maxView E = fail (moduleName++".maxView: empty map") +maxView n@(I k a m) = let (k',x) = findMax k a m in return (x,delete k' n) + +maxElem E = error (moduleName++".maxElem: empty map") +maxElem (I k a m) = let (_,x) = findMax k a m in x + +deleteMax E = error (moduleName++".deleteMax: empty map") +deleteMax n@(I k a m) = let (k',_) = findMax k a m in delete k' n + +unsafeInsertMax = insert + +foldr f z m = foldrFM f z (mergeSortFM m) +foldr' f z m = foldrFM' f z (mergeSortFM m) + +foldr1 f m = + case mergeSortFM m of + E -> error $ moduleName++".foldlr1: empty map" + n -> foldr1FM f n + +foldr1' f m = + case mergeSortFM m of + E -> error $ moduleName++".foldlr1': empty map" + n -> foldr1FM' f n + +foldl f x m = foldlFM f x (mergeSortFM m) +foldl' f x m = foldlFM' f x (mergeSortFM m) + +foldl1 f m = + case mergeSortFM m of + E -> error $ moduleName++".foldl1: empty map" + I k a n -> foldlFM f a (delete k n) + +foldl1' f m = + case mergeSortFM m of + E -> error $ moduleName++".foldl1': empty map" + I k a n -> foldlFM' f a (delete k n) + +unsafeFromOrdSeq = fromSeq +unsafeAppend = union +filterLT k = takeWhileFM (<k) . mergeSortFM +filterLE k = takeWhileFM (<=k) . mergeSortFM +filterGT k = dropWhileFM (<=k) . mergeSortFM +filterGE k = dropWhileFM (<k) . mergeSortFM +partitionLT_GE k = spanFM (<k) . mergeSortFM +partitionLE_GT k = spanFM (<=k) . mergeSortFM +partitionLT_GT k = (\(x,y) -> (x,delete k y)) . spanFM (<k) . mergeSortFM + +minViewWithKey E = fail $ moduleName++".minViewWithKey: empty map" +minViewWithKey n@(I k a m) = let (k',x) = findMin k a m in return ((k',x),delete k' n) + +minElemWithKey E = error $ moduleName++".minElemWithKey: empty map" +minElemWithKey (I k a m) = findMin k a m + +maxViewWithKey E = fail $ moduleName++".maxViewWithKey: empty map" +maxViewWithKey n@(I k a m) = let (k',x) = findMax k a m in return ((k',x),delete k' n) + +maxElemWithKey E = error $ moduleName++".maxElemWithKey: empty map" +maxElemWithKey (I k a m) = findMax k a m + +foldrWithKey f z = foldrWithKeyFM f z . mergeSortFM +foldrWithKey' f z = foldrWithKeyFM' f z . mergeSortFM +foldlWithKey f x = foldlWithKeyFM f x . mergeSortFM +foldlWithKey' f x = foldlWithKeyFM' f x . mergeSortFM +toOrdSeq = toSeq . mergeSortFM + + +strict n@E = n +strict n@(I _ _ m) = strict m `seq` n + +strictWith _ n@E = n +strictWith f n@(I _ a m) = f a `seq` strictWith f m `seq` n + + +-- defaults + +deleteSeq = deleteSeqUsingFoldr +insertWith = insertWithUsingLookupM +insertSeqWith = insertSeqWithUsingInsertWith +insertWithKey = insertWithKeyUsingInsertWith +insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey +unionWith = unionWithUsingInsertWith +unionSeqWith = unionSeqWithUsingFoldr +fromSeqWith = fromSeqWithUsingInsertSeqWith +fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey +intersectionWith = intersectionWithUsingLookupM +difference = differenceUsingDelete +properSubset = properSubsetUsingSubset +subset = subsetUsingMember +properSubmapBy = properSubmapByUsingSubmapBy +submapBy = submapByUsingLookupM +sameMapBy = sameMapByUsingSubmapBy +properSubmap = A.properSubmap +submap = A.submap +sameMap = A.sameMap +unionWithKey = unionWithKeyUsingInsertWithKey +unionSeqWithKey = unionSeqWithKeyUsingFoldr +intersectionWithKey = intersectionWithKeyUsingLookupM + +-- instance declarations + +instance Eq k => A.AssocX (FM k) k where + {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; union = union; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; + lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; + lookupAndDeleteAll = lookupAndDeleteAll; + lookupWithDefault = lookupWithDefault; adjust = adjust; + adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; + adjustAllOrInsert = adjustAllOrInsert; + adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; elements = elements; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord k => A.OrdAssocX (FM k) k where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Eq k => A.FiniteMapX (FM k) k where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance Ord k => A.OrdFiniteMapX (FM k) k + +instance Eq k => A.Assoc (FM k) k where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance Ord k => A.OrdAssoc (FM k) k where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance Eq k => A.FiniteMap (FM k) k where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance Ord k => A.OrdFiniteMap (FM k) k + +instance Eq k => Functor (FM k) where + fmap = map + +instance (Eq k,Eq a) => Eq (FM k a) where + (==) = sameMap + +instance (Ord k, Ord a) => Ord (FM k a) where + compare = compareUsingToOrdList + +instance (Eq k,Show k,Show a) => Show (FM k a) where + showsPrec = showsPrecUsingToList + +instance (Eq k,Read k,Read a) => Read (FM k a) where + readsPrec = readsPrecUsingFromList + +instance (Eq k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where + arbitrary = do (xs::[(k,a)]) <- arbitrary + return (Prelude.foldr (uncurry insert) empty xs) + +instance (Eq k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (I k a m) = variant (1 :: Int) . coarbitrary k + . coarbitrary a . coarbitrary m + + +instance Eq k => Semigroup (FM k a) where + (<>) = union +instance Eq k => Monoid (FM k a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq
src/Data/Edison/Assoc/Defaults.hs view
@@ -1,312 +1,315 @@--- |--- Module : Data.Edison.Assoc.Defaults--- Copyright : Copyright (c) 1998, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : internal (unstable)--- Portability : GHC, Hugs (MPTC and FD)------ This module provides default implementations of many of the associative--- collection operations. These function are used to fill in collection--- implementations and are not intended to be used directly by end users.--module Data.Edison.Assoc.Defaults where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)--import Data.Edison.Assoc-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)--singletonUsingInsert :: (Assoc m k) => k -> a -> m a-singletonUsingInsert k v = insert k v empty--fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a-fromSeqUsingInsertSeq kvs = insertSeq kvs empty--insertSeqUsingFoldr ::- (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a-insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs--unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a-unionSeqUsingReduce ms = S.reducel union empty ms--deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a-deleteSeqUsingFoldr ks m = S.foldr delete m ks--memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool-memberUsingLookupM k m- = case lookupM k m of- Just _ -> True- Nothing -> False--sizeUsingElements :: (AssocX m k) => m a -> Int-sizeUsingElements m = length (elements m)--countUsingMember :: AssocX m k => k -> m a -> Int-countUsingMember k m = if member k m then 1 else 0--lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a-lookupAllUsingLookupM k m = case lookupM k m of- Just x -> S.singleton x- Nothing -> S.empty--lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a-lookupWithDefaultUsingLookupM d k m = case lookupM k m of- Just x -> x- Nothing -> d--partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a)-partitionUsingFilter f m = (filter f m, filter (not . f) m)--fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a-fold1UsingElements op m = L.foldr1 op (elements m)--elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a-elementsUsingFold = fold S.lcons S.empty--nullUsingElements :: (AssocX m k) => m a -> Bool-nullUsingElements m- = case elements m of- [] -> True- _ -> False--insertWithUsingLookupM ::- FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a-insertWithUsingLookupM f k x m =- case lookupM k m of- Nothing -> insert k x m- Just y -> insert k (f x y) m--fromSeqWithUsingInsertSeqWith ::- (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a-fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty--fromSeqWithKeyUsingInsertSeqWithKey ::- (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a-fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty--insertWithKeyUsingInsertWith ::- FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a-insertWithKeyUsingInsertWith f k = insertWith (f k) k--insertSeqWithUsingInsertWith ::- (FiniteMapX m k,S.Sequence seq) =>- (a -> a -> a) -> seq (k,a) -> m a -> m a-insertSeqWithUsingInsertWith f kvs m =- S.foldr (uncurry (insertWith f)) m kvs--insertSeqWithKeyUsingInsertWithKey ::- (FiniteMapX m k,S.Sequence seq) =>- (k -> a -> a -> a) -> seq (k,a) -> m a -> m a-insertSeqWithKeyUsingInsertWithKey f kvs m =- S.foldr (uncurry (insertWithKey f)) m kvs--unionSeqWithUsingReduce ::- (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a-unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms--unionSeqWithUsingFoldr ::- (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a-unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms--toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a)-toSeqUsingFoldWithKey = foldWithKey conspair S.empty- where conspair k v kvs = S.lcons (k,v) kvs--keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k-keysUsingFoldWithKey = foldWithKey conskey S.empty- where conskey k _ ks = S.lcons k ks--unionWithUsingInsertWith ::- FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a-unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1--unionWithKeyUsingInsertWithKey ::- FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a-unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1--unionSeqWithKeyUsingReduce ::- (FiniteMap m k,S.Sequence seq) =>- (k -> a -> a -> a) -> seq (m a) -> m a-unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms--unionSeqWithKeyUsingFoldr ::- (FiniteMap m k,S.Sequence seq) =>- (k -> a -> a -> a) -> seq (m a) -> m a-unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms--intersectionWithUsingLookupM ::- FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c-intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1- where ins k x m = case lookupM k m2 of- Nothing -> m- Just y -> insert k (f x y) m--intersectionWithKeyUsingLookupM ::- FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c-intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1- where ins k x m = case lookupM k m2 of- Nothing -> m- Just y -> insert k (f k x y) m--differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a-differenceUsingDelete m1 m2 = foldWithKey del m1 m2- where del k _ m = delete k m--properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool-properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2--subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool-subsetUsingMember m1 m2 = foldWithKey mem True m1- where mem k _ b = member k m2 && b--submapByUsingLookupM :: FiniteMap m k- => (a -> a -> Bool) -> m a -> m a -> Bool-submapByUsingLookupM f m1 m2 = foldWithKey aux True m1- where aux k x b =- case lookupM k m2 of- Nothing -> False- Just y -> f x y && b--properSubmapByUsingSubmapBy :: FiniteMapX m k- => (a -> a -> Bool) -> m a -> m a -> Bool-properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2--sameMapByUsingOrdLists :: OrdFiniteMap m k- => (a -> a -> Bool) -> m a -> m a -> Bool-sameMapByUsingOrdLists f m1 m2 =- let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2- in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2))---sameMapByUsingSubmapBy :: FiniteMapX m k- => (a -> a -> Bool) -> m a -> m a -> Bool-sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2---lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a)-lookupAndDeleteDefault k m =- case lookupM k m of- Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed")- Just x -> (x, delete k m)--lookupAndDeleteMDefault :: (Monad rm, AssocX m k) => k -> m a -> rm (a, m a)-lookupAndDeleteMDefault k m =- case lookupM k m of- Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed")- Just x -> return (x, delete k m)--lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a)-lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m)--adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a-adjustOrInsertUsingMember f z k m =- if member k m- then adjust f k m- else insert k z m--adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a-adjustOrDeleteDefault f k m =- case lookupAndDeleteM k m of- Nothing -> m- Just (element,m') ->- case f element of- Nothing -> m'- Just x -> insert k x m'--adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a-adjustOrDeleteAllDefault f k m =- let (elems,m') = lookupAndDeleteAll k m- adjSeq = S.map f elems- ins Nothing n = n- ins (Just x) n = insert k x n- in L.foldr ins m' adjSeq--minElemUsingMinView :: OrdAssocX m k => m a -> a-minElemUsingMinView fm =- case minView fm of- Nothing -> error $ (instanceName fm)++".minElem: empty map"- Just (x,_) -> x--deleteMinUsingMinView :: OrdAssocX m k => m a -> m a-deleteMinUsingMinView fm =- case minView fm of- Nothing -> error $ (instanceName fm)++".deleteMin: empty map"- Just (_,m) -> m--minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a)-minElemWithKeyUsingMinViewWithKey fm =- case minViewWithKey fm of- Nothing -> error $ (instanceName fm)++".minElemWithKey: empty map"- Just (x,_) -> x--maxElemUsingMaxView :: OrdAssocX m k => m a -> a-maxElemUsingMaxView fm =- case maxView fm of- Nothing -> error $ (instanceName fm)++".maxElem: empty map"- Just (x,_) -> x--deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a-deleteMaxUsingMaxView fm =- case maxView fm of- Nothing -> error $ (instanceName fm)++".deleteMax: empty map"- Just (_,m) -> m--maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a)-maxElemWithKeyUsingMaxViewWithKey fm =- case maxViewWithKey fm of- Nothing -> error $ (instanceName fm)++".maxElemWithKey: empty map"- Just (x,_) -> x--toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a)-toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty--showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS-showsPrecUsingToList i xs rest- | i == 0 = concat [ instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]- | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]--readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a)-readsPrecUsingFromList _ xs =- let result = maybeParens p xs- p ys = tokenMatch ((instanceName x)++".fromSeq") ys- >>= readsPrec 10- >>= \(l,rest) -> return (fromList l,rest)-- -- play games with the typechecker so we don't have to use- -- extensions for scoped type variables- ~[(x,_)] = result-- in result--showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS-showsPrecUsingToOrdList i xs rest- | i == 0 = concat [ instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest]- | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)]--readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a)-readsPrecUsingUnsafeFromOrdSeq i xs =- let result = maybeParens p xs- p ys = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") ys- >>= readsPrec i- >>= \(l,rest) -> return (unsafeFromOrdList l,rest)-- -- play games with the typechecker so we don't have to use- -- extensions for scoped type variables- ~[(x,_)] = result-- in result--compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering-compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys)- where- cmp [] [] = EQ- cmp [] _ = LT- cmp _ [] = GT- cmp (v:vs) (z:zs) =- case compare v z of- EQ -> cmp vs zs- c -> c+-- | +-- Module : Data.Edison.Assoc.Defaults +-- Copyright : Copyright (c) 1998, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : internal (unstable) +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module provides default implementations of many of the associative +-- collection operations. These function are used to fill in collection +-- implementations and are not intended to be used directly by end users. + +module Data.Edison.Assoc.Defaults where + +import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter) + +import qualified Control.Monad.Fail as Fail + +import Data.Edison.Assoc +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) + +singletonUsingInsert :: (Assoc m k) => k -> a -> m a +singletonUsingInsert k v = insert k v empty + +fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a +fromSeqUsingInsertSeq kvs = insertSeq kvs empty + +insertSeqUsingFoldr :: + (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a +insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs + +unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a +unionSeqUsingReduce ms = S.reducel union empty ms + +deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a +deleteSeqUsingFoldr ks m = S.foldr delete m ks + +memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool +memberUsingLookupM k m + = case lookupM k m of + Just _ -> True + Nothing -> False + +countUsingMember :: AssocX m k => k -> m a -> Int +countUsingMember k m = if member k m then 1 else 0 + +lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a +lookupAllUsingLookupM k m = case lookupM k m of + Just x -> S.singleton x + Nothing -> S.empty + +lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a +lookupWithDefaultUsingLookupM d k m = case lookupM k m of + Just x -> x + Nothing -> d + +partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a) +partitionUsingFilter f m = (filter f m, filter (not . f) m) + +fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a +fold1UsingElements op m = L.foldr1 op (elements m) + +elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a +elementsUsingFold = fold S.lcons S.empty + +nullUsingElements :: (AssocX m k) => m a -> Bool +nullUsingElements m + = case elements m of + [] -> True + _ -> False + +insertWithUsingLookupM :: + FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a +insertWithUsingLookupM f k x m = + case lookupM k m of + Nothing -> insert k x m + Just y -> insert k (f x y) m + +fromSeqWithUsingInsertSeqWith :: + (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a +fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty + +fromSeqWithKeyUsingInsertSeqWithKey :: + (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a +fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty + +insertWithKeyUsingInsertWith :: + FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a +insertWithKeyUsingInsertWith f k = insertWith (f k) k + +insertSeqWithUsingInsertWith :: + (FiniteMapX m k,S.Sequence seq) => + (a -> a -> a) -> seq (k,a) -> m a -> m a +insertSeqWithUsingInsertWith f kvs m = + S.foldr (uncurry (insertWith f)) m kvs + +insertSeqWithKeyUsingInsertWithKey :: + (FiniteMapX m k,S.Sequence seq) => + (k -> a -> a -> a) -> seq (k,a) -> m a -> m a +insertSeqWithKeyUsingInsertWithKey f kvs m = + S.foldr (uncurry (insertWithKey f)) m kvs + +unionSeqWithUsingReduce :: + (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a +unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms + +unionSeqWithUsingFoldr :: + (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a +unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms + +toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a) +toSeqUsingFoldWithKey = foldWithKey conspair S.empty + where conspair k v kvs = S.lcons (k,v) kvs + +keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k +keysUsingFoldWithKey = foldWithKey conskey S.empty + where conskey k _ ks = S.lcons k ks + +unionWithUsingInsertWith :: + FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a +unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1 + +unionWithKeyUsingInsertWithKey :: + FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a +unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1 + +unionSeqWithKeyUsingReduce :: + (FiniteMap m k,S.Sequence seq) => + (k -> a -> a -> a) -> seq (m a) -> m a +unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms + +unionSeqWithKeyUsingFoldr :: + (FiniteMap m k,S.Sequence seq) => + (k -> a -> a -> a) -> seq (m a) -> m a +unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms + +intersectionWithUsingLookupM :: + FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c +intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1 + where ins k x m = case lookupM k m2 of + Nothing -> m + Just y -> insert k (f x y) m + +intersectionWithKeyUsingLookupM :: + FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c +intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1 + where ins k x m = case lookupM k m2 of + Nothing -> m + Just y -> insert k (f k x y) m + +differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a +differenceUsingDelete m1 m2 = foldWithKey del m1 m2 + where del k _ m = delete k m + +properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool +properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2 + +subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool +subsetUsingMember m1 m2 = foldWithKey mem True m1 + where mem k _ b = member k m2 && b + +submapByUsingLookupM :: FiniteMap m k + => (a -> a -> Bool) -> m a -> m a -> Bool +submapByUsingLookupM f m1 m2 = foldWithKey aux True m1 + where aux k x b = + case lookupM k m2 of + Nothing -> False + Just y -> f x y && b + +properSubmapByUsingSubmapBy :: FiniteMapX m k + => (a -> a -> Bool) -> m a -> m a -> Bool +properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2 + +sameMapByUsingOrdLists :: OrdFiniteMap m k + => (a -> a -> Bool) -> m a -> m a -> Bool +sameMapByUsingOrdLists f m1 m2 = + let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2 + in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2)) + + +sameMapByUsingSubmapBy :: FiniteMapX m k + => (a -> a -> Bool) -> m a -> m a -> Bool +sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2 + + +lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a) +lookupAndDeleteDefault k m = + case lookupM k m of + Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed") + Just x -> (x, delete k m) + +lookupAndDeleteMDefault :: (Fail.MonadFail rm, AssocX m k) => k -> m a -> rm (a, m a) +lookupAndDeleteMDefault k m = + case lookupM k m of + Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed") + Just x -> return (x, delete k m) + +lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a) +lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m) + +adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a +adjustOrInsertUsingMember f z k m = + if member k m + then adjust f k m + else insert k z m + +adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a +adjustOrDeleteDefault f k m = + case lookupAndDeleteM k m of + Nothing -> m + Just (element,m') -> + case f element of + Nothing -> m' + Just x -> insert k x m' + +adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a +adjustOrDeleteAllDefault f k m = + let (elems,m') = lookupAndDeleteAll k m + adjSeq = S.map f elems + ins Nothing n = n + ins (Just x) n = insert k x n + in L.foldr ins m' adjSeq + +minElemUsingMinView :: OrdAssocX m k => m a -> a +minElemUsingMinView fm = + case minView fm of + Nothing -> error $ (instanceName fm)++".minElem: empty map" + Just (x,_) -> x + +deleteMinUsingMinView :: OrdAssocX m k => m a -> m a +deleteMinUsingMinView fm = + case minView fm of + Nothing -> error $ (instanceName fm)++".deleteMin: empty map" + Just (_,m) -> m + +minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a) +minElemWithKeyUsingMinViewWithKey fm = + case minViewWithKey fm of + Nothing -> error $ (instanceName fm)++".minElemWithKey: empty map" + Just (x,_) -> x + +maxElemUsingMaxView :: OrdAssocX m k => m a -> a +maxElemUsingMaxView fm = + case maxView fm of + Nothing -> error $ (instanceName fm)++".maxElem: empty map" + Just (x,_) -> x + +deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a +deleteMaxUsingMaxView fm = + case maxView fm of + Nothing -> error $ (instanceName fm)++".deleteMax: empty map" + Just (_,m) -> m + +maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a) +maxElemWithKeyUsingMaxViewWithKey fm = + case maxViewWithKey fm of + Nothing -> error $ (instanceName fm)++".maxElemWithKey: empty map" + Just (x,_) -> x + +toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a) +toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty + +showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS +showsPrecUsingToList i xs rest + | i == 0 = concat [ instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest] + | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)] + +readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a) +readsPrecUsingFromList _ xs = + let result = maybeParens p xs + p ys = tokenMatch ((instanceName x)++".fromSeq") ys + >>= readsPrec 10 + >>= \(l,rest) -> return (fromList l,rest) + + -- play games with the typechecker so we don't have to use + -- extensions for scoped type variables + x = case result of + [(x',_)] -> x' + _ -> undefined + + in result + +showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS +showsPrecUsingToOrdList i xs rest + | i == 0 = concat [ instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest] + | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)] + +readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a) +readsPrecUsingUnsafeFromOrdSeq i xs = + let result = maybeParens p xs + p ys = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") ys + >>= readsPrec i + >>= \(l,rest) -> return (unsafeFromOrdList l,rest) + + -- play games with the typechecker so we don't have to use + -- extensions for scoped type variables + x = case result of + [(x',_)] -> x' + _ -> undefined + + in result + +compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering +compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys) + where + cmp [] [] = EQ + cmp [] _ = LT + cmp _ [] = GT + cmp (v:vs) (z:zs) = + case compare v z of + EQ -> cmp vs zs + c -> c
src/Data/Edison/Assoc/PatriciaLoMap.hs view
@@ -1,847 +1,854 @@--- |--- Module : Data.Edison.Assoc.PatriciaLoMap--- Copyright : Copyright (c) 1998, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Finite maps implemented as little-endian Patricia trees.------ /References:/------ * Chris Okasaki and Any Gill. \"Fast Mergeable Integer Maps\".--- Workshop on ML, September 1998, pages 77-86.--module Data.Edison.Assoc.PatriciaLoMap (- -- * Type of little-endian Patricia trees- FM,-- -- * AssocX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,- lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,strict,strictWith,- lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,map,- fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,-- -- * Assoc operations- toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,-- -- * FiniteMapX operations- fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,- insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,- difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,- properSubmap,submap,sameMap,-- -- * FiniteMap operations- unionWithKey,unionSeqWithKey,intersectionWithKey,-- -- * OrdAssocX operations- minView, minElem, deleteMin, unsafeInsertMin,- maxView, maxElem, deleteMax, unsafeInsertMax,- foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',- unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,- partitionLT_GE, partitionLE_GT, partitionLT_GT,-- -- * OrdAssoc operations- minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,- foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',- toOrdSeq,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)-import qualified Prelude-import Control.Monad.Identity (runIdentity)-import Data.Monoid-import qualified Data.Edison.Assoc as A-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Assoc.Defaults-import Data.Int-import Data.Bits-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant)--moduleName :: String-moduleName = "Data.Edison.Assoc.PatriciaLoMap"--data FM a- = E- | L Int a- | B Int Int !(FM a) !(FM a)---- Invariants:--- * No B node has an E child--- * first argument to B is a prefix--- * second argument to B is the "branching bit" and is--- always an exact power of two--- * all bits in the prefix >= the branching bit are zeros--- * valid prefix bits match all subnodes--structuralInvariant :: FM a -> Bool-structuralInvariant E = True-structuralInvariant (L _ _) = True-structuralInvariant x = inv 0 0 x--inv :: Int -> Int -> FM a -> Bool-inv _ _ E = False-inv pre msk (L k _) = k .&. msk == pre-inv pre msk (B p m t0 t1) =- (p .&. msk == pre) &&- (bitcount 0 m == 1) &&- (p .&. (complement (m - 1)) == 0) &&- inv p0 msk' t0 &&- inv p1 msk' t1-- where p0 = p- p1 = p .|. m- msk' = (m `shiftL` 1) - 1--bitcount :: Int -> Int -> Int-bitcount a 0 = a-bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))---- auxiliary functions--makeB :: Int -> Int -> FM t -> FM t -> FM t-makeB _ _ E t = t-makeB _ _ t E = t-makeB p m t0 t1 = B p m t0 t1--lmakeB :: Int -> Int -> FM t -> FM t -> FM t-lmakeB _ _ E t = t-lmakeB p m t0 t1 = B p m t0 t1--rmakeB :: Int -> Int -> FM a -> FM a -> FM a-rmakeB _ _ t E = t-rmakeB p m t0 t1 = B p m t0 t1--lowestBit :: Int32 -> Int32-lowestBit x = x .&. (-x)--branchingBit :: Int -> Int -> Int-branchingBit p0 p1 =- fromIntegral (lowestBit (fromIntegral p0 `xor` fromIntegral p1))--mask :: Int -> Int -> Int-mask p m = fromIntegral (fromIntegral p .&. (fromIntegral m - (1 :: Int32)))--zeroBit :: Int -> Int -> Bool-zeroBit p m = (fromIntegral p) .&. (fromIntegral m) == (0 :: Int32)--matchPrefix :: Int -> Int -> Int -> Bool-matchPrefix k p m = mask k m == p--join :: Int -> FM a -> Int -> FM a -> FM a-join p0 t0 p1 t1 =- let m = branchingBit p0 p1- in if zeroBit p0 m then B (mask p0 m) m t0 t1- else B (mask p0 m) m t1 t0--keepR :: forall t t1. t -> t1 -> t1-keepR _ y = y---- end auxiliary functions--empty :: FM a-empty = E--singleton :: Int -> a -> FM a-singleton k x = L k x--fromSeq :: S.Sequence seq => seq (Int,a) -> FM a-fromSeq = S.foldl (\t (k, x) -> insert k x t) E--insert :: Int -> a -> FM a -> FM a-insert k x E = L k x-insert k x t@(L j _) = if j == k then L k x else join k (L k x) j t-insert k x t@(B p m t0 t1) =- if matchPrefix k p m then- if zeroBit k m then B p m (insert k x t0) t1- else B p m t0 (insert k x t1)- else join k (L k x) p t--union :: FM a -> FM a -> FM a-union s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then B p m (union s0 t) s1- else B p m s0 (union s1 t)- else join p s q t- | m > n = if matchPrefix p q n then- if zeroBit p n then B q n (union s t0) t1- else B q n t0 (union s t1)- else join p s q t- | otherwise = if p == q then B p m (union s0 t0) (union s1 t1)- else join p s q t-union s@(B p m s0 s1) (L k x) =- if matchPrefix k p m then- if zeroBit k m then B p m (insert k x s0) s1- else B p m s0 (insert k x s1)- else join k (L k x) p s-union s@(B _ _ _ _) E = s-union (L k x) t = insert k x t-union E t = t--delete :: Int -> FM a -> FM a-delete _ E = E-delete k t@(L j _) = if k == j then E else t-delete k t@(B p m t0 t1) =- if matchPrefix k p m then- if zeroBit k m then lmakeB p m (delete k t0) t1- else rmakeB p m t0 (delete k t1)- else t--null :: FM a -> Bool-null E = True-null _ = False--size :: FM a -> Int-size E = 0-size (L _ _) = 1-size (B _ _ t0 t1) = size t0 + size t1--member :: Int -> FM a -> Bool-member _ E = False-member k (L j _) = (j == k)-member k (B _ m t0 t1) = if zeroBit k m then member k t0 else member k t1--lookup :: Int -> FM a -> a-lookup k m = runIdentity (lookupM k m)--lookupM :: (Monad rm) => Int -> FM a -> rm a-lookupM _ E = fail "PatriciaLoMap.lookup: lookup failed"-lookupM k (L j x)- | j == k = return x- | otherwise = fail "PatriciaLoMap.lookup: lookup failed"-lookupM k (B _ m t0 t1) = if zeroBit k m then lookupM k t0 else lookupM k t1--doLookupAndDelete :: z -> (a -> FM a -> z) -> Int -> FM a -> z-doLookupAndDelete onFail _ _ E = onFail-doLookupAndDelete onFail cont k (L j x)- | j == k = cont x E- | otherwise = onFail-doLookupAndDelete onFail cont k (B p m t0 t1)- | zeroBit k m = doLookupAndDelete onFail (\x t0' -> cont x (makeB p m t0' t1)) k t0- | otherwise = doLookupAndDelete onFail (\x t1' -> cont x (makeB p m t0 t1')) k t1--lookupAndDelete :: Int -> FM a -> (a, FM a)-lookupAndDelete = doLookupAndDelete- (error "PatriciaLoMap.lookupAndDelete: lookup failed")- (,)--lookupAndDeleteM :: Monad m => Int -> FM a -> m (a, FM a)-lookupAndDeleteM = doLookupAndDelete- (fail "PatriciaLoMap.lookupAndDelete: lookup failed")- (\x m -> return (x,m))--lookupAndDeleteAll :: S.Sequence seq => Int -> FM a -> (seq a,FM a)-lookupAndDeleteAll k m = doLookupAndDelete- (S.empty, m)- (\x m' -> (S.singleton x,m'))- k m---adjust :: (a -> a) -> Int -> FM a -> FM a-adjust _ _ E = E-adjust f k t@(L j x) = if k == j then L k (f x) else t-adjust f k t@(B p m t0 t1) =- if matchPrefix k p m then- if zeroBit k m then B p m (adjust f k t0) t1- else B p m t0 (adjust f k t1)- else t---- FIXME can we do better than this?-adjustOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a-adjustOrInsert = adjustOrInsertUsingMember--adjustAllOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a-adjustAllOrInsert = adjustOrInsertUsingMember--adjustOrDelete :: (a -> Maybe a) -> Int -> FM a -> FM a-adjustOrDelete = adjustOrDeleteDefault--adjustOrDeleteAll :: (a -> Maybe a) -> Int -> FM a -> FM a-adjustOrDeleteAll = adjustOrDeleteDefault--map :: (a -> b) -> FM a -> FM b-map _ E = E-map f (L k x) = L k (f x)-map f (B p m t0 t1) = B p m (map f t0) (map f t1)--fold :: (a -> b -> b) -> b -> FM a -> b-fold _ c E = c-fold f c (L _ x) = f x c-fold f c (B _ _ t0 t1) = fold f (fold f c t1) t0--fold' :: (a -> b -> b) -> b -> FM a -> b-fold' _ c E = c-fold' f c (L _ x) = c `seq` f x c-fold' f c (B _ _ t0 t1) = c `seq` (fold f $! (fold f c t1)) t0--fold1 :: (a -> a -> a) -> FM a -> a-fold1 _ E = error "PatriciaLoMap.fold1: empty map"-fold1 _ (L _ x) = x-fold1 f (B _ _ t0 t1) = f (fold1 f t0) (fold1 f t1)--fold1' :: (a -> a -> a) -> FM a -> a-fold1' _ E = error "PatriciaLoMap.fold1: empty map"-fold1' _ (L _ x) = x-fold1' f (B _ _ t0 t1) = f (fold1' f t0) $! (fold1' f t1)--filter :: (a -> Bool) -> FM a -> FM a-filter _ E = E-filter g t@(L _ x) = if g x then t else E-filter g (B p m t0 t1) = makeB p m (filter g t0) (filter g t1)--partition :: (a -> Bool) -> FM a -> (FM a, FM a)-partition _ E = (E, E)-partition g t@(L _ x) = if g x then (t, E) else (E, t)-partition g (B p m t0 t1) =- let (t0',t0'') = partition g t0- (t1',t1'') = partition g t1- in (makeB p m t0' t1', makeB p m t0'' t1'')--fromSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a-fromSeqWith f = S.foldl (\t (k, x) -> insertWith f k x t) E--insertWith :: (a -> a -> a) -> Int -> a -> FM a -> FM a-insertWith _ k x E = L k x-insertWith f k x t@(L j y) = if j == k then L k (f x y) else join k (L k x) j t-insertWith f k x t@(B p m t0 t1) =- if matchPrefix k p m then- if zeroBit k m then B p m (insertWith f k x t0) t1- else B p m t0 (insertWith f k x t1)- else join k (L k x) p t--unionl :: FM a -> FM a -> FM a-unionl s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then B p m (unionl s0 t) s1- else B p m s0 (unionl s1 t)- else join p s q t- | m > n = if matchPrefix p q n then- if zeroBit p n then B q n (unionl s t0) t1- else B q n t0 (unionl s t1)- else join p s q t- | otherwise = if p == q then B p m (unionl s0 t0) (unionl s1 t1)- else join p s q t-unionl s@(B p m s0 s1) (L k x) =- if matchPrefix k p m then- if zeroBit k m then B p m (insertWith keepR k x s0) s1- else B p m s0 (insertWith keepR k x s1)- else join k (L k x) p s-unionl s@(B _ _ _ _) E = s-unionl (L k x) t = insert k x t-unionl E t = t--unionr :: FM a -> FM a -> FM a-unionr s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then B p m (unionr s0 t) s1- else B p m s0 (unionr s1 t)- else join p s q t- | m > n = if matchPrefix p q n then- if zeroBit p n then B q n (unionr s t0) t1- else B q n t0 (unionr s t1)- else join p s q t- | otherwise = if p == q then B p m (unionr s0 t0) (unionr s1 t1)- else join p s q t-unionr s@(B p m s0 s1) (L k x) =- if matchPrefix k p m then- if zeroBit k m then B p m (insert k x s0) s1- else B p m s0 (insert k x s1)- else join k (L k x) p s-unionr s@(B _ _ _ _) E = s-unionr (L k x) t = insertWith keepR k x t-unionr E t = t--unionWith :: (a -> a -> a) -> FM a -> FM a -> FM a-unionWith f s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then B p m (unionWith f s0 t) s1- else B p m s0 (unionWith f s1 t)- else join p s q t- | m > n = if matchPrefix p q n then- if zeroBit p n then B q n (unionWith f s t0) t1- else B q n t0 (unionWith f s t1)- else join p s q t- | otherwise = if p == q then B p m (unionWith f s0 t0) (unionWith f s1 t1)- else join p s q t-unionWith f s@(B p m s0 s1) (L k x) =- if matchPrefix k p m then- if zeroBit k m then B p m (insertWith (flip f) k x s0) s1- else B p m s0 (insertWith (flip f) k x s1)- else join k (L k x) p s-unionWith _ s@(B _ _ _ _) E = s-unionWith f (L k x) t = insertWith f k x t-unionWith _ E t = t--intersectionWith :: (a -> b -> c) -> FM a -> FM b -> FM c-intersectionWith f s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then intersectionWith f s0 t- else intersectionWith f s1 t- else E- | m > n = if matchPrefix p q n then- if zeroBit p n then intersectionWith f s t0- else intersectionWith f s t1- else E- | otherwise = if p /= q then E- else makeB p m (intersectionWith f s0 t0) (intersectionWith f s1 t1)-intersectionWith f (B _ m s0 s1) (L k y) =- case lookupM k (if zeroBit k m then s0 else s1) of- Just x -> L k (f x y)- Nothing -> E-intersectionWith _ (B _ _ _ _) E = E-intersectionWith f (L k x) t =- case lookupM k t of- Just y -> L k (f x y)- Nothing -> E-intersectionWith _ E _ = E--difference :: FM a -> FM b -> FM a-difference s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then lmakeB p m (difference s0 t) s1- else rmakeB p m s0 (difference s1 t)- else s- | m > n = if matchPrefix p q n then- if zeroBit p n then difference s t0- else difference s t1- else s- | otherwise = if p /= q then s- else makeB p m (difference s0 t0) (difference s1 t1)-difference s@(B p m s0 s1) (L k _) =- if matchPrefix k p m then- if zeroBit k m then lmakeB p m (delete k s0) s1- else rmakeB p m s0 (delete k s1)- else s-difference s@(B _ _ _ _) E = s-difference s@(L k _) t = if member k t then E else s-difference E _ = E--properSubset :: FM a -> FM b -> Bool-properSubset s t = case subset' s t of {LT -> True; _ -> False}--subset' :: FM t -> FM t1 -> Ordering-subset' s@(B p m s0 s1) (B q n t0 t1)- | m < n = GT- | m > n = if matchPrefix p q n then- if zeroBit p n then subset' s t0- else subset' s t1- else GT- | otherwise = if p == q then case (subset' s0 t0,subset' s1 t1) of- (GT,_) -> GT- (_,GT) -> GT- (EQ,EQ) -> EQ- (_,_) -> LT- else GT-subset' (B _ _ _ _) _ = GT-subset' (L k _) (L j _) = if k == j then EQ else GT-subset' (L k _) t = if member k t then LT else GT-subset' E E = EQ-subset' E _ = LT--subset :: FM a -> FM b -> Bool-subset s@(B p m s0 s1) (B q n t0 t1)- | m < n = False- | m > n = matchPrefix p q n && (if zeroBit p n then subset s t0- else subset s t1)- | otherwise = (p == q) && subset s0 t0 && subset s1 t1-subset (B _ _ _ _) _ = False-subset (L k _) t = member k t-subset E _ = True--properSubmapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool-properSubmapBy = properSubmapByUsingSubmapBy--submapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool-submapBy = submapByUsingLookupM--sameMapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool-sameMapBy = sameMapByUsingSubmapBy--properSubmap :: (Eq a) => FM a -> FM a -> Bool-properSubmap = A.properSubmap--submap :: (Eq a) => FM a -> FM a -> Bool-submap = A.submap--sameMap :: (Eq a) => FM a -> FM a -> Bool-sameMap = A.sameMap--mapWithKey :: (Int -> a -> b) -> FM a -> FM b-mapWithKey _ E = E-mapWithKey f (L k x) = L k (f k x)-mapWithKey f (B p m t0 t1) = B p m (mapWithKey f t0) (mapWithKey f t1)--foldWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b-foldWithKey _ c E = c-foldWithKey f c (L k x) = f k x c-foldWithKey f c (B _ _ t0 t1) = foldWithKey f (foldWithKey f c t1) t0--foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b-foldWithKey' _ c E = c-foldWithKey' f c (L k x) = c `seq` f k x c-foldWithKey' f c (B _ _ t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0---filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a-filterWithKey _ E = E-filterWithKey g t@(L k x) = if g k x then t else E-filterWithKey g (B p m t0 t1) =- makeB p m (filterWithKey g t0) (filterWithKey g t1)--partitionWithKey :: (Int -> a -> Bool) -> FM a -> (FM a, FM a)-partitionWithKey _ E = (E, E)-partitionWithKey g t@(L k x) = if g k x then (t, E) else (E, t)-partitionWithKey g (B p m t0 t1) =- let (t0',t0'') = partitionWithKey g t0- (t1',t1'') = partitionWithKey g t1- in (makeB p m t0' t1', makeB p m t0'' t1'')--unionWithKey :: (Int -> a -> a -> a) -> FM a -> FM a -> FM a-unionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then B p m (unionWithKey f s0 t) s1- else B p m s0 (unionWithKey f s1 t)- else join p s q t- | m > n = if matchPrefix p q n then- if zeroBit p n then B q n (unionWithKey f s t0) t1- else B q n t0 (unionWithKey f s t1)- else join p s q t- | otherwise = if p == q then B p m (unionWithKey f s0 t0) (unionWithKey f s1 t1)- else join p s q t-unionWithKey f s@(B p m s0 s1) (L k x) =- if matchPrefix k p m then- if zeroBit k m then B p m (insertWith (flip (f k)) k x s0) s1- else B p m s0 (insertWith (flip (f k)) k x s1)- else join k (L k x) p s-unionWithKey _ s@(B _ _ _ _) E = s-unionWithKey f (L k x) t = insertWith (f k) k x t-unionWithKey _ E t = t--intersectionWithKey :: (Int -> a -> b -> c) -> FM a -> FM b -> FM c-intersectionWithKey f s@(B p m s0 s1) t@(B q n t0 t1)- | m < n = if matchPrefix q p m then- if zeroBit q m then intersectionWithKey f s0 t- else intersectionWithKey f s1 t- else E- | m > n = if matchPrefix p q n then- if zeroBit p n then intersectionWithKey f s t0- else intersectionWithKey f s t1- else E- | otherwise = if p /= q then E- else makeB p m (intersectionWithKey f s0 t0) (intersectionWithKey f s1 t1)-intersectionWithKey f (B _ m s0 s1) (L k y) =- case lookupM k (if zeroBit k m then s0 else s1) of- Just x -> L k (f k x y)- Nothing -> E-intersectionWithKey _ (B _ _ _ _) E = E-intersectionWithKey f (L k x) t =- case lookupM k t of- Just y -> L k (f k x y)- Nothing -> E-intersectionWithKey _ E _ = E---- Datastructure definition is strict in all submaps,--- no forcing required-strict :: t -> t-strict n = n--strictWith :: (t -> a) -> FM t -> FM t-strictWith _ n@E = n-strictWith f n@(L _ x) = f x `seq` n-strictWith f n@(B _ _ m1 m2) = strictWith f m1 `seq` strictWith f m2 `seq` n---ordListFM :: FM a -> [(Int,a)]-ordListFM E = []-ordListFM (L k x) = [(k,x)]-ordListFM (B _ _ t0 t1) = merge (ordListFM t0) (ordListFM t1)- where merge [] ys = ys- merge xs [] = xs- merge (x@(k1,_):xs) (y@(k2,_):ys) =- case compare k1 k2 of- LT -> x : merge xs (y:ys)- GT -> y : merge (x:xs) ys- EQ -> error "PatriciaLoMap: bug in ordListFM"--ordListFM_rev :: FM a -> [(Int,a)]-ordListFM_rev E = []-ordListFM_rev (L k x) = [(k,x)]-ordListFM_rev (B _ _ t0 t1) = merge (ordListFM_rev t0) (ordListFM_rev t1)- where merge [] ys = ys- merge xs [] = xs- merge (x@(k1,_):xs) (y@(k2,_):ys) =- case compare k1 k2 of- LT -> y : merge (x:xs) ys- GT -> x : merge xs (y:ys)- EQ -> error "PatriciaLoMap: bug in ordListFM_rev"--minView :: Monad m => FM a -> m (a, FM a)-minView fm =- case ordListFM fm of- [] -> fail $ moduleName++".minView: empty map"- ((k,x):_) -> return (x,delete k fm)--minViewWithKey :: Monad m => FM a -> m ((Int, a), FM a)-minViewWithKey fm =- case ordListFM fm of- [] -> fail $ moduleName++".minViewWithKey: empty map"- ((k,x):_) -> return ((k,x),delete k fm)--maxView :: Monad m => FM a -> m (a, FM a)-maxView fm =- case ordListFM_rev fm of- [] -> fail $ moduleName++".maxView: empty map"- ((k,x):_) -> return (x,delete k fm)--maxViewWithKey :: Monad m => FM a -> m ((Int, a), FM a)-maxViewWithKey fm =- case ordListFM_rev fm of- [] -> fail $ moduleName++".maxViewWithKey: empty map"- ((k,x):_) -> return ((k,x),delete k fm)--minElem :: FM a -> a-minElem = minElemUsingMinView--minElemWithKey :: FM a -> (Int,a)-minElemWithKey = minElemWithKeyUsingMinViewWithKey--deleteMin :: FM a -> FM a-deleteMin = deleteMinUsingMinView--unsafeInsertMin :: Int -> a -> FM a -> FM a-unsafeInsertMin = insert--maxElem :: FM a -> a-maxElem = maxElemUsingMaxView--deleteMax :: FM a -> FM a-deleteMax = deleteMaxUsingMaxView--maxElemWithKey :: FM a -> (Int,a)-maxElemWithKey = maxElemWithKeyUsingMaxViewWithKey--unsafeInsertMax :: Int -> a -> FM a -> FM a-unsafeInsertMax = insert--foldr :: (a -> b -> b) -> b -> FM a -> b-foldr f z fm = L.foldr f z . L.map snd . ordListFM $ fm--foldr' :: (a -> b -> b) -> b -> FM a -> b-foldr' f z fm = L.foldl' (flip f) z . L.map snd . ordListFM_rev $ fm--foldr1 :: (a -> a -> a) -> FM a -> a-foldr1 f fm = L.foldr1 f . L.map snd . ordListFM $ fm--foldr1' :: (a -> a -> a) -> FM a -> a-foldr1' f fm = L.foldl1' (flip f) . L.map snd . ordListFM_rev $ fm--foldl :: (b -> a -> b) -> b -> FM a -> b-foldl f z fm = L.foldr (flip f) z . L.map snd . ordListFM_rev $ fm--foldl' :: (b -> a -> b) -> b -> FM a -> b-foldl' f z fm = L.foldl' f z . L.map snd . ordListFM $ fm--foldl1 :: (a -> a -> a) -> FM a -> a-foldl1 f fm = L.foldr1 (flip f) . L.map snd . ordListFM_rev $ fm--foldl1' :: (a -> a -> a) -> FM a -> a-foldl1' f fm = L.foldl1' f . L.map snd . ordListFM $ fm--foldrWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b-foldrWithKey f z fm = L.foldr (uncurry f) z . ordListFM $ fm--foldrWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b-foldrWithKey' f z fm = L.foldl' (flip (uncurry f)) z . ordListFM_rev $ fm--foldlWithKey :: (b -> Int -> a -> b) -> b -> FM a -> b-foldlWithKey f z fm = L.foldr (\(k,x) a -> f a k x) z . ordListFM_rev $ fm--foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b-foldlWithKey' f z fm = L.foldl' (\a (k,x) -> f a k x) z . ordListFM $ fm---unsafeFromOrdSeq :: S.Sequence seq => seq (Int,a) -> FM a-unsafeFromOrdSeq = fromSeq--unsafeAppend :: FM a -> FM a -> FM a-unsafeAppend = union--filterLT :: Int -> FM a -> FM a-filterLT k = filterWithKey (\k' _ -> k' < k)--filterLE :: Int -> FM a -> FM a-filterLE k = filterWithKey (\k' _ -> k' <= k)--filterGT :: Int -> FM a -> FM a-filterGT k = filterWithKey (\k' _ -> k' > k)--filterGE :: Int -> FM a -> FM a-filterGE k = filterWithKey (\k' _ -> k' >= k)--partitionLT_GE :: Int -> FM a -> (FM a, FM a)-partitionLT_GE k fm = (filterLT k fm,filterGE k fm)--partitionLE_GT :: Int -> FM a -> (FM a,FM a)-partitionLE_GT k fm = (filterLE k fm,filterGT k fm)--partitionLT_GT :: Int -> FM a -> (FM a,FM a)-partitionLT_GT k fm = (filterLT k fm,filterGT k fm)--toOrdSeq :: S.Sequence seq => FM a -> seq (Int,a)-toOrdSeq = L.foldr S.lcons S.empty . ordListFM---- defaults--insertSeq :: S.Sequence seq => seq (Int,a) -> FM a -> FM a-insertSeq = insertSeqUsingFoldr--unionSeq :: S.Sequence seq => seq (FM a) -> FM a-unionSeq = unionSeqUsingReduce--deleteAll :: Int -> FM a -> FM a-deleteAll = delete--deleteSeq :: S.Sequence seq => seq Int -> FM a -> FM a-deleteSeq = deleteSeqUsingFoldr--count :: Int -> FM a -> Int-count = countUsingMember--lookupAll :: S.Sequence seq => Int -> FM a -> seq a-lookupAll = lookupAllUsingLookupM--lookupWithDefault :: a -> Int -> FM a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--elements :: S.Sequence seq => FM a -> seq a-elements = elementsUsingFold--fromSeqWithKey ::- S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a-fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey--insertWithKey :: (Int -> a -> a -> a) -> Int -> a -> FM a -> FM a-insertWithKey = insertWithKeyUsingInsertWith--insertSeqWith ::- S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a -> FM a-insertSeqWith = insertSeqWithUsingInsertWith--insertSeqWithKey ::- S.Sequence seq =>- (Int -> a -> a -> a) -> seq (Int,a) -> FM a -> FM a-insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey--adjustAll :: (a -> a) -> Int -> FM a -> FM a-adjustAll = adjust--unionSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (FM a) -> FM a-unionSeqWith = unionSeqWithUsingReduce--toSeq :: S.Sequence seq => FM a -> seq (Int,a)-toSeq = toSeqUsingFoldWithKey--keys :: S.Sequence seq => FM a -> seq Int-keys = keysUsingFoldWithKey--unionSeqWithKey ::- S.Sequence seq => (Int -> a -> a -> a) -> seq (FM a) -> FM a-unionSeqWithKey = unionSeqWithKeyUsingReduce---- instance declarations--instance A.AssocX FM Int where- {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; union = union; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;- lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;- lookupAndDeleteAll = lookupAndDeleteAll;- lookupWithDefault = lookupWithDefault; adjust = adjust;- adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;- adjustAllOrInsert = adjustAllOrInsert;- adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; elements = elements;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance A.Assoc FM Int where- {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;- foldWithKey = foldWithKey; foldWithKey' = foldWithKey';- filterWithKey = filterWithKey;- partitionWithKey = partitionWithKey}--instance A.FiniteMapX FM Int where- {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;- insertWith = insertWith; insertWithKey = insertWithKey;- insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;- unionl = unionl; unionr = unionr; unionWith = unionWith;- unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;- difference = difference; properSubset = properSubset; subset = subset;- properSubmapBy = properSubmapBy; submapBy = submapBy;- sameMapBy = sameMapBy}--instance A.FiniteMap FM Int where- {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;- intersectionWithKey = intersectionWithKey}--instance A.OrdAssocX FM Int where- {minView = minView; minElem = minElem; deleteMin = deleteMin;- unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;- deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance A.OrdAssoc FM Int where- {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;- maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;- foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';- foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';- toOrdSeq = toOrdSeq}--instance A.OrdFiniteMapX FM Int-instance A.OrdFiniteMap FM Int--instance Functor FM where- fmap = map--instance (Show a) => Show (FM a) where- showsPrec = showsPrecUsingToList--instance (Read a) => Read (FM a) where- readsPrec = readsPrecUsingFromList--instance (Eq a) => Eq (FM a) where- (==) = sameMap--instance (Ord a) => Ord (FM a) where- compare = compareUsingToOrdList--instance (Arbitrary a) => Arbitrary (FM a) where- arbitrary = do xs <- arbitrary- return (Prelude.foldr (uncurry insert) empty xs)--instance (CoArbitrary a) => CoArbitrary (FM a) where- coarbitrary E = variant 0- coarbitrary (L i a) = variant 1 . coarbitrary i . coarbitrary a- coarbitrary (B i j m n) = variant 2 . coarbitrary i . coarbitrary j- . coarbitrary m . coarbitrary n---instance Monoid (FM a) where- mempty = empty- mappend = union- mconcat = unionSeq+-- | +-- Module : Data.Edison.Assoc.PatriciaLoMap +-- Copyright : Copyright (c) 1998, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Finite maps implemented as little-endian Patricia trees. +-- +-- /References:/ +-- +-- * Chris Okasaki and Any Gill. \"Fast Mergeable Integer Maps\". +-- Workshop on ML, September 1998, pages 77-86. + +module Data.Edison.Assoc.PatriciaLoMap ( + -- * Type of little-endian Patricia trees + FM, + + -- * AssocX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, + lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,strict,strictWith, + lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,map, + fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, + + -- * Assoc operations + toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, + + -- * FiniteMapX operations + fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, + insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, + difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, + properSubmap,submap,sameMap, + + -- * FiniteMap operations + unionWithKey,unionSeqWithKey,intersectionWithKey, + + -- * OrdAssocX operations + minView, minElem, deleteMin, unsafeInsertMin, + maxView, maxElem, deleteMax, unsafeInsertMax, + foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1', + unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE, + partitionLT_GE, partitionLE_GT, partitionLT_GT, + + -- * OrdAssoc operations + minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, + foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', + toOrdSeq, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter) +import qualified Prelude +import qualified Control.Monad.Fail as Fail +import Data.Monoid +import Data.Semigroup as SG +import qualified Data.Edison.Assoc as A +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Assoc.Defaults +import Data.Int +import Data.Bits +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant) + +moduleName :: String +moduleName = "Data.Edison.Assoc.PatriciaLoMap" + +data FM a + = E + | L Int a + | B Int Int !(FM a) !(FM a) + +-- Invariants: +-- * No B node has an E child +-- * first argument to B is a prefix +-- * second argument to B is the "branching bit" and is +-- always an exact power of two +-- * all bits in the prefix >= the branching bit are zeros +-- * valid prefix bits match all subnodes + +structuralInvariant :: FM a -> Bool +structuralInvariant E = True +structuralInvariant (L _ _) = True +structuralInvariant x = inv 0 0 x + +inv :: Int -> Int -> FM a -> Bool +inv _ _ E = False +inv pre msk (L k _) = k .&. msk == pre +inv pre msk (B p m t0 t1) = + (p .&. msk == pre) && + (bitcount 0 m == 1) && + (p .&. (complement (m - 1)) == 0) && + inv p0 msk' t0 && + inv p1 msk' t1 + + where p0 = p + p1 = p .|. m + msk' = (m `shiftL` 1) - 1 + +bitcount :: Int -> Int -> Int +bitcount a 0 = a +bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1)) + +-- auxiliary functions + +makeB :: Int -> Int -> FM t -> FM t -> FM t +makeB _ _ E t = t +makeB _ _ t E = t +makeB p m t0 t1 = B p m t0 t1 + +lmakeB :: Int -> Int -> FM t -> FM t -> FM t +lmakeB _ _ E t = t +lmakeB p m t0 t1 = B p m t0 t1 + +rmakeB :: Int -> Int -> FM a -> FM a -> FM a +rmakeB _ _ t E = t +rmakeB p m t0 t1 = B p m t0 t1 + +lowestBit :: Word -> Word +lowestBit x = x .&. (-x) + +branchingBit :: Int -> Int -> Int +branchingBit p0 p1 = + fromIntegral (lowestBit (fromIntegral p0 `xor` fromIntegral p1)) + +mask :: Int -> Int -> Int +mask p m = fromIntegral (fromIntegral p .&. (fromIntegral m - (1 :: Word))) + +shorter :: Int -> Int -> Bool +shorter m n = fromIntegral m < (fromIntegral n :: Word) + +zeroBit :: Int -> Int -> Bool +zeroBit p m = (fromIntegral p) .&. (fromIntegral m) == (0 :: Word) + +matchPrefix :: Int -> Int -> Int -> Bool +matchPrefix k p m = mask k m == p + +join :: Int -> FM a -> Int -> FM a -> FM a +join p0 t0 p1 t1 = + let m = branchingBit p0 p1 + in if zeroBit p0 m then B (mask p0 m) m t0 t1 + else B (mask p0 m) m t1 t0 + +keepR :: forall t t1. t -> t1 -> t1 +keepR _ y = y + +-- end auxiliary functions + +empty :: FM a +empty = E + +singleton :: Int -> a -> FM a +singleton k x = L k x + +fromSeq :: S.Sequence seq => seq (Int,a) -> FM a +fromSeq = S.foldl (\t (k, x) -> insert k x t) E + +insert :: Int -> a -> FM a -> FM a +insert k x E = L k x +insert k x t@(L j _) = if j == k then L k x else join k (L k x) j t +insert k x t@(B p m t0 t1) = + if matchPrefix k p m then + if zeroBit k m then B p m (insert k x t0) t1 + else B p m t0 (insert k x t1) + else join k (L k x) p t + +union :: FM a -> FM a -> FM a +union s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then B p m (union s0 t) s1 + else B p m s0 (union s1 t) + else join p s q t + | shorter n m = if matchPrefix p q n then + if zeroBit p n then B q n (union s t0) t1 + else B q n t0 (union s t1) + else join p s q t + | otherwise = if p == q then B p m (union s0 t0) (union s1 t1) + else join p s q t +union s@(B p m s0 s1) (L k x) = + if matchPrefix k p m then + if zeroBit k m then B p m (insert k x s0) s1 + else B p m s0 (insert k x s1) + else join k (L k x) p s +union s@(B _ _ _ _) E = s +union (L k x) t = insert k x t +union E t = t + +delete :: Int -> FM a -> FM a +delete _ E = E +delete k t@(L j _) = if k == j then E else t +delete k t@(B p m t0 t1) = + if matchPrefix k p m then + if zeroBit k m then lmakeB p m (delete k t0) t1 + else rmakeB p m t0 (delete k t1) + else t + +null :: FM a -> Bool +null E = True +null _ = False + +size :: FM a -> Int +size E = 0 +size (L _ _) = 1 +size (B _ _ t0 t1) = size t0 + size t1 + +member :: Int -> FM a -> Bool +member _ E = False +member k (L j _) = (j == k) +member k (B _ m t0 t1) = if zeroBit k m then member k t0 else member k t1 + +lookup :: Int -> FM a -> a +lookup k m = runFail_ (lookupM k m) + +lookupM :: (Fail.MonadFail rm) => Int -> FM a -> rm a +lookupM _ E = fail "PatriciaLoMap.lookup: lookup failed" +lookupM k (L j x) + | j == k = return x + | otherwise = fail "PatriciaLoMap.lookup: lookup failed" +lookupM k (B _ m t0 t1) = if zeroBit k m then lookupM k t0 else lookupM k t1 + +doLookupAndDelete :: z -> (a -> FM a -> z) -> Int -> FM a -> z +doLookupAndDelete onFail _ _ E = onFail +doLookupAndDelete onFail cont k (L j x) + | j == k = cont x E + | otherwise = onFail +doLookupAndDelete onFail cont k (B p m t0 t1) + | zeroBit k m = doLookupAndDelete onFail (\x t0' -> cont x (makeB p m t0' t1)) k t0 + | otherwise = doLookupAndDelete onFail (\x t1' -> cont x (makeB p m t0 t1')) k t1 + +lookupAndDelete :: Int -> FM a -> (a, FM a) +lookupAndDelete = doLookupAndDelete + (error "PatriciaLoMap.lookupAndDelete: lookup failed") + (,) + +lookupAndDeleteM :: Fail.MonadFail m => Int -> FM a -> m (a, FM a) +lookupAndDeleteM = doLookupAndDelete + (fail "PatriciaLoMap.lookupAndDelete: lookup failed") + (\x m -> return (x,m)) + +lookupAndDeleteAll :: S.Sequence seq => Int -> FM a -> (seq a,FM a) +lookupAndDeleteAll k m = doLookupAndDelete + (S.empty, m) + (\x m' -> (S.singleton x,m')) + k m + + +adjust :: (a -> a) -> Int -> FM a -> FM a +adjust _ _ E = E +adjust f k t@(L j x) = if k == j then L k (f x) else t +adjust f k t@(B p m t0 t1) = + if matchPrefix k p m then + if zeroBit k m then B p m (adjust f k t0) t1 + else B p m t0 (adjust f k t1) + else t + +-- FIXME can we do better than this? +adjustOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a +adjustOrInsert = adjustOrInsertUsingMember + +adjustAllOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a +adjustAllOrInsert = adjustOrInsertUsingMember + +adjustOrDelete :: (a -> Maybe a) -> Int -> FM a -> FM a +adjustOrDelete = adjustOrDeleteDefault + +adjustOrDeleteAll :: (a -> Maybe a) -> Int -> FM a -> FM a +adjustOrDeleteAll = adjustOrDeleteDefault + +map :: (a -> b) -> FM a -> FM b +map _ E = E +map f (L k x) = L k (f x) +map f (B p m t0 t1) = B p m (map f t0) (map f t1) + +fold :: (a -> b -> b) -> b -> FM a -> b +fold _ c E = c +fold f c (L _ x) = f x c +fold f c (B _ _ t0 t1) = fold f (fold f c t1) t0 + +fold' :: (a -> b -> b) -> b -> FM a -> b +fold' _ c E = c +fold' f c (L _ x) = c `seq` f x c +fold' f c (B _ _ t0 t1) = c `seq` (fold f $! (fold f c t1)) t0 + +fold1 :: (a -> a -> a) -> FM a -> a +fold1 _ E = error "PatriciaLoMap.fold1: empty map" +fold1 _ (L _ x) = x +fold1 f (B _ _ t0 t1) = f (fold1 f t0) (fold1 f t1) + +fold1' :: (a -> a -> a) -> FM a -> a +fold1' _ E = error "PatriciaLoMap.fold1: empty map" +fold1' _ (L _ x) = x +fold1' f (B _ _ t0 t1) = f (fold1' f t0) $! (fold1' f t1) + +filter :: (a -> Bool) -> FM a -> FM a +filter _ E = E +filter g t@(L _ x) = if g x then t else E +filter g (B p m t0 t1) = makeB p m (filter g t0) (filter g t1) + +partition :: (a -> Bool) -> FM a -> (FM a, FM a) +partition _ E = (E, E) +partition g t@(L _ x) = if g x then (t, E) else (E, t) +partition g (B p m t0 t1) = + let (t0',t0'') = partition g t0 + (t1',t1'') = partition g t1 + in (makeB p m t0' t1', makeB p m t0'' t1'') + +fromSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a +fromSeqWith f = S.foldl (\t (k, x) -> insertWith f k x t) E + +insertWith :: (a -> a -> a) -> Int -> a -> FM a -> FM a +insertWith _ k x E = L k x +insertWith f k x t@(L j y) = if j == k then L k (f x y) else join k (L k x) j t +insertWith f k x t@(B p m t0 t1) = + if matchPrefix k p m then + if zeroBit k m then B p m (insertWith f k x t0) t1 + else B p m t0 (insertWith f k x t1) + else join k (L k x) p t + +unionl :: FM a -> FM a -> FM a +unionl s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then B p m (unionl s0 t) s1 + else B p m s0 (unionl s1 t) + else join p s q t + | shorter n m = if matchPrefix p q n then + if zeroBit p n then B q n (unionl s t0) t1 + else B q n t0 (unionl s t1) + else join p s q t + | otherwise = if p == q then B p m (unionl s0 t0) (unionl s1 t1) + else join p s q t +unionl s@(B p m s0 s1) (L k x) = + if matchPrefix k p m then + if zeroBit k m then B p m (insertWith keepR k x s0) s1 + else B p m s0 (insertWith keepR k x s1) + else join k (L k x) p s +unionl s@(B _ _ _ _) E = s +unionl (L k x) t = insert k x t +unionl E t = t + +unionr :: FM a -> FM a -> FM a +unionr s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then B p m (unionr s0 t) s1 + else B p m s0 (unionr s1 t) + else join p s q t + | shorter n m = if matchPrefix p q n then + if zeroBit p n then B q n (unionr s t0) t1 + else B q n t0 (unionr s t1) + else join p s q t + | otherwise = if p == q then B p m (unionr s0 t0) (unionr s1 t1) + else join p s q t +unionr s@(B p m s0 s1) (L k x) = + if matchPrefix k p m then + if zeroBit k m then B p m (insert k x s0) s1 + else B p m s0 (insert k x s1) + else join k (L k x) p s +unionr s@(B _ _ _ _) E = s +unionr (L k x) t = insertWith keepR k x t +unionr E t = t + +unionWith :: (a -> a -> a) -> FM a -> FM a -> FM a +unionWith f s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then B p m (unionWith f s0 t) s1 + else B p m s0 (unionWith f s1 t) + else join p s q t + | shorter n m = if matchPrefix p q n then + if zeroBit p n then B q n (unionWith f s t0) t1 + else B q n t0 (unionWith f s t1) + else join p s q t + | otherwise = if p == q then B p m (unionWith f s0 t0) (unionWith f s1 t1) + else join p s q t +unionWith f s@(B p m s0 s1) (L k x) = + if matchPrefix k p m then + if zeroBit k m then B p m (insertWith (flip f) k x s0) s1 + else B p m s0 (insertWith (flip f) k x s1) + else join k (L k x) p s +unionWith _ s@(B _ _ _ _) E = s +unionWith f (L k x) t = insertWith f k x t +unionWith _ E t = t + +intersectionWith :: (a -> b -> c) -> FM a -> FM b -> FM c +intersectionWith f s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then intersectionWith f s0 t + else intersectionWith f s1 t + else E + | shorter n m = if matchPrefix p q n then + if zeroBit p n then intersectionWith f s t0 + else intersectionWith f s t1 + else E + | otherwise = if p /= q then E + else makeB p m (intersectionWith f s0 t0) (intersectionWith f s1 t1) +intersectionWith f (B _ m s0 s1) (L k y) = + case lookupM k (if zeroBit k m then s0 else s1) of + Just x -> L k (f x y) + Nothing -> E +intersectionWith _ (B _ _ _ _) E = E +intersectionWith f (L k x) t = + case lookupM k t of + Just y -> L k (f x y) + Nothing -> E +intersectionWith _ E _ = E + +difference :: FM a -> FM b -> FM a +difference s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then lmakeB p m (difference s0 t) s1 + else rmakeB p m s0 (difference s1 t) + else s + | shorter n m = if matchPrefix p q n then + if zeroBit p n then difference s t0 + else difference s t1 + else s + | otherwise = if p /= q then s + else makeB p m (difference s0 t0) (difference s1 t1) +difference s@(B p m s0 s1) (L k _) = + if matchPrefix k p m then + if zeroBit k m then lmakeB p m (delete k s0) s1 + else rmakeB p m s0 (delete k s1) + else s +difference s@(B _ _ _ _) E = s +difference s@(L k _) t = if member k t then E else s +difference E _ = E + +properSubset :: FM a -> FM b -> Bool +properSubset s t = case subset' s t of {LT -> True; _ -> False} + +subset' :: FM t -> FM t1 -> Ordering +subset' s@(B p m s0 s1) (B q n t0 t1) + | shorter m n = GT + | shorter n m = if matchPrefix p q n then + if zeroBit p n then subset' s t0 SG.<> LT + else subset' s t1 SG.<> LT + else GT + | otherwise = if p == q then case (subset' s0 t0,subset' s1 t1) of + (GT,_) -> GT + (_,GT) -> GT + (EQ,EQ) -> EQ + (_,_) -> LT + else GT +subset' (B _ _ _ _) _ = GT +subset' (L k _) (L j _) = if k == j then EQ else GT +subset' (L k _) t = if member k t then LT else GT +subset' E E = EQ +subset' E _ = LT + +subset :: FM a -> FM b -> Bool +subset s@(B p m s0 s1) (B q n t0 t1) + | shorter m n = False + | shorter n m = matchPrefix p q n && (if zeroBit p n then subset s t0 + else subset s t1) + | otherwise = (p == q) && subset s0 t0 && subset s1 t1 +subset (B _ _ _ _) _ = False +subset (L k _) t = member k t +subset E _ = True + +properSubmapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool +properSubmapBy = properSubmapByUsingSubmapBy + +submapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool +submapBy = submapByUsingLookupM + +sameMapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool +sameMapBy = sameMapByUsingSubmapBy + +properSubmap :: (Eq a) => FM a -> FM a -> Bool +properSubmap = A.properSubmap + +submap :: (Eq a) => FM a -> FM a -> Bool +submap = A.submap + +sameMap :: (Eq a) => FM a -> FM a -> Bool +sameMap = A.sameMap + +mapWithKey :: (Int -> a -> b) -> FM a -> FM b +mapWithKey _ E = E +mapWithKey f (L k x) = L k (f k x) +mapWithKey f (B p m t0 t1) = B p m (mapWithKey f t0) (mapWithKey f t1) + +foldWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b +foldWithKey _ c E = c +foldWithKey f c (L k x) = f k x c +foldWithKey f c (B _ _ t0 t1) = foldWithKey f (foldWithKey f c t1) t0 + +foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b +foldWithKey' _ c E = c +foldWithKey' f c (L k x) = c `seq` f k x c +foldWithKey' f c (B _ _ t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0 + + +filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a +filterWithKey _ E = E +filterWithKey g t@(L k x) = if g k x then t else E +filterWithKey g (B p m t0 t1) = + makeB p m (filterWithKey g t0) (filterWithKey g t1) + +partitionWithKey :: (Int -> a -> Bool) -> FM a -> (FM a, FM a) +partitionWithKey _ E = (E, E) +partitionWithKey g t@(L k x) = if g k x then (t, E) else (E, t) +partitionWithKey g (B p m t0 t1) = + let (t0',t0'') = partitionWithKey g t0 + (t1',t1'') = partitionWithKey g t1 + in (makeB p m t0' t1', makeB p m t0'' t1'') + +unionWithKey :: (Int -> a -> a -> a) -> FM a -> FM a -> FM a +unionWithKey f s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then B p m (unionWithKey f s0 t) s1 + else B p m s0 (unionWithKey f s1 t) + else join p s q t + | shorter n m = if matchPrefix p q n then + if zeroBit p n then B q n (unionWithKey f s t0) t1 + else B q n t0 (unionWithKey f s t1) + else join p s q t + | otherwise = if p == q then B p m (unionWithKey f s0 t0) (unionWithKey f s1 t1) + else join p s q t +unionWithKey f s@(B p m s0 s1) (L k x) = + if matchPrefix k p m then + if zeroBit k m then B p m (insertWith (flip (f k)) k x s0) s1 + else B p m s0 (insertWith (flip (f k)) k x s1) + else join k (L k x) p s +unionWithKey _ s@(B _ _ _ _) E = s +unionWithKey f (L k x) t = insertWith (f k) k x t +unionWithKey _ E t = t + +intersectionWithKey :: (Int -> a -> b -> c) -> FM a -> FM b -> FM c +intersectionWithKey f s@(B p m s0 s1) t@(B q n t0 t1) + | shorter m n = if matchPrefix q p m then + if zeroBit q m then intersectionWithKey f s0 t + else intersectionWithKey f s1 t + else E + | shorter n m = if matchPrefix p q n then + if zeroBit p n then intersectionWithKey f s t0 + else intersectionWithKey f s t1 + else E + | otherwise = if p /= q then E + else makeB p m (intersectionWithKey f s0 t0) (intersectionWithKey f s1 t1) +intersectionWithKey f (B _ m s0 s1) (L k y) = + case lookupM k (if zeroBit k m then s0 else s1) of + Just x -> L k (f k x y) + Nothing -> E +intersectionWithKey _ (B _ _ _ _) E = E +intersectionWithKey f (L k x) t = + case lookupM k t of + Just y -> L k (f k x y) + Nothing -> E +intersectionWithKey _ E _ = E + +-- Datastructure definition is strict in all submaps, +-- no forcing required +strict :: t -> t +strict n = n + +strictWith :: (t -> a) -> FM t -> FM t +strictWith _ n@E = n +strictWith f n@(L _ x) = f x `seq` n +strictWith f n@(B _ _ m1 m2) = strictWith f m1 `seq` strictWith f m2 `seq` n + + +ordListFM :: FM a -> [(Int,a)] +ordListFM E = [] +ordListFM (L k x) = [(k,x)] +ordListFM (B _ _ t0 t1) = merge (ordListFM t0) (ordListFM t1) + where merge [] ys = ys + merge xs [] = xs + merge (x@(k1,_):xs) (y@(k2,_):ys) = + case compare k1 k2 of + LT -> x : merge xs (y:ys) + GT -> y : merge (x:xs) ys + EQ -> error "PatriciaLoMap: bug in ordListFM" + +ordListFM_rev :: FM a -> [(Int,a)] +ordListFM_rev E = [] +ordListFM_rev (L k x) = [(k,x)] +ordListFM_rev (B _ _ t0 t1) = merge (ordListFM_rev t0) (ordListFM_rev t1) + where merge [] ys = ys + merge xs [] = xs + merge (x@(k1,_):xs) (y@(k2,_):ys) = + case compare k1 k2 of + LT -> y : merge (x:xs) ys + GT -> x : merge xs (y:ys) + EQ -> error "PatriciaLoMap: bug in ordListFM_rev" + +minView :: Fail.MonadFail m => FM a -> m (a, FM a) +minView fm = + case ordListFM fm of + [] -> fail $ moduleName++".minView: empty map" + ((k,x):_) -> return (x,delete k fm) + +minViewWithKey :: Fail.MonadFail m => FM a -> m ((Int, a), FM a) +minViewWithKey fm = + case ordListFM fm of + [] -> fail $ moduleName++".minViewWithKey: empty map" + ((k,x):_) -> return ((k,x),delete k fm) + +maxView :: Fail.MonadFail m => FM a -> m (a, FM a) +maxView fm = + case ordListFM_rev fm of + [] -> fail $ moduleName++".maxView: empty map" + ((k,x):_) -> return (x,delete k fm) + +maxViewWithKey :: Fail.MonadFail m => FM a -> m ((Int, a), FM a) +maxViewWithKey fm = + case ordListFM_rev fm of + [] -> fail $ moduleName++".maxViewWithKey: empty map" + ((k,x):_) -> return ((k,x),delete k fm) + +minElem :: FM a -> a +minElem = minElemUsingMinView + +minElemWithKey :: FM a -> (Int,a) +minElemWithKey = minElemWithKeyUsingMinViewWithKey + +deleteMin :: FM a -> FM a +deleteMin = deleteMinUsingMinView + +unsafeInsertMin :: Int -> a -> FM a -> FM a +unsafeInsertMin = insert + +maxElem :: FM a -> a +maxElem = maxElemUsingMaxView + +deleteMax :: FM a -> FM a +deleteMax = deleteMaxUsingMaxView + +maxElemWithKey :: FM a -> (Int,a) +maxElemWithKey = maxElemWithKeyUsingMaxViewWithKey + +unsafeInsertMax :: Int -> a -> FM a -> FM a +unsafeInsertMax = insert + +foldr :: (a -> b -> b) -> b -> FM a -> b +foldr f z fm = L.foldr f z . L.map snd . ordListFM $ fm + +foldr' :: (a -> b -> b) -> b -> FM a -> b +foldr' f z fm = L.foldl' (flip f) z . L.map snd . ordListFM_rev $ fm + +foldr1 :: (a -> a -> a) -> FM a -> a +foldr1 f fm = L.foldr1 f . L.map snd . ordListFM $ fm + +foldr1' :: (a -> a -> a) -> FM a -> a +foldr1' f fm = L.foldl1' (flip f) . L.map snd . ordListFM_rev $ fm + +foldl :: (b -> a -> b) -> b -> FM a -> b +foldl f z fm = L.foldr (flip f) z . L.map snd . ordListFM_rev $ fm + +foldl' :: (b -> a -> b) -> b -> FM a -> b +foldl' f z fm = L.foldl' f z . L.map snd . ordListFM $ fm + +foldl1 :: (a -> a -> a) -> FM a -> a +foldl1 f fm = L.foldr1 (flip f) . L.map snd . ordListFM_rev $ fm + +foldl1' :: (a -> a -> a) -> FM a -> a +foldl1' f fm = L.foldl1' f . L.map snd . ordListFM $ fm + +foldrWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b +foldrWithKey f z fm = L.foldr (uncurry f) z . ordListFM $ fm + +foldrWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b +foldrWithKey' f z fm = L.foldl' (flip (uncurry f)) z . ordListFM_rev $ fm + +foldlWithKey :: (b -> Int -> a -> b) -> b -> FM a -> b +foldlWithKey f z fm = L.foldr (\(k,x) a -> f a k x) z . ordListFM_rev $ fm + +foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b +foldlWithKey' f z fm = L.foldl' (\a (k,x) -> f a k x) z . ordListFM $ fm + + +unsafeFromOrdSeq :: S.Sequence seq => seq (Int,a) -> FM a +unsafeFromOrdSeq = fromSeq + +unsafeAppend :: FM a -> FM a -> FM a +unsafeAppend = union + +filterLT :: Int -> FM a -> FM a +filterLT k = filterWithKey (\k' _ -> k' < k) + +filterLE :: Int -> FM a -> FM a +filterLE k = filterWithKey (\k' _ -> k' <= k) + +filterGT :: Int -> FM a -> FM a +filterGT k = filterWithKey (\k' _ -> k' > k) + +filterGE :: Int -> FM a -> FM a +filterGE k = filterWithKey (\k' _ -> k' >= k) + +partitionLT_GE :: Int -> FM a -> (FM a, FM a) +partitionLT_GE k fm = (filterLT k fm,filterGE k fm) + +partitionLE_GT :: Int -> FM a -> (FM a,FM a) +partitionLE_GT k fm = (filterLE k fm,filterGT k fm) + +partitionLT_GT :: Int -> FM a -> (FM a,FM a) +partitionLT_GT k fm = (filterLT k fm,filterGT k fm) + +toOrdSeq :: S.Sequence seq => FM a -> seq (Int,a) +toOrdSeq = L.foldr S.lcons S.empty . ordListFM + +-- defaults + +insertSeq :: S.Sequence seq => seq (Int,a) -> FM a -> FM a +insertSeq = insertSeqUsingFoldr + +unionSeq :: S.Sequence seq => seq (FM a) -> FM a +unionSeq = unionSeqUsingReduce + +deleteAll :: Int -> FM a -> FM a +deleteAll = delete + +deleteSeq :: S.Sequence seq => seq Int -> FM a -> FM a +deleteSeq = deleteSeqUsingFoldr + +count :: Int -> FM a -> Int +count = countUsingMember + +lookupAll :: S.Sequence seq => Int -> FM a -> seq a +lookupAll = lookupAllUsingLookupM + +lookupWithDefault :: a -> Int -> FM a -> a +lookupWithDefault = lookupWithDefaultUsingLookupM + +elements :: S.Sequence seq => FM a -> seq a +elements = elementsUsingFold + +fromSeqWithKey :: + S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a +fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey + +insertWithKey :: (Int -> a -> a -> a) -> Int -> a -> FM a -> FM a +insertWithKey = insertWithKeyUsingInsertWith + +insertSeqWith :: + S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a -> FM a +insertSeqWith = insertSeqWithUsingInsertWith + +insertSeqWithKey :: + S.Sequence seq => + (Int -> a -> a -> a) -> seq (Int,a) -> FM a -> FM a +insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey + +adjustAll :: (a -> a) -> Int -> FM a -> FM a +adjustAll = adjust + +unionSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (FM a) -> FM a +unionSeqWith = unionSeqWithUsingReduce + +toSeq :: S.Sequence seq => FM a -> seq (Int,a) +toSeq = toSeqUsingFoldWithKey + +keys :: S.Sequence seq => FM a -> seq Int +keys = keysUsingFoldWithKey + +unionSeqWithKey :: + S.Sequence seq => (Int -> a -> a -> a) -> seq (FM a) -> FM a +unionSeqWithKey = unionSeqWithKeyUsingReduce + +-- instance declarations + +instance A.AssocX FM Int where + {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; union = union; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; + lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; + lookupAndDeleteAll = lookupAndDeleteAll; + lookupWithDefault = lookupWithDefault; adjust = adjust; + adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; + adjustAllOrInsert = adjustAllOrInsert; + adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; elements = elements; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance A.Assoc FM Int where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance A.FiniteMapX FM Int where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance A.FiniteMap FM Int where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance A.OrdAssocX FM Int where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance A.OrdAssoc FM Int where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance A.OrdFiniteMapX FM Int +instance A.OrdFiniteMap FM Int + +instance Functor FM where + fmap = map + +instance (Show a) => Show (FM a) where + showsPrec = showsPrecUsingToList + +instance (Read a) => Read (FM a) where + readsPrec = readsPrecUsingFromList + +instance (Eq a) => Eq (FM a) where + (==) = sameMap + +instance (Ord a) => Ord (FM a) where + compare = compareUsingToOrdList + +instance (Arbitrary a) => Arbitrary (FM a) where + arbitrary = do (xs::[(Int,a)]) <- arbitrary + return (Prelude.foldr (uncurry insert) empty xs) + +instance (CoArbitrary a) => CoArbitrary (FM a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (L i a) = variant (1 :: Int) . coarbitrary i . coarbitrary a + coarbitrary (B i j m n) = variant (2 :: Int) . coarbitrary i . coarbitrary j + . coarbitrary m . coarbitrary n + + +instance Semigroup (FM a) where + (<>) = union +instance Monoid (FM a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq
src/Data/Edison/Assoc/StandardMap.hs view
@@ -1,368 +1,362 @@--- |--- Module : Data.Edison.Assoc.AssocList--- Copyright : Copyright (c) 2006, 2008 Robert Dockins--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ The standard library "Data.Map" repackaged as an Edison--- associative collection.--module Data.Edison.Assoc.StandardMap (- -- * Type of standard finite maps- FM,-- -- * AssocX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,- lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,- lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,- adjustOrDelete,adjustOrDeleteAll,strict,strictWith,- map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,-- -- * FiniteMapX operations- fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,- insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,- difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,- properSubmap,submap,sameMap,-- -- * OrdAssocX operations- minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax,- unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1',- foldl1, foldl1', unsafeFromOrdSeq,- unsafeAppend, filterLT, filterLE, filterGT, filterGE,- partitionLT_GE, partitionLE_GT, partitionLT_GT,-- -- * Assoc operations- toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,-- -- * OrdAssoc operations- minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,- foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq,-- -- * FiniteMap operations- unionWithKey,unionSeqWithKey,intersectionWithKey,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)-import qualified Prelude-import qualified Data.Edison.Assoc as A-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Assoc.Defaults-import Data.Int-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..))--import qualified Data.Map as DM--type FM = DM.Map--moduleName :: String-moduleName = "Data.Edison.Assoc.StandardMap"--empty :: FM k a-singleton :: Ord k => k -> a -> FM k a-fromSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a-insert :: Ord k => k -> a -> FM k a -> FM k a-insertSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a-union :: Ord k => FM k a -> FM k a -> FM k a-unionSeq :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a-delete :: Ord k => k -> FM k a -> FM k a-deleteAll :: Ord k => k -> FM k a -> FM k a-deleteSeq :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a-null :: FM k a -> Bool-size :: FM k a -> Int-member :: Ord k => k -> FM k a -> Bool-count :: Ord k => k -> FM k a -> Int-lookup :: Ord k => k -> FM k a -> a-lookupAll :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a-lookupM :: (Ord k,Monad m) => k -> FM k a -> m a-lookupWithDefault :: Ord k => a -> k -> FM k a -> a-lookupAndDelete :: Ord k => k -> FM k a -> (a, FM k a)-lookupAndDeleteM :: (Ord k,Monad m) => k -> FM k a -> m (a, FM k a)-lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a)-adjust :: Ord k => (a->a) -> k -> FM k a -> FM k a-adjustAll :: Ord k => (a->a) -> k -> FM k a -> FM k a-adjustOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a-adjustOrDelete :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a-adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a-strict :: Ord k => FM k a -> FM k a-strictWith :: Ord k => (a -> b) -> FM k a -> FM k a-map :: (Ord k,Functor (FM k)) => (a -> b) -> FM k a -> FM k b-fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1 :: Ord k => (a -> a -> a) -> FM k a -> a-fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1' :: Ord k => (a -> a -> a) -> FM k a -> a-filter :: Ord k => (a -> Bool) -> FM k a -> FM k a-partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a)-elements :: (Ord k,S.Sequence seq) => FM k a -> seq a--minView :: (Ord k,Monad m) => FM k a -> m (a, FM k a)-minElem :: Ord k => FM k a -> a-deleteMin :: Ord k => FM k a -> FM k a-unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a-maxView :: (Ord k,Monad m) => FM k a -> m (a, FM k a)-maxElem :: Ord k => FM k a -> a-deleteMax :: Ord k => FM k a -> FM k a-unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a-foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a-foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a-foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b-foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a-foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a-unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a-unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a-filterLT :: Ord k => k -> FM k a -> FM k a-filterGT :: Ord k => k -> FM k a -> FM k a-filterLE :: Ord k => k -> FM k a -> FM k a-filterGE :: Ord k => k -> FM k a -> FM k a-partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a)-partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a)--fromSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a)- -> seq (k,a) -> FM k a-fromSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)- -> seq (k,a) -> FM k a-insertWith :: Ord k => (a -> a -> a) -> k -> a- -> FM k a -> FM k a-insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a- -> FM k a -> FM k a-insertSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a)- -> FM k a -> FM k a-insertSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a)- -> FM k a -> FM k a-unionl :: Ord k => FM k a -> FM k a -> FM k a-unionr :: Ord k => FM k a -> FM k a -> FM k a-unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWith :: (Ord k,S.Sequence seq) =>- (a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c-difference :: Ord k => FM k a -> FM k b -> FM k a-properSubset :: Ord k => FM k a -> FM k b -> Bool-subset :: Ord k => FM k a -> FM k b -> Bool-properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-properSubmap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool-submap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool-sameMap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool--toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)-keys :: (Ord k,S.Sequence seq) => FM k a -> seq k-mapWithKey :: Ord k => (k -> a -> b) -> FM k a -> FM k b-foldWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-foldWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b-filterWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a-partitionWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a)--minViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)-minElemWithKey :: Ord k => FM k a -> (k,a)-maxViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a)-maxElemWithKey :: Ord k => FM k a -> (k,a)-foldrWithKey :: (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey :: (b -> k -> a -> b) -> b -> FM k a -> b-foldrWithKey' :: (k -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey' :: (b -> k -> a -> b) -> b -> FM k a -> b-toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a)--unionWithKey :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a)- -> seq (FM k a) -> FM k a-intersectionWithKey :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c--structuralInvariant :: Ord k => FM k a -> Bool-structuralInvariant = DM.valid---empty = DM.empty-singleton = DM.singleton-fromSeq = fromSeqUsingInsertSeq-insert = DM.insert-insertSeq = insertSeqUsingFoldr-union = DM.union-unionSeq = DM.unions . S.toList-delete = DM.delete-deleteAll = DM.delete -- by finite map property-deleteSeq = deleteSeqUsingFoldr-null = DM.null-size = DM.size-member = DM.member-count = countUsingMember-lookup k m = maybe (error (moduleName ++ ".lookup: failed")) id (DM.lookup k m)-lookupM k m = maybe (fail (moduleName ++ ".lookupM: failed")) return (DM.lookup k m)-lookupAll = lookupAllUsingLookupM-lookupWithDefault = DM.findWithDefault-lookupAndDelete = lookupAndDeleteDefault-lookupAndDeleteM = lookupAndDeleteMDefault-lookupAndDeleteAll = lookupAndDeleteAllDefault-adjust = DM.adjust-adjustAll = DM.adjust-adjustOrInsert = adjustOrInsertUsingMember-adjustAllOrInsert = adjustOrInsertUsingMember-adjustOrDelete = DM.update-adjustOrDeleteAll = DM.update-strict xs = DM.fold (flip const) () xs `seq` xs-strictWith f xs = DM.fold (\x z -> f x `seq` z) () xs `seq` xs-map = fmap-fold = DM.fold-fold' f x xs = L.foldl' (flip f) x (DM.elems xs)-fold1 f xs = L.foldr1 f (DM.elems xs)-fold1' f xs = L.foldl1' (flip f) (DM.elems xs)-filter = DM.filter-partition = DM.partition-elements = elementsUsingFold--minView m = if DM.null m- then fail (moduleName ++ ".minView: failed")- else let ((_,x),m') = DM.deleteFindMin m- in return (x,m')-minElem = snd . DM.findMin-deleteMin = DM.deleteMin-unsafeInsertMin = DM.insert-maxView m = if DM.null m- then fail (moduleName ++ ".maxView: failed")- else let ((_,x),m') = DM.deleteFindMax m- in return (x,m')-maxElem = snd . DM.findMax-deleteMax = DM.deleteMax-unsafeInsertMax = DM.insert-foldr f x m = L.foldr f x (DM.elems m)-foldl f x m = L.foldl f x (DM.elems m)-foldr1 f m = L.foldr1 f (DM.elems m)-foldl1 f m = L.foldl1 f (DM.elems m)-foldr' f x m = L.foldr' f x (DM.elems m)-foldl' f x m = L.foldl' f x (DM.elems m)-foldr1' f m = L.foldr1' f (DM.elems m)-foldl1' f m = L.foldl1' f (DM.elems m)-unsafeFromOrdSeq = DM.fromAscList . S.toList-unsafeAppend = DM.union-filterLT k = fst . DM.split k-filterGT k = snd . DM.split k-filterLE k m = let (lt, mx, _ ) = DM.splitLookup k m in maybe lt (\x -> insert k x lt) mx-filterGE k m = let (_ , mx, gt) = DM.splitLookup k m in maybe gt (\x -> insert k x gt) mx-partitionLT_GE k m = let (lt, mx, gt) = DM.splitLookup k m in (lt, maybe gt (\x -> insert k x gt) mx)-partitionLE_GT k m = let (lt, mx, gt) = DM.splitLookup k m in (maybe lt (\x -> insert k x lt) mx, gt)-partitionLT_GT = DM.split-fromSeqWith f s = DM.fromListWith f (S.toList s)-fromSeqWithKey f s = DM.fromListWithKey f (S.toList s)-insertWith = DM.insertWith-insertWithKey = insertWithKeyUsingInsertWith-insertSeqWith = insertSeqWithUsingInsertWith-insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey-unionl = DM.union-unionr = flip DM.union-unionWith = DM.unionWith-unionSeqWith = unionSeqWithUsingReduce-intersectionWith = DM.intersectionWith-difference = DM.difference-properSubset = DM.isProperSubmapOfBy (\_ _ -> True)-subset = DM.isSubmapOfBy (\_ _ -> True)-properSubmapBy = DM.isProperSubmapOfBy-submapBy = DM.isSubmapOfBy-sameMapBy = sameMapByUsingOrdLists-properSubmap = A.properSubmap-submap = A.submap-sameMap = A.sameMap--toSeq = toSeqUsingFoldWithKey-keys = keysUsingFoldWithKey-mapWithKey = DM.mapWithKey-foldWithKey = DM.foldWithKey-foldWithKey' f x m = L.foldl' (\b (k,a) -> f k a b) x (DM.toList m)-filterWithKey = DM.filterWithKey-partitionWithKey = DM.partitionWithKey--minViewWithKey m = if DM.null m- then fail (moduleName ++ ".minViewWithKey: failed")- else return (DM.deleteFindMin m)-minElemWithKey = DM.findMin-maxViewWithKey m = if DM.null m- then fail (moduleName ++ ".maxViewWithKey: failed")- else return (DM.deleteFindMax m)-maxElemWithKey = DM.findMax-foldrWithKey = DM.foldWithKey-foldrWithKey' f x m = L.foldr' (\(k,a) b -> f k a b) x (DM.toAscList m)-foldlWithKey f x m = L.foldl (\b (k,a) -> f b k a) x (DM.toAscList m)-foldlWithKey' f x m = L.foldl' (\b (k,a) -> f b k a) x (DM.toAscList m)-toOrdSeq = S.fromList . DM.toAscList--unionWithKey = DM.unionWithKey-unionSeqWithKey = unionSeqWithKeyUsingReduce-intersectionWithKey = DM.intersectionWithKey---instance Ord k => A.AssocX (FM k) k where- {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; union = union; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;- lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;- lookupAndDeleteAll = lookupAndDeleteAll;- lookupWithDefault = lookupWithDefault; adjust = adjust;- adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;- adjustAllOrInsert = adjustAllOrInsert;- adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; elements = elements;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord k => A.OrdAssocX (FM k) k where- {minView = minView; minElem = minElem; deleteMin = deleteMin;- unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;- deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterGT = filterGT; filterLE = filterLE;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord k => A.FiniteMapX (FM k) k where- {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;- insertWith = insertWith; insertWithKey = insertWithKey;- insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;- unionl = unionl; unionr = unionr; unionWith = unionWith;- unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;- difference = difference; properSubset = properSubset; subset = subset;- properSubmapBy = properSubmapBy; submapBy = submapBy;- sameMapBy = sameMapBy}--instance Ord k => A.OrdFiniteMapX (FM k) k--instance Ord k => A.Assoc (FM k) k where- {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;- foldWithKey = foldWithKey; foldWithKey' = foldWithKey';- filterWithKey = filterWithKey;- partitionWithKey = partitionWithKey}--instance Ord k => A.OrdAssoc (FM k) k where- {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;- maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;- foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';- foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';- toOrdSeq = toOrdSeq}--instance Ord k => A.FiniteMap (FM k) k where- {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;- intersectionWithKey = intersectionWithKey}--instance Ord k => A.OrdFiniteMap (FM k) k--instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where- arbitrary = do xs <- arbitrary- return (Prelude.foldr (uncurry insert) empty xs)--instance (Ord k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where- coarbitrary mp = coarbitrary (A.toList mp)+-- | +-- Module : Data.Edison.Assoc.AssocList +-- Copyright : Copyright (c) 2006, 2008 Robert Dockins +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- The standard library "Data.Map" repackaged as an Edison +-- associative collection. + +module Data.Edison.Assoc.StandardMap ( + -- * Type of standard finite maps + FM, + + -- * AssocX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, + lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, + lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, + adjustOrDelete,adjustOrDeleteAll,strict,strictWith, + map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, + + -- * FiniteMapX operations + fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, + insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, + difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, + properSubmap,submap,sameMap, + + -- * OrdAssocX operations + minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, + unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1', + foldl1, foldl1', unsafeFromOrdSeq, + unsafeAppend, filterLT, filterLE, filterGT, filterGE, + partitionLT_GE, partitionLE_GT, partitionLT_GT, + + -- * Assoc operations + toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, + + -- * OrdAssoc operations + minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, + foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, + + -- * FiniteMap operations + unionWithKey,unionSeqWithKey,intersectionWithKey, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter) +import qualified Prelude +import qualified Control.Monad.Fail as Fail +import qualified Data.Edison.Assoc as A +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Assoc.Defaults +import Data.Int +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..)) + +import qualified Data.Map as DM + +type FM = DM.Map + +moduleName :: String +moduleName = "Data.Edison.Assoc.StandardMap" + +empty :: FM k a +singleton :: Ord k => k -> a -> FM k a +fromSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a +insert :: Ord k => k -> a -> FM k a -> FM k a +insertSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a +union :: Ord k => FM k a -> FM k a -> FM k a +unionSeq :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a +delete :: Ord k => k -> FM k a -> FM k a +deleteAll :: Ord k => k -> FM k a -> FM k a +deleteSeq :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a +null :: FM k a -> Bool +size :: FM k a -> Int +member :: Ord k => k -> FM k a -> Bool +count :: Ord k => k -> FM k a -> Int +lookup :: Ord k => k -> FM k a -> a +lookupAll :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a +lookupM :: (Ord k, Fail.MonadFail m) => k -> FM k a -> m a +lookupWithDefault :: Ord k => a -> k -> FM k a -> a +lookupAndDelete :: Ord k => k -> FM k a -> (a, FM k a) +lookupAndDeleteM :: (Ord k, Fail.MonadFail m) => k -> FM k a -> m (a, FM k a) +lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a) +adjust :: Ord k => (a->a) -> k -> FM k a -> FM k a +adjustAll :: Ord k => (a->a) -> k -> FM k a -> FM k a +adjustOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a +adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a +adjustOrDelete :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a +adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a +strict :: Ord k => FM k a -> FM k a +strictWith :: Ord k => (a -> b) -> FM k a -> FM k a +map :: Ord k => (a -> b) -> FM k a -> FM k b +fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b +fold1 :: Ord k => (a -> a -> a) -> FM k a -> a +fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +fold1' :: Ord k => (a -> a -> a) -> FM k a -> a +filter :: Ord k => (a -> Bool) -> FM k a -> FM k a +partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a) +elements :: (Ord k,S.Sequence seq) => FM k a -> seq a + +minView :: (Ord k, Fail.MonadFail m) => FM k a -> m (a, FM k a) +minElem :: Ord k => FM k a -> a +deleteMin :: Ord k => FM k a -> FM k a +unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a +maxView :: (Ord k, Fail.MonadFail m) => FM k a -> m (a, FM k a) +maxElem :: Ord k => FM k a -> a +deleteMax :: Ord k => FM k a -> FM k a +unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a +foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b +foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b +foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a +foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a +unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a +unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a +filterLT :: Ord k => k -> FM k a -> FM k a +filterGT :: Ord k => k -> FM k a -> FM k a +filterLE :: Ord k => k -> FM k a -> FM k a +filterGE :: Ord k => k -> FM k a -> FM k a +partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a) +partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) +partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) + +fromSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) + -> seq (k,a) -> FM k a +fromSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) + -> seq (k,a) -> FM k a +insertWith :: Ord k => (a -> a -> a) -> k -> a + -> FM k a -> FM k a +insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a + -> FM k a -> FM k a +insertSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) + -> FM k a -> FM k a +insertSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) + -> FM k a -> FM k a +unionl :: Ord k => FM k a -> FM k a -> FM k a +unionr :: Ord k => FM k a -> FM k a -> FM k a +unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWith :: (Ord k,S.Sequence seq) => + (a -> a -> a) -> seq (FM k a) -> FM k a +intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c +difference :: Ord k => FM k a -> FM k b -> FM k a +properSubset :: Ord k => FM k a -> FM k b -> Bool +subset :: Ord k => FM k a -> FM k b -> Bool +properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +properSubmap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool +submap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool +sameMap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool + +toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) +keys :: (Ord k,S.Sequence seq) => FM k a -> seq k +mapWithKey :: Ord k => (k -> a -> b) -> FM k a -> FM k b +foldWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b +foldWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b +filterWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a +partitionWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a) + +minViewWithKey :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a) +minElemWithKey :: Ord k => FM k a -> (k,a) +maxViewWithKey :: (Ord k, Fail.MonadFail m) => FM k a -> m ((k, a), FM k a) +maxElemWithKey :: Ord k => FM k a -> (k,a) +foldrWithKey :: (k -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey :: (b -> k -> a -> b) -> b -> FM k a -> b +foldrWithKey' :: (k -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey' :: (b -> k -> a -> b) -> b -> FM k a -> b +toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) + +unionWithKey :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) + -> seq (FM k a) -> FM k a +intersectionWithKey :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c + +structuralInvariant :: Ord k => FM k a -> Bool +structuralInvariant = DM.valid + + +empty = DM.empty +singleton = DM.singleton +fromSeq = fromSeqUsingInsertSeq +insert = DM.insert +insertSeq = insertSeqUsingFoldr +union = DM.union +unionSeq = DM.unions . S.toList +delete = DM.delete +deleteAll = DM.delete -- by finite map property +deleteSeq = deleteSeqUsingFoldr +null = DM.null +size = DM.size +member = DM.member +count = countUsingMember +lookup k m = maybe (error (moduleName ++ ".lookup: failed")) id (DM.lookup k m) +lookupM k m = maybe (fail (moduleName ++ ".lookupM: failed")) return (DM.lookup k m) +lookupAll = lookupAllUsingLookupM +lookupWithDefault = DM.findWithDefault +lookupAndDelete = lookupAndDeleteDefault +lookupAndDeleteM = lookupAndDeleteMDefault +lookupAndDeleteAll = lookupAndDeleteAllDefault +adjust = DM.adjust +adjustAll = DM.adjust +adjustOrInsert = adjustOrInsertUsingMember +adjustAllOrInsert = adjustOrInsertUsingMember +adjustOrDelete = DM.update +adjustOrDeleteAll = DM.update +strict xs = DM.foldr (flip const) () xs `seq` xs +strictWith f xs = DM.foldr (\x z -> f x `seq` z) () xs `seq` xs +map = fmap +fold = DM.foldr +fold' f x xs = L.foldl' (flip f) x (DM.elems xs) +fold1 f xs = L.foldr1 f (DM.elems xs) +fold1' f xs = L.foldl1' (flip f) (DM.elems xs) +filter = DM.filter +partition = DM.partition +elements = elementsUsingFold + +minView m = if DM.null m + then fail (moduleName ++ ".minView: failed") + else let ((_,x),m') = DM.deleteFindMin m + in return (x,m') +minElem = snd . DM.findMin +deleteMin = DM.deleteMin +unsafeInsertMin = DM.insert +maxView m = if DM.null m + then fail (moduleName ++ ".maxView: failed") + else let ((_,x),m') = DM.deleteFindMax m + in return (x,m') +maxElem = snd . DM.findMax +deleteMax = DM.deleteMax +unsafeInsertMax = DM.insert +foldr f x m = L.foldr f x (DM.elems m) +foldl f x m = L.foldl f x (DM.elems m) +foldr1 f m = L.foldr1 f (DM.elems m) +foldl1 f m = L.foldl1 f (DM.elems m) +foldr' f x m = L.foldr' f x (DM.elems m) +foldl' f x m = L.foldl' f x (DM.elems m) +foldr1' f m = L.foldr1' f (DM.elems m) +foldl1' f m = L.foldl1' f (DM.elems m) +unsafeFromOrdSeq = DM.fromAscList . S.toList +unsafeAppend = DM.union +filterLT k = fst . DM.split k +filterGT k = snd . DM.split k +filterLE k m = let (lt, mx, _ ) = DM.splitLookup k m in maybe lt (\x -> insert k x lt) mx +filterGE k m = let (_ , mx, gt) = DM.splitLookup k m in maybe gt (\x -> insert k x gt) mx +partitionLT_GE k m = let (lt, mx, gt) = DM.splitLookup k m in (lt, maybe gt (\x -> insert k x gt) mx) +partitionLE_GT k m = let (lt, mx, gt) = DM.splitLookup k m in (maybe lt (\x -> insert k x lt) mx, gt) +partitionLT_GT = DM.split +fromSeqWith f s = DM.fromListWith f (S.toList s) +fromSeqWithKey f s = DM.fromListWithKey f (S.toList s) +insertWith = DM.insertWith +insertWithKey = insertWithKeyUsingInsertWith +insertSeqWith = insertSeqWithUsingInsertWith +insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey +unionl = DM.union +unionr = flip DM.union +unionWith = DM.unionWith +unionSeqWith = unionSeqWithUsingReduce +intersectionWith = DM.intersectionWith +difference = DM.difference +properSubset = DM.isProperSubmapOfBy (\_ _ -> True) +subset = DM.isSubmapOfBy (\_ _ -> True) +properSubmapBy = DM.isProperSubmapOfBy +submapBy = DM.isSubmapOfBy +sameMapBy = sameMapByUsingOrdLists +properSubmap = A.properSubmap +submap = A.submap +sameMap = A.sameMap + +toSeq = toSeqUsingFoldWithKey +keys = keysUsingFoldWithKey +mapWithKey = DM.mapWithKey +foldWithKey = DM.foldrWithKey +foldWithKey' f x m = L.foldl' (\b (k,a) -> f k a b) x (DM.toList m) +filterWithKey = DM.filterWithKey +partitionWithKey = DM.partitionWithKey + +minViewWithKey m = if DM.null m + then fail (moduleName ++ ".minViewWithKey: failed") + else return (DM.deleteFindMin m) +minElemWithKey = DM.findMin +maxViewWithKey m = if DM.null m + then fail (moduleName ++ ".maxViewWithKey: failed") + else return (DM.deleteFindMax m) +maxElemWithKey = DM.findMax +foldrWithKey = DM.foldrWithKey +foldrWithKey' f x m = L.foldr' (\(k,a) b -> f k a b) x (DM.toAscList m) +foldlWithKey f x m = L.foldl (\b (k,a) -> f b k a) x (DM.toAscList m) +foldlWithKey' f x m = L.foldl' (\b (k,a) -> f b k a) x (DM.toAscList m) +toOrdSeq = S.fromList . DM.toAscList + +unionWithKey = DM.unionWithKey +unionSeqWithKey = unionSeqWithKeyUsingReduce +intersectionWithKey = DM.intersectionWithKey + + +instance Ord k => A.AssocX (FM k) k where + {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; union = union; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; + lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; + lookupAndDeleteAll = lookupAndDeleteAll; + lookupWithDefault = lookupWithDefault; adjust = adjust; + adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; + adjustAllOrInsert = adjustAllOrInsert; + adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; elements = elements; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord k => A.OrdAssocX (FM k) k where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord k => A.FiniteMapX (FM k) k where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance Ord k => A.OrdFiniteMapX (FM k) k + +instance Ord k => A.Assoc (FM k) k where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance Ord k => A.OrdAssoc (FM k) k where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance Ord k => A.FiniteMap (FM k) k where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance Ord k => A.OrdFiniteMap (FM k) k
src/Data/Edison/Assoc/TernaryTrie.hs view
@@ -1,1165 +1,1300 @@--- |--- Module : Data.Edison.Assoc.TernaryTrie--- Copyright : Copyright (c) 2002, 2008 Andrew Bromage--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Finite maps implemented as ternary search tries--module Data.Edison.Assoc.TernaryTrie (- -- * Type of ternary search tries- FM,-- -- * AssocX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,lookup,lookupM,lookupAll,- lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,- lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,- adjustOrDelete,adjustOrDeleteAll,strict,strictWith,- map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant,-- -- * Assoc operations- toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey,-- -- * FiniteMapX operations- fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith,- insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith,- difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy,- properSubmap,submap,sameMap,-- -- * FiniteMap operations- unionWithKey,unionSeqWithKey,intersectionWithKey,-- -- * OrdAssocX operations- minView, minElem, deleteMin, unsafeInsertMin,- maxView, maxElem, deleteMax, unsafeInsertMax,- foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1',- unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE,- partitionLT_GE, partitionLE_GT, partitionLT_GT,-- -- * OrdAssoc operations- minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey,- foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey',- toOrdSeq,-- -- * Other supported operations- mergeVFM, mergeKVFM,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter)-import qualified Prelude-import qualified Data.Edison.Assoc as A-import qualified Data.Edison.Seq as S-import qualified Data.List as L-import Control.Monad.Identity-import Data.Monoid-import Data.Maybe (isNothing)--import Data.Edison.Assoc.Defaults-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), variant)----- signatures for exported functions-moduleName :: String-empty :: Ord k => FM k a-singleton :: Ord k => [k] -> a -> FM k a-fromSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a-insert :: Ord k => [k] -> a -> FM k a -> FM k a-insertSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a -> FM k a-union :: Ord k => FM k a -> FM k a -> FM k a-unionSeq :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a-delete :: Ord k => [k] -> FM k a -> FM k a-deleteAll :: Ord k => [k] -> FM k a -> FM k a-deleteSeq :: (Ord k,S.Sequence seq) => seq [k] -> FM k a -> FM k a-null :: Ord k => FM k a -> Bool-size :: Ord k => FM k a -> Int-member :: Ord k => [k] -> FM k a -> Bool-count :: Ord k => [k] -> FM k a -> Int-lookup :: Ord k => [k] -> FM k a -> a-lookupM :: (Ord k, Monad rm) => [k] -> FM k a -> rm a-lookupAll :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a-lookupAndDelete :: Ord k => [k] -> FM k a -> (a, FM k a)-lookupAndDeleteM :: (Ord k, Monad rm) => [k] -> FM k a -> rm (a, FM k a)-lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a)-lookupWithDefault :: Ord k => a -> [k] -> FM k a -> a-adjust :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a-adjustAll :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a-adjustOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a-adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a-adjustOrDelete :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a-adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a-strict :: FM k a -> FM k a-strictWith :: (a -> b) -> FM k a -> FM k a-map :: Ord k => (a -> b) -> FM k a -> FM k b-fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1 :: Ord k => (a -> a -> a) -> FM k a -> a-fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b-fold1' :: Ord k => (a -> a -> a) -> FM k a -> a-filter :: Ord k => (a -> Bool) -> FM k a -> FM k a-partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a)-elements :: (Ord k,S.Sequence seq) => FM k a -> seq a--fromSeqWith :: (Ord k,S.Sequence seq) =>- (a -> a -> a) -> seq ([k],a) -> FM k a-fromSeqWithKey :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a-insertWith :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a-insertWithKey :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a-insertSeqWith :: (Ord k,S.Sequence seq) =>- (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a-insertSeqWithKey :: (Ord k,S.Sequence seq) =>- ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a-unionl :: Ord k => FM k a -> FM k a -> FM k a-unionr :: Ord k => FM k a -> FM k a -> FM k a-unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWith :: (Ord k,S.Sequence seq) =>- (a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c-difference :: Ord k => FM k a -> FM k b -> FM k a-properSubset :: Ord k => FM k a -> FM k b -> Bool-subset :: Ord k => FM k a -> FM k b -> Bool-properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool-properSubmap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool-submap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool-sameMap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool--toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)-keys :: (Ord k,S.Sequence seq) => FM k a -> seq [k]-mapWithKey :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b-foldWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-foldWithKey' :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-filterWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a-partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a)-unionWithKey :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a-unionSeqWithKey :: (Ord k,S.Sequence seq) =>- ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a-intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c--foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a-foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b-foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a--foldrWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-foldrWithKey' :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b-foldlWithKey :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b-foldlWithKey' :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b-toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a)--moduleName = "Data.Edison.Assoc.TernaryTrie"---data FM k a- = FM !(Maybe a) !(FMB k a)--data FMB k v- = E- | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v)--newtype FMB' k v- = FMB' (FMB k v)--balance :: Int-balance = 6--sizeFMB :: FMB k v -> Int-sizeFMB E = 0-sizeFMB (I size _ _ _ _ _) = size--mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v-mkFMB k v l m r- = I (1 + sizeFMB l + sizeFMB r) k v l m r--lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v-lookupFMB [] _- = Nothing-lookupFMB (_:_) E- = Nothing-lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r)- = case compare x k of- LT -> lookupFMB nk l- GT -> lookupFMB nk r- EQ -> if L.null xs then v else lookupFMB xs fmbm--listToFMB :: [k] -> (Maybe v -> Maybe v) -> FMB k v-listToFMB [x] fv = mkFMB x (fv Nothing) E (FMB' E) E-listToFMB (x:xs) fv = mkFMB x Nothing E (FMB' $ listToFMB xs fv) E-listToFMB _ _ = error "TernaryTrie.listToFMB: bug!"--addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v-addToFMB xs combiner E- = listToFMB xs combiner-addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r)- = case compare x k of- LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r- GT -> mkBalancedFMB k v l m (addToFMB nk combiner r)- EQ -> case xs of- [] -> I size k (combiner v) l m r- _ -> I size k v l (FMB' $ addToFMB xs combiner fmbm) r-addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!"--addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v-addToFM [] combiner (FM n fmb)- = FM (combiner n) fmb-addToFM xs combiner (FM n fmb)- = FM n (addToFMB xs combiner fmb)--lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z-lookupAndDelFromFMB onFail _ _ E = onFail-lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r)- = case compare x k of- LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l- GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r- EQ -> case xs of- [] -> case v of- Nothing -> onFail- Just w -> case fmbm of- E -> cont w (appendFMB l r)- _ -> cont w (I size k Nothing l m r)- _ -> lookupAndDelFromFMB onFail (\w m' -> cont w (I size k v l (FMB' m') r)) xs fmbm-lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!"--lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z-lookupAndDelFromFM onFail _ [] (FM Nothing _) = onFail-lookupAndDelFromFM _ cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb)-lookupAndDelFromFM onFail cont xs (FM n fmb) =- lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb---delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v-delFromFMB _ E- = E-delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r)- = case compare x k of- LT -> mkBalancedFMB k v (delFromFMB nk l) m r- GT -> mkBalancedFMB k v l m (delFromFMB nk r)- EQ -> case xs of- [] -> case fmbm of- E -> appendFMB l r- _ -> I size k Nothing l m r- _ -> I size k v l (FMB' $ delFromFMB xs fmbm) r-delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!"---delFromFM :: (Ord k) => [k] -> FM k v -> FM k v-delFromFM [] (FM _ fmb)- = FM Nothing fmb-delFromFM xs (FM n fmb)- = FM n (delFromFMB xs fmb)---mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v-mkBalancedFMB k v l m r- | size_l + size_r < 2- = mkFMB k v l m r- | size_r > balance * size_l -- Right tree too big- = case r of- I _ _ _ rl _ rr- | sizeFMB rl < 2 * sizeFMB rr- -> single_L l m r- | otherwise- -> double_L l m r- _ -> error "TernaryTrie.mkBalancedFMB: bug!"-- | size_l > balance * size_r -- Left tree too big- = case l of- I _ _ _ ll _ lr- | sizeFMB lr < 2 * sizeFMB ll- -> single_R l m r- | otherwise- -> double_R l m r- _ -> error "TernaryTrie.mkBalancedFMB: bug!"-- | otherwise -- No imbalance- = mkFMB k v l m r- where- size_l = sizeFMB l- size_r = sizeFMB r-- single_L l m (I _ k_r v_r rl rm rr)- = mkFMB k_r v_r (mkFMB k v l m rl) rm rr- single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"-- double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr)- = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr)- double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"-- single_R (I _ k_l v_l ll lm lr) m r- = mkFMB k_l v_l ll lm (mkFMB k v lr m r)- single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"-- double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r- = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r)- double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!"---mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v-mkVBalancedFMB k v E m E- = mkFMB k v E m E-mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr)- = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr-mkVBalancedFMB k v (I _ kl vl ll lm lr) m r@E- = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)-mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr)- | balance * size_l < size_r- = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr- | balance * size_r < size_l- = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r)- | otherwise- = mkFMB k v l m r- where- size_l = sizeFMB l- size_r = sizeFMB r-- -- Constraint: All keys in the first FMB are less than- -- that in the second FMB.-appendFMB :: FMB k v -> FMB k v -> FMB k v-appendFMB E m2 = m2-appendFMB m1 E = m1-appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2)- | size1 > size2- = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2)- | otherwise- = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2--mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b-mapVFM f (FM n fmb)- = FM (f n) (mapVFMB f fmb)--mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b-mapVFMB f m- = mapVFMB' m- where- mapVFMB' E = E- mapVFMB' (I _ k v l (FMB' m) r)- = case (mapVFMB' m, f v) of- (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r)- (m',v') -> mkVBalancedFMB k v'- (mapVFMB' l) (FMB' m') (mapVFMB' r)--mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b-mapKVFM f (FM n fmb)- = FM (f [] n) (mapKVFMB [] fmb)- where- mapKVFMB _ E = E- mapKVFMB ks (I _ k v l (FMB' m) r)- = mkVBalancedFMB k (f (reverse (k:ks)) v)- (mapKVFMB ks l)- (FMB' (mapKVFMB (k:ks) m))- (mapKVFMB ks r)--nullFMB :: FMB k v -> Bool-nullFMB E = True-nullFMB (I _ _ v l (FMB' m) r)- = case v of- Just _ -> False- Nothing -> nullFMB l && nullFMB m && nullFMB r--nullFM :: FM k v -> Bool-nullFM (FM (Just _) _) = False-nullFM (FM Nothing fmb) = nullFMB fmb--data FMBCtx k v- = T- | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v)- | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v)--splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a)-splayFMB key fmb- = splaydown T fmb- where- splaydown ctx E- = splayup ctx Nothing E (FMB' E) E- splaydown ctx (I _ k v l m r)- = case compare key k of- LT -> splaydown (L k v ctx m r) l- GT -> splaydown (R k v l m ctx) r- EQ -> splayup ctx v l m r-- splayup ctx v l m r- = splayup' ctx l r- where- splayup' T l r- = (v, l, m, r)- splayup' (L ck cv ctx cm cr) tl tr- = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr)- splayup' (R ck cv cl cm ctx) tl tr- = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr--mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->- FMB k a -> FMB k b -> FMB k c-mergeVFMB f fmbx fmby- = mergeVFMB' fmbx fmby- where- mergeVFMB' E E- = E- mergeVFMB' E fmby@(I _ _ _ _ (FMB' _) _)- = mapVFMB (\v -> f Nothing v) fmby- mergeVFMB' fmbx@(I _ _ _ _ (FMB' _) _) E- = mapVFMB (\v -> f v Nothing) fmbx- mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx)- fmby@(I sizey ky vy ly (FMB' my) ry)- | sizex >= sizey- = let (vy, ly, FMB' my, ry) = splayFMB kx fmby- in case (mergeVFMB' mx my, f vx vy) of- (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)- (m',v) -> mkVBalancedFMB kx v- (mergeVFMB' lx ly)- (FMB' m')- (mergeVFMB' rx ry)- | otherwise- = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx- in case (mergeVFMB' mx my, f vx vy) of- (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry)- (m',v) -> mkVBalancedFMB ky v- (mergeVFMB' lx ly)- (FMB' m')- (mergeVFMB' rx ry)--mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) ->- FM k a -> FM k b -> FM k c-mergeVFM f (FM vx fmbx) (FM vy fmby)- = FM (f vx vy) (mergeVFMB f fmbx fmby)---mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->- FMB k a -> FMB k b -> FMB k c-mergeKVFMB f fmbx fmby- = mergeKVFMB' [] fmbx fmby- where- mergeKVFMB' _ E E- = E- mergeKVFMB' ks E fmby- = mergeKVFMBs (\k v -> f k Nothing v) ks fmby- mergeKVFMB' ks fmbx E- = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx- mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx)- fmby@(I sizey ky vy ly (FMB' my) ry)- | sizex >= sizey- = let (vy, ly, FMB' my, ry) = splayFMB kx fmby- ks' = reverse (kx:ks)- in case (mergeKVFMB' ks' mx my, f ks' vx vy) of- (E,Nothing) -> appendFMB- (mergeKVFMB' ks lx ly)- (mergeKVFMB' ks rx ry)- (m',v) -> mkVBalancedFMB kx v- (mergeKVFMB' ks lx ly)- (FMB' m')- (mergeKVFMB' ks rx ry)- | otherwise- = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx- ks' = reverse (ky:ks)- in case (mergeKVFMB' ks' mx my, f ks' vx vy) of- (E,Nothing) -> appendFMB- (mergeKVFMB' ks lx ly)- (mergeKVFMB' ks rx ry)- (m',v) -> mkVBalancedFMB ky v- (mergeKVFMB' ks lx ly)- (FMB' m')- (mergeKVFMB' ks rx ry)-- mergeKVFMBs f ks fmb- = mergeKVFMBs' ks fmb- where- mergeKVFMBs' _ E- = E- mergeKVFMBs' ks (I _ k v l (FMB' m) r)- = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of- (E, Nothing) -> appendFMB- (mergeKVFMBs' ks l)- (mergeKVFMBs' ks r)- (m,v) -> mkVBalancedFMB k v- (mergeKVFMBs' ks l)- (FMB' m)- (mergeKVFMBs' ks r)--mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) ->- FM k a -> FM k b -> FM k c-mergeKVFM f (FM vx fmbx) (FM vy fmby)- = FM (f [] vx vy) (mergeKVFMB f fmbx fmby)----- The public interface.------- AssocX--empty = FM Nothing E--singleton [] v = FM (Just v) E-singleton xs v = FM Nothing (listToFMB xs (\_ -> Just v))--fromSeq = fromSeqUsingInsertSeq--insert k v fm = addToFM k (\_ -> Just v) fm--insertSeq = insertSeqUsingFoldr--union = mergeVFM mplus--unionSeq = unionSeqUsingReduce--delete k fm = delFromFM k fm--deleteAll = delete--deleteSeq = deleteSeqUsingFoldr--null = nullFM--size (FM k fmb)- | isNothing k = fmb_size fmb 0- | otherwise = fmb_size fmb 1- where fmb_size E k = k- fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k- fmb_size (I _ _ _ l (FMB' m) r ) k = fmb_size l $ fmb_size m $ fmb_size r $! k+1---member = memberUsingLookupM--count = countUsingMember--lookup m k = runIdentity (lookupM m k)--lookupM [] (FM Nothing _)- = fail "TernaryTrie.lookup: lookup failed"-lookupM [] (FM (Just v) _)- = return v-lookupM xs (FM _ fmb)- = case lookupFMB xs fmb of- Nothing -> fail "TernaryTrie.lookup: lookup failed"- Just v -> return v--lookupAll = lookupAllUsingLookupM--lookupAndDelete =- lookupAndDelFromFM- (error "TernaryTrie.lookupAndDelete: lookup failed")- (,)--lookupAndDeleteM =- lookupAndDelFromFM- (fail "TernaryTrie.lookupAndDeleteM: lookup failed")- (\w m -> return (w,m))--lookupAndDeleteAll k m =- lookupAndDelFromFM- (S.empty,m)- (\w m' -> (S.singleton w,m'))- k m--lookupWithDefault = lookupWithDefaultUsingLookupM--adjust f k- = addToFM k (\mv -> case mv of- Nothing -> mv- Just v -> Just (f v))--adjustAll = adjust--adjustOrInsert f z k- = addToFM k (\mv -> case mv of- Nothing -> Just z- Just v -> Just (f v))--adjustAllOrInsert = adjustOrInsert--adjustOrDelete f k- = addToFM k (\mv -> case mv of- Nothing -> mv- Just v -> f v)--adjustOrDeleteAll = adjustOrDelete--map f- = mapVFM (\mv -> case mv of- Nothing -> Nothing- Just v -> Just (f v))--fold = foldr-fold' = foldr'--foldr op z (FM n fmb)- = foldMV n . foldFMB fmb $ z- where- foldMV Nothing = id- foldMV (Just v) = op v-- foldFMB E- = id- foldFMB (I _ _ v l (FMB' m) r)- = foldFMB l . foldMV v . foldFMB m . foldFMB r--foldrWithKey f z (FM n fmb)- = foldMV [] n . foldFMB id fmb $ z- where- foldMV _ Nothing = id- foldMV ks (Just v) = f ks v-- foldFMB _ E = id- foldFMB kf (I _ k mv l (FMB' m) r)- = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r--foldlWithKey f z (FM n fmb)- = foldFMB id fmb . foldMV [] n $ z- where- g k x a = f a k x-- foldMV _ Nothing = id- foldMV ks (Just v) = g ks v-- foldFMB _ E = id- foldFMB kf (I _ k mv l (FMB' m) r)- = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l--foldrWithKey' = foldrWithKey-foldlWithKey' = foldlWithKey--foldl :: (a -> b -> a) -> a -> FM t b -> a-foldl op z (FM n fmb)- = foldFMB fmb . foldMV n $ z- where- foldMV Nothing = id- foldMV (Just v) = (flip op) v-- foldFMB E = id- foldFMB (I _ _ v l (FMB' m) r)- = foldFMB r . foldFMB m . foldMV v . foldFMB l----- FIXME, undestand this code to strictify it-foldr' = foldr-foldl' :: (a -> b -> a) -> a -> FM t b -> a-foldl' = foldl--foldr1 f fm =- case maxView fm of- Just (z,fm') -> foldr f z fm'- Nothing -> error $ moduleName++".foldr1: empty map"--foldl1 :: (b -> b -> b) -> FM k b -> b-foldl1 f fm =- case minView fm of- Just (z,fm') -> foldl f z fm'- Nothing -> error $ moduleName++".foldl1: empty map"---basecase :: Maybe t1 -> (t1 -> t) -> t -> t-basecase Nothing = \_ n -> n-basecase (Just x) = \j _ -> j x--comb :: (t1 -> t1 -> t1)- -> ((t1 -> t2) -> t2 -> t3)- -> ((t1 -> t) -> t -> t2)- -> (t1 -> t)- -> t- -> t3-comb f p1 p2- = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n)--fold1 f (FM mv fmb)- = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map")- where- fold1FMB E- = \_ n -> n- fold1FMB (I _ _ mv l (FMB' m) r)- = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r)--fold1' = fold1--{--FIXME -- can these be somehow fixed to have the right order...--foldr1 f (FM v fmb)- = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map")- where- fold1FMB E- = \j n -> n- fold1FMB (I _ _ v l (FMB' m) r)- = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r)---foldl1 f (FM v fmb)- = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map")- where- fold1FMB E- = \j n -> n- fold1FMB (I _ _ v l (FMB' m) r)- = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l)--}------ FIXME, undestand this code to strictify it-foldr1' = foldr1-foldl1' :: (b -> b -> b) -> FM k b -> b-foldl1' = foldl1---filter p = mapVFM (\mv -> case mv of- Nothing -> mv- Just v -> if p v then mv else Nothing)--partition = partitionUsingFilter--elements = elementsUsingFold--strict z@(FM _ fmb) = strictFMB fmb `seq` z- where strictFMB n@E = n- strictFMB n@(I _ _ _ l (FMB' m) r) =- strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n--strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z- where f' v@Nothing = v- f' v@(Just x) = f x `seq` v-- strictWithFMB n@E = n- strictWithFMB n@(I _ _ v l (FMB' m) r) =- f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n----- FiniteMapX--fromSeqWith = fromSeqWithUsingInsertSeqWith--fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey--insertWith f k v- = addToFM k (\vem ->- case vem of- Nothing -> Just v- Just ve -> Just (f ve v))--insertWithKey = insertWithKeyUsingInsertWith--insertSeqWith = insertSeqWithUsingInsertWith--insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey--unionl = union-unionr = flip union--unionWith f = unionWithKey (const f)--unionSeqWith = unionSeqWithUsingReduce--intersectionWith f = intersectionWithKey (const f)--difference mx my- = mergeVFM (\v1 v2 -> case v2 of- Nothing -> v1- Just _ -> Nothing) mx my--properSubset = properSubsetUsingSubset--subset (FM nx fmbx) (FM ny fmby)- = subsetEqM nx ny && subsetEqFMB fmbx fmby- where- subsetEqM Nothing _ = True- subsetEqM (Just _) Nothing = False- subsetEqM (Just _) (Just _) = True-- subsetEqFMB E _ = True- subsetEqFMB fmbx@(I _ _ _ _ _ _) E- = nullFMB fmbx- subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx)- fmby@(I sizey ky vy ly (FMB' my) ry)- | sizex >= sizey- = let (vy, ly, FMB' my, ry) = splayFMB kx fmby- in subsetEqM vx vy- && subsetEqFMB lx ly- && subsetEqFMB mx my- && subsetEqFMB rx ry- | otherwise- = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx- in subsetEqM vx vy- && subsetEqFMB lx ly- && subsetEqFMB mx my- && subsetEqFMB rx ry---submapBy = submapByUsingLookupM-properSubmapBy = properSubmapByUsingSubmapBy-sameMapBy = sameMapByUsingSubmapBy-properSubmap = A.properSubmap-submap = A.submap-sameMap = A.sameMap---- Assoc--toSeq = toSeqUsingFoldWithKey--keys = keysUsingFoldWithKey--mapWithKey f- = mapKVFM (\k mv -> case mv of- Nothing -> Nothing- Just v -> Just (f k v))--foldWithKey op r (FM n fmb)- = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r- where- foldWithKeyB _ Nothing = id- foldWithKeyB k (Just v) = op k v-- foldWithKeyFM _ E = id- foldWithKeyFM ks (I _ k v l (FMB' m) r)- = foldWithKeyFM ks l- . foldWithKeyB (reverse (k:ks)) v- . foldWithKeyFM (k:ks) m- . foldWithKeyFM ks r----- FIXME, make this strict-foldWithKey' = foldWithKey---filterWithKey f- = mapKVFM (\k mv -> case mv of- Nothing -> mv- Just v -> if f k v then mv else Nothing)--partitionWithKey f m- = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m)---- FiniteMap--unionWithKey f- = mergeKVFM (\k v1m v2m ->- case v1m of- Nothing -> v2m- Just v1 ->- case v2m of- Nothing -> v1m- Just v2 -> Just (f k v1 v2))--unionSeqWithKey = unionSeqWithKeyUsingReduce--intersectionWithKey f- = mergeKVFM (\k v1m v2m ->- case v1m of- Nothing -> Nothing- Just v1 ->- case v2m of- Nothing -> Nothing- Just v2 -> Just (f k v1 v2))---- OrdAssocX--minViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)-minViewFMB E _ = fail $ moduleName++".minView: empty map"-minViewFMB (I i k (Just v) E m r) f = return (v, f (I i k Nothing E m r))-minViewFMB (I _ _ Nothing E (FMB' E) _) _ = error $ moduleName++".minView: bug!"-minViewFMB (I _ k Nothing E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))-minViewFMB (I _ k mv l m r) f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r))--minView :: Monad m => FM k a -> m (a,FM k a)-minView (FM (Just v) fmb) = return (v, FM Nothing fmb)-minView (FM Nothing fmb) = minViewFMB fmb (FM Nothing)--minViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)-minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map"-minViewWithKeyFMB (I i k (Just v) E m r) kf f = return ((kf [k],v),f (I i k Nothing E m r))-minViewWithKeyFMB (I _ _ Nothing E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!"-minViewWithKeyFMB (I _ k Nothing E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:))- (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r))-minViewWithKeyFMB (I _ k mv l m r) kf f = minViewWithKeyFMB l kf- (\l' -> f (mkVBalancedFMB k mv l' m r))--minViewWithKey :: Monad m => FM k a -> m (([k],a),FM k a)-minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb)-minViewWithKey (FM Nothing fmb) = minViewWithKeyFMB fmb id (FM Nothing)---minElemFMB :: FMB k a -> a-minElemFMB E = error $ moduleName++".minElem: empty map"-minElemFMB (I _ _ (Just v) E _ _) = v-minElemFMB (I _ _ Nothing E (FMB' m) _) = minElemFMB m-minElemFMB (I _ _ _ l _ _) = minElemFMB l--minElem :: FM t1 t -> t-minElem (FM (Just v) _) = v-minElem (FM Nothing fmb) = minElemFMB fmb---minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a)-minElemWithKeyFMB _ E = error $ moduleName++".minElemWithKey: empty map"-minElemWithKeyFMB kf (I _ k (Just v) E _ _) = (kf [k],v)-minElemWithKeyFMB kf (I _ k Nothing E (FMB' m) _) = minElemWithKeyFMB (kf . (k:)) m-minElemWithKeyFMB kf (I _ _ _ l _ _) = minElemWithKeyFMB kf l--minElemWithKey :: FM k a -> ([k],a)-minElemWithKey (FM (Just v) _) = ([],v)-minElemWithKey (FM Nothing fmb) = minElemWithKeyFMB id fmb--deleteMin :: Ord k => FM k a -> FM k a-deleteMin = deleteMinUsingMinView--unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a-unsafeInsertMin = insert--maxViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a)-maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l)---maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E))-maxViewFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!"-maxViewFMB (I i k mv l (FMB' m) E) f = maxViewFMB m (\m' -> f (I i k mv l (FMB' m') E))-maxViewFMB (I _ k mv l m r) f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r'))-maxViewFMB E _ = error $ moduleName++".maxView: bug!"--maxView :: Monad m => FM k a -> m (a, FM k a)-maxView (FM Nothing E) = fail $ moduleName++".maxView: empty map"-maxView (FM (Just v) E) = return (v,FM Nothing E)-maxView (FM mv fmb) = maxViewFMB fmb (FM mv)---maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a)-maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l)-maxViewWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!"-maxViewWithKeyFMB (I i k mv l (FMB' m) E) kf f = maxViewWithKeyFMB m (kf . (k:))- (\m' -> f (I i k mv l (FMB' m') E))-maxViewWithKeyFMB (I _ k mv l m r) kf f = maxViewWithKeyFMB r kf- (\r' -> f (mkVBalancedFMB k mv l m r'))-maxViewWithKeyFMB E _ _ = error $ moduleName++".maxViewWithKey: bug!"---maxViewWithKey :: Monad m => FM k a -> m (([k],a), FM k a)-maxViewWithKey (FM Nothing E) = fail $ moduleName++".maxViewWithKey: empty map"-maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E)-maxViewWithKey (FM mv fmb) = maxViewWithKeyFMB fmb id (FM mv)----maxElemFMB :: FMB k a -> a-maxElemFMB (I _ _ (Just v) _ (FMB' E) E) = v-maxElemFMB (I _ _ Nothing _ (FMB' E) E) = error $ moduleName++".maxElem: bug!"-maxElemFMB (I _ _ _ _ (FMB' m) E) = maxElemFMB m-maxElemFMB (I _ _ _ _ _ r) = maxElemFMB r-maxElemFMB E = error $ moduleName++".maxElem: bug!"--maxElem :: FM k a -> a-maxElem (FM (Just v) E) = v-maxElem (FM Nothing E) = error $ moduleName++".maxElem: empty map"-maxElem (FM _ fmb) = maxElemFMB fmb--maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a)-maxElemWithKeyFMB (I _ k (Just v) _ (FMB' E) E) kf = (kf [k],v)-maxElemWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxElemWithKey: bug!"-maxElemWithKeyFMB (I _ k _ _ (FMB' m) E) kf = maxElemWithKeyFMB m (kf . (k:))-maxElemWithKeyFMB (I _ _ _ _ _ r) kf = maxElemWithKeyFMB r kf-maxElemWithKeyFMB E _ = error $ moduleName++".maxElemWithKey: bug!"---maxElemWithKey :: FM k a -> ([k],a)-maxElemWithKey (FM (Just v) E) = ([],v)-maxElemWithKey (FM Nothing E) = error $ moduleName++".maxElemWithKey: empty map"-maxElemWithKey (FM _ fmb) = maxElemWithKeyFMB fmb id---deleteMax :: Ord k => FM k a -> FM k a-deleteMax = deleteMaxUsingMaxView--unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a-unsafeInsertMax = insert--unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a-unsafeFromOrdSeq = fromSeq--unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a-unsafeAppend = union---- FIXME this doesn't respect the structural invariant... why??-{--unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2)-unsafeAppend (FM Nothing fmb1) (FM mv fmb2) = FM mv (appendFMB fmb1 fmb2)-unsafeAppend (FM (Just _) _) (FM (Just _) _) = error $ moduleName++".unsafeAppend: bug!"--}--filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a-filterL_FMB _ _ _ E = E-filterL_FMB f k ks (I _ key mv l (FMB' m) r)- | key < k = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r)- | key > k = filterL_FMB f k ks l- | otherwise = case ks of- [] -> f k mv l- (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E--filterLT :: Ord k => [k] -> FM k a -> FM k a-filterLT [] _ = FM Nothing E-filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\_ _ l -> l) k ks fmb)--filterLE :: Ord k => [k] -> FM k a -> FM k a-filterLE [] (FM mv _) = FM mv E-filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb)----filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a-filterG_FMB _ _ _ E = E-filterG_FMB f k ks (I _ key mv l (FMB' m) r)- | key < k = filterG_FMB f k ks r- | key > k = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r- | otherwise = case ks of- [] -> f k mv m r- (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r--filterGT :: Ord k => [k] -> FM k a -> FM k a-filterGT [] (FM _ fmb) = FM Nothing fmb-filterGT (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k _ m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb)--filterGE :: Ord k => [k] -> FM k a -> FM k a-filterGE [] fm = fm-filterGE (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb)----FIXME do better...-partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a)-partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm)--partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)-partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm)--partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a)-partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm)--toOrdSeq = toOrdSeqUsingFoldrWithKey---- instance declarations--instance Ord k => A.AssocX (FM k) [k] where- {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; union = union; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- lookup = lookup; lookupM = lookupM; lookupAll = lookupAll;- lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM;- lookupAndDeleteAll = lookupAndDeleteAll;- lookupWithDefault = lookupWithDefault; adjust = adjust;- adjustAll = adjustAll; adjustOrInsert = adjustOrInsert;- adjustAllOrInsert = adjustAllOrInsert;- adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; elements = elements;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord k => A.Assoc (FM k) [k] where- {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey;- foldWithKey = foldWithKey; foldWithKey' = foldWithKey';- filterWithKey = filterWithKey;- partitionWithKey = partitionWithKey}--instance Ord k => A.FiniteMapX (FM k) [k] where- {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey;- insertWith = insertWith; insertWithKey = insertWithKey;- insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey;- unionl = unionl; unionr = unionr; unionWith = unionWith;- unionSeqWith = unionSeqWith; intersectionWith = intersectionWith;- difference = difference; properSubset = properSubset; subset = subset;- properSubmapBy = properSubmapBy; submapBy = submapBy;- sameMapBy = sameMapBy}--instance Ord k => A.FiniteMap (FM k) [k] where- {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey;- intersectionWithKey = intersectionWithKey}--instance Ord k => A.OrdAssocX (FM k) [k] where- {minView = minView; minElem = minElem; deleteMin = deleteMin;- unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem;- deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax;- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord k => A.OrdAssoc (FM k) [k] where- {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey;- maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey;- foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey';- foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey';- toOrdSeq = toOrdSeq}--instance Ord k => A.OrdFiniteMapX (FM k) [k]-instance Ord k => A.OrdFiniteMap (FM k) [k]---instance Ord k => Functor (FM k) where- fmap = map--instance (Ord k, Show k, Show a) => Show (FM k a) where- showsPrec = showsPrecUsingToList--instance (Ord k, Read k, Read a) => Read (FM k a) where- readsPrec = readsPrecUsingFromList--instance (Ord k, Eq a) => Eq (FM k a) where- (==) = sameMap--instance (Ord k, Ord a) => Ord (FM k a) where- compare = compareUsingToOrdList------- Test code follows-----keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool-keyInvariantFMB _ E = True-keyInvariantFMB p (I _ k _ l _ r)- = p k- && keyInvariantFMB p l- && keyInvariantFMB p r--actualSizeFMB :: FMB k a -> Int-actualSizeFMB E = 0-actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r--structuralInvariantFMB :: Ord k => FMB k a -> Bool-structuralInvariantFMB E = True-structuralInvariantFMB fmb@(I size k _ l (FMB' m) r)- = structuralInvariantFMB l- && structuralInvariantFMB m- && structuralInvariantFMB r- && keyInvariantFMB (<k) l- && keyInvariantFMB (>k) r- && actualSizeFMB fmb == size- && (sizel + sizer < 2- || (sizel <= balance * sizer && sizer <= balance * sizel))- where- sizel = sizeFMB l- sizer = sizeFMB r--structuralInvariant :: Ord k => FM k a -> Bool-structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb---instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where- arbitrary = do xs <- arbitrary- return (Prelude.foldr (uncurry insert) empty xs)--instance (Ord k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where- coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb---coarbitrary_maybe :: (CoArbitrary t) => Maybe t -> Test.QuickCheck.Gen b- -> Test.QuickCheck.Gen b-coarbitrary_maybe Nothing = variant 0-coarbitrary_maybe (Just x) = variant 1 . coarbitrary x--coarbitrary_fmb :: (CoArbitrary t1, CoArbitrary t) => FMB t t1 -> Gen a -> Gen a-coarbitrary_fmb E = variant 0-coarbitrary_fmb (I _ k x l (FMB' m) r) =- variant 1 . coarbitrary k . coarbitrary_maybe x .- coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r--instance Ord k => Monoid (FM k a) where- mempty = empty- mappend = union- mconcat = unionSeq-+-- | +-- Module : Data.Edison.Assoc.TernaryTrie +-- Copyright : Copyright (c) 2002, 2008 Andrew Bromage +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Finite maps indexed by lists or strings @[k]@, implemented as ternary +-- search tries + +module Data.Edison.Assoc.TernaryTrie ( + -- * Type of ternary search tries + FM, + + -- * AssocX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, + lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, + lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, + adjustOrDelete,adjustOrDeleteAll,strict,strictWith, + map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, + + -- * Assoc operations + toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, + + -- * FiniteMapX operations + fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, + insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, + difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, + properSubmap,submap,sameMap, + + -- * FiniteMap operations + unionWithKey,unionSeqWithKey,intersectionWithKey, + + -- * OrdAssocX operations + minView, minElem, deleteMin, unsafeInsertMin, + maxView, maxElem, deleteMax, unsafeInsertMax, + foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1', + unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE, + partitionLT_GE, partitionLE_GT, partitionLT_GT, + + -- * OrdAssoc operations + minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, + foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', + toOrdSeq, + + -- * Other supported operations + mergeVFM, mergeKVFM, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,foldl',filter) +import qualified Prelude +import qualified Data.Edison.Assoc as A +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S +import qualified Data.List as L +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Data.Coerce (coerce) +import Data.Monoid +import Data.Semigroup as SG +import Data.Maybe (isJust, isNothing) + +import Data.Edison.Assoc.Defaults +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), Gen(), NonNegative(..), variant, sized, resize, choose, oneof) + + +-- signatures for exported functions +moduleName :: String +empty :: Ord k => FM k a +singleton :: Ord k => [k] -> a -> FM k a +fromSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a +insert :: Ord k => [k] -> a -> FM k a -> FM k a +insertSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a -> FM k a +union :: Ord k => FM k a -> FM k a -> FM k a +unionSeq :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a +delete :: Ord k => [k] -> FM k a -> FM k a +deleteAll :: Ord k => [k] -> FM k a -> FM k a +deleteSeq :: (Ord k,S.Sequence seq) => seq [k] -> FM k a -> FM k a +null :: Ord k => FM k a -> Bool +size :: Ord k => FM k a -> Int +member :: Ord k => [k] -> FM k a -> Bool +count :: Ord k => [k] -> FM k a -> Int +lookup :: Ord k => [k] -> FM k a -> a +lookupM :: (Ord k, Fail.MonadFail rm) => [k] -> FM k a -> rm a +lookupAll :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a +lookupAndDelete :: Ord k => [k] -> FM k a -> (a, FM k a) +lookupAndDeleteM :: (Ord k, Fail.MonadFail rm) => [k] -> FM k a -> rm (a, FM k a) +lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a) +lookupWithDefault :: Ord k => a -> [k] -> FM k a -> a +adjust :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a +adjustAll :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a +adjustOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a +adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a +adjustOrDelete :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a +adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a +strict :: FM k a -> FM k a +strictWith :: (a -> b) -> FM k a -> FM k a +map :: Ord k => (a -> b) -> FM k a -> FM k b +fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b +fold1 :: Ord k => (a -> a -> a) -> FM k a -> a +fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +fold1' :: Ord k => (a -> a -> a) -> FM k a -> a +filter :: Ord k => (a -> Bool) -> FM k a -> FM k a +partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a) +elements :: (Ord k,S.Sequence seq) => FM k a -> seq a + +fromSeqWith :: (Ord k,S.Sequence seq) => + (a -> a -> a) -> seq ([k],a) -> FM k a +fromSeqWithKey :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a +insertWith :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a +insertWithKey :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a +insertSeqWith :: (Ord k,S.Sequence seq) => + (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a +insertSeqWithKey :: (Ord k,S.Sequence seq) => + ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a +unionl :: Ord k => FM k a -> FM k a -> FM k a +unionr :: Ord k => FM k a -> FM k a -> FM k a +unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWith :: (Ord k,S.Sequence seq) => + (a -> a -> a) -> seq (FM k a) -> FM k a +intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c +difference :: Ord k => FM k a -> FM k b -> FM k a +properSubset :: Ord k => FM k a -> FM k b -> Bool +subset :: Ord k => FM k a -> FM k b -> Bool +properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +properSubmap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool +submap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool +sameMap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool + +toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a) +keys :: (Ord k,S.Sequence seq) => FM k a -> seq [k] +mapWithKey :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b +foldWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b +foldWithKey' :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b +filterWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a +partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a) +unionWithKey :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWithKey :: (Ord k,S.Sequence seq) => + ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a +intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c + +foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a + +foldrWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b +foldrWithKey' :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b +foldlWithKey' :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b +toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a) + +moduleName = "Data.Edison.Assoc.TernaryTrie" + + +data FM k a + = FM !(Maybe a) !(FMB k a) + +-- | This is isomorphic to an iteration of binary trees with keys @k@. +-- +-- @ +-- data BT k v = E | I k v (BT k v) (BT k v) +-- data Layer k v x = Layer (Maybe v) (BT k x) +-- +-- FMB k v = Fix (Layer k v) +-- @ +-- +-- The trees are weight-balanced trees, ensuring that the sizes of the +-- two subtrees of any node are bounded by each other up to a constant factor. +-- +-- @ +-- size l + size r <= 1 +-- +-- -- or -- +-- +-- size l <= 6 * size r +-- size r <= 6 * size l +-- @ +-- +-- Source: <https://yoichihirai.com/bst.pdf Balancing Weight-Balanced Trees> +-- by Hirai and Yamamoto, 2011 (Section 4) +data FMB k v + = E + | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v) + deriving Show + +newtype FMB' k v + = FMB' (FMB k v) + deriving Show + +-- | The balance factor must be either 3 or 4. +-- With other factors, the invariant gets broken by delete, minViewWithKey and maxViewWithKey. +-- (cf. Section 4 of the paper linked above) +balance :: Int +balance = 4 + +sizeFMB :: FMB k v -> Int +sizeFMB E = 0 +sizeFMB (I size _ _ _ _ _) = size + +mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v +mkFMB k v l m r + = I (1 + sizeFMB l + sizeFMB r) k v l m r + +lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v +lookupFMB [] _ + = Nothing +lookupFMB (_:_) E + = Nothing +lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r) + = case compare x k of + LT -> lookupFMB nk l + GT -> lookupFMB nk r + EQ -> if L.null xs then v else lookupFMB xs fmbm + +listToFMB :: [k] -> v -> FMB k v +listToFMB [x] v = mkFMB x (Just v) E (FMB' E) E +listToFMB (x:xs) v = mkFMB x Nothing E (FMB' $ listToFMB xs v) E +listToFMB _ _ = error "TernaryTrie.listToFMB: bug!" + +addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v +addToFMB xs combiner E + = case combiner Nothing of + Just v -> listToFMB xs v + Nothing -> E +addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r) + = case compare x k of + LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r + GT -> mkBalancedFMB k v l m (addToFMB nk combiner r) + EQ -> case xs of + [] -> case combiner v of + Nothing | FMB' E <- m -> appendFMB l r + v' -> I size k v' l m r + _ -> case addToFMB xs combiner fmbm of + E | Nothing <- v -> appendFMB l r + m' -> I size k v l (FMB' m') r +addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!" + +addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v +addToFM [] combiner (FM n fmb) + = FM (combiner n) fmb +addToFM xs combiner (FM n fmb) + = FM n (addToFMB xs combiner fmb) + +lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z +lookupAndDelFromFMB onFail _ _ E = onFail +lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r) + = case compare x k of + LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l + GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r + EQ -> case xs of + [] -> case v of + Nothing -> onFail + Just w -> case fmbm of + E -> cont w (appendFMB l r) + _ -> cont w (I size k Nothing l m r) + _ -> lookupAndDelFromFMB onFail (\w m' -> case m' of + E | Nothing <- v -> cont w (appendFMB l r) + _ -> cont w (I size k v l (FMB' m') r)) xs fmbm +lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!" + +lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z +lookupAndDelFromFM onFail _ [] (FM Nothing _) = onFail +lookupAndDelFromFM _ cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb) +lookupAndDelFromFM onFail cont xs (FM n fmb) = + lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb + + +delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v +delFromFMB _ E + = E +delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r) + = case compare x k of + LT -> mkBalancedFMB k v (delFromFMB nk l) m r + GT -> mkBalancedFMB k v l m (delFromFMB nk r) + EQ -> case xs of + [] -> case fmbm of + E -> appendFMB l r + _ -> I size k Nothing l m r + _ -> case delFromFMB xs fmbm of + E | Nothing <- v -> appendFMB l r + m' -> I size k v l (FMB' m') r +delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!" + + +delFromFM :: (Ord k) => [k] -> FM k v -> FM k v +delFromFM [] (FM _ fmb) + = FM Nothing fmb +delFromFM xs (FM n fmb) + = FM n (delFromFMB xs fmb) + + +mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v +mkBalancedFMB k v l m r + | size_l + size_r < 2 + = mkFMB k v l m r + | size_r > balance * size_l -- Right tree too big + = case r of + I _ _ _ rl _ rr + | sizeFMB rl < 2 * sizeFMB rr + -> single_L l m r + | otherwise + -> double_L l m r + _ -> error "TernaryTrie.mkBalancedFMB: bug!" + + | size_l > balance * size_r -- Left tree too big + = case l of + I _ _ _ ll _ lr + | sizeFMB lr < 2 * sizeFMB ll + -> single_R l m r + | otherwise + -> double_R l m r + _ -> error "TernaryTrie.mkBalancedFMB: bug!" + + | otherwise -- No imbalance + = mkFMB k v l m r + where + size_l = sizeFMB l + size_r = sizeFMB r + + single_L l m (I _ k_r v_r rl rm rr) + = mkFMB k_r v_r (mkFMB k v l m rl) rm rr + single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" + + double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr) + = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr) + double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" + + single_R (I _ k_l v_l ll lm lr) m r + = mkFMB k_l v_l ll lm (mkFMB k v lr m r) + single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" + + double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r + = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r) + double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" + + +mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v +mkVBalancedFMB k Nothing l (FMB' E) r + = appendFMB l r +mkVBalancedFMB k v E m E + = mkFMB k v E m E +mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr) + = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr +mkVBalancedFMB k v (I _ kl vl ll lm lr) m r@E + = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r) +mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr) + | balance * size_l < size_r + = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr + | balance * size_r < size_l + = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r) + | otherwise + = mkFMB k v l m r + where + size_l = sizeFMB l + size_r = sizeFMB r + + -- Constraint: All keys in the first FMB are less than + -- that in the second FMB. +appendFMB :: FMB k v -> FMB k v -> FMB k v +appendFMB E m2 = m2 +appendFMB m1 E = m1 +appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2) + | size1 > size2 + = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2) + | otherwise + = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2 + +mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b +mapVFM f (FM n fmb) + = FM (f n) (mapVFMB f fmb) + +mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b +mapVFMB f m + = mapVFMB' m + where + mapVFMB' E = E + mapVFMB' (I _ k v l (FMB' m) r) + = case (mapVFMB' m, f v) of + (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r) + (m',v') -> mkVBalancedFMB k v' + (mapVFMB' l) (FMB' m') (mapVFMB' r) + +mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b +mapKVFM f (FM n fmb) + = FM (f [] n) (mapKVFMB [] fmb) + where + mapKVFMB _ E = E + mapKVFMB ks (I _ k v l (FMB' m) r) + = mkVBalancedFMB k (f (reverse (k:ks)) v) + (mapKVFMB ks l) + (FMB' (mapKVFMB (k:ks) m)) + (mapKVFMB ks r) + +nullFMB :: FMB k v -> Bool +nullFMB E = True +nullFMB (I _ _ v l (FMB' m) r) + = case v of + Just _ -> False + Nothing -> nullFMB l && nullFMB m && nullFMB r + +nullFM :: FM k v -> Bool +nullFM (FM (Just _) _) = False +nullFM (FM Nothing fmb) = nullFMB fmb + +data FMBCtx k v + = T + | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v) + | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v) + +splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a) +splayFMB key fmb + = splaydown T fmb + where + splaydown ctx E + = splayup ctx Nothing E (FMB' E) E + splaydown ctx (I _ k v l m r) + = case compare key k of + LT -> splaydown (L k v ctx m r) l + GT -> splaydown (R k v l m ctx) r + EQ -> splayup ctx v l m r + + splayup ctx v l m r + = splayup' ctx l r + where + splayup' T l r + = (v, l, m, r) + splayup' (L ck cv ctx cm cr) tl tr + = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr) + splayup' (R ck cv cl cm ctx) tl tr + = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr + +mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) -> + FMB k a -> FMB k b -> FMB k c +mergeVFMB f fmbx fmby + = mergeVFMB' fmbx fmby + where + mergeVFMB' E E + = E + mergeVFMB' E fmby@(I _ _ _ _ (FMB' _) _) + = mapVFMB (\v -> f Nothing v) fmby + mergeVFMB' fmbx@(I _ _ _ _ (FMB' _) _) E + = mapVFMB (\v -> f v Nothing) fmbx + mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx) + fmby@(I sizey ky vy ly (FMB' my) ry) + | sizex >= sizey + = let (vy, ly, FMB' my, ry) = splayFMB kx fmby + in case (mergeVFMB' mx my, f vx vy) of + (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry) + (m',v) -> mkVBalancedFMB kx v + (mergeVFMB' lx ly) + (FMB' m') + (mergeVFMB' rx ry) + | otherwise + = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx + in case (mergeVFMB' mx my, f vx vy) of + (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry) + (m',v) -> mkVBalancedFMB ky v + (mergeVFMB' lx ly) + (FMB' m') + (mergeVFMB' rx ry) + +mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) -> + FM k a -> FM k b -> FM k c +mergeVFM f (FM vx fmbx) (FM vy fmby) + = FM (f vx vy) (mergeVFMB f fmbx fmby) + + +mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) -> + FMB k a -> FMB k b -> FMB k c +mergeKVFMB f fmbx fmby + = mergeKVFMB' [] fmbx fmby + where + mergeKVFMB' _ E E + = E + mergeKVFMB' ks E fmby + = mergeKVFMBs (\k v -> f k Nothing v) ks fmby + mergeKVFMB' ks fmbx E + = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx + mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx) + fmby@(I sizey ky vy ly (FMB' my) ry) + | sizex >= sizey + = let (vy, ly, FMB' my, ry) = splayFMB kx fmby + ks' = reverse (kx:ks) + in case (mergeKVFMB' ks' mx my, f ks' vx vy) of + (E,Nothing) -> appendFMB + (mergeKVFMB' ks lx ly) + (mergeKVFMB' ks rx ry) + (m',v) -> mkVBalancedFMB kx v + (mergeKVFMB' ks lx ly) + (FMB' m') + (mergeKVFMB' ks rx ry) + | otherwise + = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx + ks' = reverse (ky:ks) + in case (mergeKVFMB' ks' mx my, f ks' vx vy) of + (E,Nothing) -> appendFMB + (mergeKVFMB' ks lx ly) + (mergeKVFMB' ks rx ry) + (m',v) -> mkVBalancedFMB ky v + (mergeKVFMB' ks lx ly) + (FMB' m') + (mergeKVFMB' ks rx ry) + + mergeKVFMBs f ks fmb + = mergeKVFMBs' ks fmb + where + mergeKVFMBs' _ E + = E + mergeKVFMBs' ks (I _ k v l (FMB' m) r) + = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of + (E, Nothing) -> appendFMB + (mergeKVFMBs' ks l) + (mergeKVFMBs' ks r) + (m,v) -> mkVBalancedFMB k v + (mergeKVFMBs' ks l) + (FMB' m) + (mergeKVFMBs' ks r) + +mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) -> + FM k a -> FM k b -> FM k c +mergeKVFM f (FM vx fmbx) (FM vy fmby) + = FM (f [] vx vy) (mergeKVFMB f fmbx fmby) + + +-- The public interface. +-- + +-- AssocX + +empty = FM Nothing E + +singleton [] v = FM (Just v) E +singleton xs v = FM Nothing (listToFMB xs v) + +fromSeq = fromSeqUsingInsertSeq + +insert k v fm = addToFM k (\_ -> Just v) fm + +insertSeq = insertSeqUsingFoldr + +union = mergeVFM mplus + +unionSeq = unionSeqUsingReduce + +delete k fm = delFromFM k fm + +deleteAll = delete + +deleteSeq = deleteSeqUsingFoldr + +null = nullFM + +size (FM k fmb) + | isNothing k = fmb_size fmb 0 + | otherwise = fmb_size fmb 1 + where fmb_size E k = k + fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k + fmb_size (I _ _ _ l (FMB' m) r ) k = fmb_size l $ fmb_size m $ fmb_size r $! k+1 + + +member = memberUsingLookupM + +count = countUsingMember + +lookup m k = runFail_ (lookupM m k) + +lookupM [] (FM Nothing _) + = fail "TernaryTrie.lookup: lookup failed" +lookupM [] (FM (Just v) _) + = return v +lookupM xs (FM _ fmb) + = case lookupFMB xs fmb of + Nothing -> fail "TernaryTrie.lookup: lookup failed" + Just v -> return v + +lookupAll = lookupAllUsingLookupM + +lookupAndDelete = + lookupAndDelFromFM + (error "TernaryTrie.lookupAndDelete: lookup failed") + (,) + +lookupAndDeleteM = + lookupAndDelFromFM + (fail "TernaryTrie.lookupAndDeleteM: lookup failed") + (\w m -> return (w,m)) + +lookupAndDeleteAll k m = + lookupAndDelFromFM + (S.empty,m) + (\w m' -> (S.singleton w,m')) + k m + +lookupWithDefault = lookupWithDefaultUsingLookupM + +adjust f k + = addToFM k (\mv -> case mv of + Nothing -> mv + Just v -> Just (f v)) + +adjustAll = adjust + +adjustOrInsert f z k + = addToFM k (\mv -> case mv of + Nothing -> Just z + Just v -> Just (f v)) + +adjustAllOrInsert = adjustOrInsert + +adjustOrDelete f k + = addToFM k (\mv -> case mv of + Nothing -> mv + Just v -> f v) + +adjustOrDeleteAll = adjustOrDelete + +map f + = mapVFM (\mv -> case mv of + Nothing -> Nothing + Just v -> Just (f v)) + +fold = foldr +fold' = foldr' + +foldr op z (FM n fmb) + = foldMV n . foldFMB fmb $ z + where + foldMV Nothing = id + foldMV (Just v) = op v + + foldFMB E + = id + foldFMB (I _ _ v l (FMB' m) r) + = foldFMB l . foldMV v . foldFMB m . foldFMB r + +foldrWithKey f z (FM n fmb) + = foldMV [] n . foldFMB id fmb $ z + where + foldMV _ Nothing = id + foldMV ks (Just v) = f ks v + + foldFMB _ E = id + foldFMB kf (I _ k mv l (FMB' m) r) + = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r + +foldlWithKey f z (FM n fmb) + = foldFMB id fmb . foldMV [] n $ z + where + g k x a = f a k x + + foldMV _ Nothing = id + foldMV ks (Just v) = g ks v + + foldFMB _ E = id + foldFMB kf (I _ k mv l (FMB' m) r) + = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l + +foldrWithKey' = foldrWithKey +foldlWithKey' = foldlWithKey + +foldl :: (a -> b -> a) -> a -> FM t b -> a +foldl op z (FM n fmb) + = foldFMB fmb . foldMV n $ z + where + foldMV Nothing = id + foldMV (Just v) = (flip op) v + + foldFMB E = id + foldFMB (I _ _ v l (FMB' m) r) + = foldFMB r . foldFMB m . foldMV v . foldFMB l + + +-- FIXME, understand this code to strictify it +foldr' = foldr +foldl' :: (a -> b -> a) -> a -> FM t b -> a +foldl' = foldl + +foldr1 f fm = + case maxView fm of + Just (z,fm') -> foldr f z fm' + Nothing -> error $ moduleName++".foldr1: empty map" + +foldl1 :: (b -> b -> b) -> FM k b -> b +foldl1 f fm = + case minView fm of + Just (z,fm') -> foldl f z fm' + Nothing -> error $ moduleName++".foldl1: empty map" + + +basecase :: Maybe t1 -> (t1 -> t) -> t -> t +basecase Nothing = \_ n -> n +basecase (Just x) = \j _ -> j x + +comb :: (t1 -> t1 -> t1) + -> ((t1 -> t2) -> t2 -> t3) + -> ((t1 -> t) -> t -> t2) + -> (t1 -> t) + -> t + -> t3 +comb f p1 p2 + = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n) + +fold1 f (FM mv fmb) + = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map") + where + fold1FMB E + = \_ n -> n + fold1FMB (I _ _ mv l (FMB' m) r) + = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r) + +fold1' = fold1 + +{- +FIXME -- can these be somehow fixed to have the right order... + +foldr1 f (FM v fmb) + = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map") + where + fold1FMB E + = \j n -> n + fold1FMB (I _ _ v l (FMB' m) r) + = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r) + + +foldl1 f (FM v fmb) + = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map") + where + fold1FMB E + = \j n -> n + fold1FMB (I _ _ v l (FMB' m) r) + = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l) +-} + + + +-- FIXME, understand this code to strictify it +foldr1' = foldr1 +foldl1' :: (b -> b -> b) -> FM k b -> b +foldl1' = foldl1 + + +filter p = mapVFM (\mv -> case mv of + Nothing -> mv + Just v -> if p v then mv else Nothing) + +partition = partitionUsingFilter + +elements = elementsUsingFold + +strict z@(FM _ fmb) = strictFMB fmb `seq` z + where strictFMB n@E = n + strictFMB n@(I _ _ _ l (FMB' m) r) = + strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n + +strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z + where f' v@Nothing = v + f' v@(Just x) = f x `seq` v + + strictWithFMB n@E = n + strictWithFMB n@(I _ _ v l (FMB' m) r) = + f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n + + +-- FiniteMapX + +fromSeqWith = fromSeqWithUsingInsertSeqWith + +fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey + +insertWith f k v + = addToFM k (\vem -> + case vem of + Nothing -> Just v + Just ve -> Just (f ve v)) + +insertWithKey = insertWithKeyUsingInsertWith + +insertSeqWith = insertSeqWithUsingInsertWith + +insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey + +unionl = union +unionr = flip union + +unionWith f = unionWithKey (const f) + +unionSeqWith = unionSeqWithUsingReduce + +intersectionWith f = intersectionWithKey (const f) + +difference mx my + = mergeVFM (\v1 v2 -> case v2 of + Nothing -> v1 + Just _ -> Nothing) mx my + +properSubset = properSubsetUsingSubset + +subset (FM nx fmbx) (FM ny fmby) + = subsetEqM nx ny && subsetEqFMB fmbx fmby + where + subsetEqM Nothing _ = True + subsetEqM (Just _) Nothing = False + subsetEqM (Just _) (Just _) = True + + subsetEqFMB E _ = True + subsetEqFMB fmbx@(I _ _ _ _ _ _) E + = nullFMB fmbx + subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx) + fmby@(I sizey ky vy ly (FMB' my) ry) + | sizex >= sizey + = let (vy, ly, FMB' my, ry) = splayFMB kx fmby + in subsetEqM vx vy + && subsetEqFMB lx ly + && subsetEqFMB mx my + && subsetEqFMB rx ry + | otherwise + = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx + in subsetEqM vx vy + && subsetEqFMB lx ly + && subsetEqFMB mx my + && subsetEqFMB rx ry + + +submapBy = submapByUsingLookupM +properSubmapBy = properSubmapByUsingSubmapBy +sameMapBy = sameMapByUsingSubmapBy +properSubmap = A.properSubmap +submap = A.submap +sameMap = A.sameMap + +-- Assoc + +toSeq = toSeqUsingFoldWithKey + +keys = keysUsingFoldWithKey + +mapWithKey f + = mapKVFM (\k mv -> case mv of + Nothing -> Nothing + Just v -> Just (f k v)) + +foldWithKey op r (FM n fmb) + = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r + where + foldWithKeyB _ Nothing = id + foldWithKeyB k (Just v) = op k v + + foldWithKeyFM _ E = id + foldWithKeyFM ks (I _ k v l (FMB' m) r) + = foldWithKeyFM ks l + . foldWithKeyB (reverse (k:ks)) v + . foldWithKeyFM (k:ks) m + . foldWithKeyFM ks r + + +-- FIXME, make this strict +foldWithKey' = foldWithKey + + +filterWithKey f + = mapKVFM (\k mv -> case mv of + Nothing -> mv + Just v -> if f k v then mv else Nothing) + +partitionWithKey f m + = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m) + +-- FiniteMap + +unionWithKey f + = mergeKVFM (\k v1m v2m -> + case v1m of + Nothing -> v2m + Just v1 -> + case v2m of + Nothing -> v1m + Just v2 -> Just (f k v1 v2)) + +unionSeqWithKey = unionSeqWithKeyUsingReduce + +intersectionWithKey f + = mergeKVFM (\k v1m v2m -> + case v1m of + Nothing -> Nothing + Just v1 -> + case v2m of + Nothing -> Nothing + Just v2 -> Just (f k v1 v2)) + +-- OrdAssocX + +minViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a) +minViewFMB E _ = fail $ moduleName++".minView: empty map" +minViewFMB (I i k (Just v) E m r) f = return (v, f t) + where + t = case m of + FMB' E -> r + _ -> I i k Nothing E m r +minViewFMB (I _ _ Nothing E (FMB' E) _) _ = error $ moduleName++".minView: bug!" +minViewFMB (I _ k Nothing E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) +minViewFMB (I _ k mv l m r) f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r)) + +minView :: Fail.MonadFail m => FM k a -> m (a,FM k a) +minView (FM (Just v) fmb) = return (v, FM Nothing fmb) +minView (FM Nothing fmb) = minViewFMB fmb (FM Nothing) + +minViewWithKeyFMB :: Fail.MonadFail m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a) +minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map" +minViewWithKeyFMB (I i k (Just v) E m r) kf f = return ((kf [k],v),f t) + where + t = case m of + FMB' E -> r + _ -> I i k Nothing E m r +minViewWithKeyFMB (I _ _ Nothing E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!" +minViewWithKeyFMB (I _ k Nothing E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:)) + (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) +minViewWithKeyFMB (I _ k mv l m r) kf f = minViewWithKeyFMB l kf + (\l' -> f (mkVBalancedFMB k mv l' m r)) + +minViewWithKey :: Fail.MonadFail m => FM k a -> m (([k],a),FM k a) +minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb) +minViewWithKey (FM Nothing fmb) = minViewWithKeyFMB fmb id (FM Nothing) + + +minElemFMB :: FMB k a -> a +minElemFMB E = error $ moduleName++".minElem: empty map" +minElemFMB (I _ _ (Just v) E _ _) = v +minElemFMB (I _ _ Nothing E (FMB' m) _) = minElemFMB m +minElemFMB (I _ _ _ l _ _) = minElemFMB l + +minElem :: FM t1 t -> t +minElem (FM (Just v) _) = v +minElem (FM Nothing fmb) = minElemFMB fmb + + +minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a) +minElemWithKeyFMB _ E = error $ moduleName++".minElemWithKey: empty map" +minElemWithKeyFMB kf (I _ k (Just v) E _ _) = (kf [k],v) +minElemWithKeyFMB kf (I _ k Nothing E (FMB' m) _) = minElemWithKeyFMB (kf . (k:)) m +minElemWithKeyFMB kf (I _ _ _ l _ _) = minElemWithKeyFMB kf l + +minElemWithKey :: FM k a -> ([k],a) +minElemWithKey (FM (Just v) _) = ([],v) +minElemWithKey (FM Nothing fmb) = minElemWithKeyFMB id fmb + +deleteMin :: Ord k => FM k a -> FM k a +deleteMin = deleteMinUsingMinView + +unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a +unsafeInsertMin = insert + +maxViewFMB :: Fail.MonadFail m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a) +maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l) +--maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E)) +maxViewFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!" +maxViewFMB (I i k mv l (FMB' m) E) f = maxViewFMB m (\m' -> f (t m')) + where + t m' = case m' of + E | Nothing <- mv -> l + _ -> I i k mv l (FMB' m') E +maxViewFMB (I _ k mv l m r) f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r')) +maxViewFMB E _ = error $ moduleName++".maxView: bug!" + +maxView :: Fail.MonadFail m => FM k a -> m (a, FM k a) +maxView (FM Nothing E) = fail $ moduleName++".maxView: empty map" +maxView (FM (Just v) E) = return (v,FM Nothing E) +maxView (FM mv fmb) = maxViewFMB fmb (FM mv) + + +maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a) +maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l) +maxViewWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!" +maxViewWithKeyFMB (I i k mv l (FMB' m) E) kf f = maxViewWithKeyFMB m (kf . (k:)) + (\m' -> f (t m')) + where + t m' = case m' of + E | Nothing <- mv -> l + _ -> I i k mv l (FMB' m') E +maxViewWithKeyFMB (I _ k mv l m r) kf f = maxViewWithKeyFMB r kf + (\r' -> f (mkVBalancedFMB k mv l m r')) +maxViewWithKeyFMB E _ _ = error $ moduleName++".maxViewWithKey: bug!" + + +maxViewWithKey :: Fail.MonadFail m => FM k a -> m (([k],a), FM k a) +maxViewWithKey (FM Nothing E) = fail $ moduleName++".maxViewWithKey: empty map" +maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E) +maxViewWithKey (FM mv fmb) = maxViewWithKeyFMB fmb id (FM mv) + + + +maxElemFMB :: FMB k a -> a +maxElemFMB (I _ _ (Just v) _ (FMB' E) E) = v +maxElemFMB (I _ _ Nothing _ (FMB' E) E) = error $ moduleName++".maxElem: bug!" +maxElemFMB (I _ _ _ _ (FMB' m) E) = maxElemFMB m +maxElemFMB (I _ _ _ _ _ r) = maxElemFMB r +maxElemFMB E = error $ moduleName++".maxElem: bug!" + +maxElem :: FM k a -> a +maxElem (FM (Just v) E) = v +maxElem (FM Nothing E) = error $ moduleName++".maxElem: empty map" +maxElem (FM _ fmb) = maxElemFMB fmb + +maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a) +maxElemWithKeyFMB (I _ k (Just v) _ (FMB' E) E) kf = (kf [k],v) +maxElemWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxElemWithKey: bug!" +maxElemWithKeyFMB (I _ k _ _ (FMB' m) E) kf = maxElemWithKeyFMB m (kf . (k:)) +maxElemWithKeyFMB (I _ _ _ _ _ r) kf = maxElemWithKeyFMB r kf +maxElemWithKeyFMB E _ = error $ moduleName++".maxElemWithKey: bug!" + + +maxElemWithKey :: FM k a -> ([k],a) +maxElemWithKey (FM (Just v) E) = ([],v) +maxElemWithKey (FM Nothing E) = error $ moduleName++".maxElemWithKey: empty map" +maxElemWithKey (FM _ fmb) = maxElemWithKeyFMB fmb id + + +deleteMax :: Ord k => FM k a -> FM k a +deleteMax = deleteMaxUsingMaxView + +unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a +unsafeInsertMax = insert + +unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a +unsafeFromOrdSeq = fromSeq + +unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a +unsafeAppend = union + +-- FIXME this doesn't respect the structural invariant... why?? +{- +unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2) +unsafeAppend (FM Nothing fmb1) (FM mv fmb2) = FM mv (appendFMB fmb1 fmb2) +unsafeAppend (FM (Just _) _) (FM (Just _) _) = error $ moduleName++".unsafeAppend: bug!" +-} + +filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a +filterL_FMB _ _ _ E = E +filterL_FMB f k ks (I _ key mv l (FMB' m) r) + | key < k = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r) + | key > k = filterL_FMB f k ks l + | otherwise = case ks of + [] -> f k mv l + (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E + +filterLT :: Ord k => [k] -> FM k a -> FM k a +filterLT [] _ = FM Nothing E +filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\_ _ l -> l) k ks fmb) + +filterLE :: Ord k => [k] -> FM k a -> FM k a +filterLE [] (FM mv _) = FM mv E +filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb) + + + +filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a +filterG_FMB _ _ _ E = E +filterG_FMB f k ks (I _ key mv l (FMB' m) r) + | key < k = filterG_FMB f k ks r + | key > k = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r + | otherwise = case ks of + [] -> f k mv m r + (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r + +filterGT :: Ord k => [k] -> FM k a -> FM k a +filterGT [] (FM _ fmb) = FM Nothing fmb +filterGT (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k _ m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb) + +filterGE :: Ord k => [k] -> FM k a -> FM k a +filterGE [] fm = fm +filterGE (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb) + +--FIXME do better... +partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a) +partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm) + +partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a) +partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm) + +partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a) +partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm) + +toOrdSeq = toOrdSeqUsingFoldrWithKey + +-- instance declarations + +instance Ord k => A.AssocX (FM k) [k] where + {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; union = union; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; + lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; + lookupAndDeleteAll = lookupAndDeleteAll; + lookupWithDefault = lookupWithDefault; adjust = adjust; + adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; + adjustAllOrInsert = adjustAllOrInsert; + adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; elements = elements; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord k => A.Assoc (FM k) [k] where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance Ord k => A.FiniteMapX (FM k) [k] where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance Ord k => A.FiniteMap (FM k) [k] where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance Ord k => A.OrdAssocX (FM k) [k] where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord k => A.OrdAssoc (FM k) [k] where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance Ord k => A.OrdFiniteMapX (FM k) [k] +instance Ord k => A.OrdFiniteMap (FM k) [k] + + +instance Ord k => Functor (FM k) where + fmap = map + +instance (Ord k, Show k, Show a) => Show (FM k a) where + showsPrec = showsPrecUsingToList + +instance (Ord k, Read k, Read a) => Read (FM k a) where + readsPrec = readsPrecUsingFromList + +instance (Ord k, Eq a) => Eq (FM k a) where + (==) = sameMap + +instance (Ord k, Ord a) => Ord (FM k a) where + compare = compareUsingToOrdList + +-- +-- Test code follows +-- + +keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool +keyInvariantFMB _ E = True +keyInvariantFMB p (I _ k _ l _ r) + = p k + && keyInvariantFMB p l + && keyInvariantFMB p r + +actualSizeFMB :: FMB k a -> Int +actualSizeFMB E = 0 +actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r + +structuralInvariantFMB :: Ord k => FMB k a -> Bool +structuralInvariantFMB E = True +structuralInvariantFMB fmb@(I size k v l (FMB' m) r) + = structuralInvariantFMB l + && structuralInvariantFMB m + && structuralInvariantFMB r + && keyInvariantFMB (<k) l + && keyInvariantFMB (>k) r + && actualSizeFMB fmb == size + && isBalanced l r + && relevantRoot fmb + +isBalanced :: FMB k a -> FMB k a -> Bool +isBalanced l r = sizel + sizer <= 1 + || (sizel <= balance * sizer && sizer <= balance * sizel) + where + sizel = sizeFMB l + sizer = sizeFMB r + +-- | This invariant is used by minView +relevantRoot :: FMB k a -> Bool +relevantRoot (I _ _ Nothing _ (FMB' E) _) = False +relevantRoot _ = True + +structuralInvariant :: Ord k => FM k a -> Bool +structuralInvariant (FM _ fmb) = structuralInvariantFMB fmb + +-- | Generate weight-balanced trees either by direct recursion or via +-- 'fromSeq'. The former is much more likely to hit counterexamples to wrong +-- @balance@ coefficients. We keep the latter generator around just in case, +-- because it generates a more realistic distribution. +instance (Integral k, Arbitrary k, Arbitrary a) => Arbitrary (FM k a) where + arbitrary = oneof [genFM, fromSeq <$> (arbitrary :: Gen [([k], a)])] + shrink (FM v m) = [FM v m | (v, FMB' m) <- shrinkTuple shrink shrinkFMB' (v, FMB' m)] + +instance (Ord k,CoArbitrary k,CoArbitrary a) => CoArbitrary (FM k a) where + coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb + + +coarbitrary_maybe :: (CoArbitrary t) => Maybe t -> Test.QuickCheck.Gen b + -> Test.QuickCheck.Gen b +coarbitrary_maybe Nothing = variant (0 :: Int) +coarbitrary_maybe (Just x) = variant (1 :: Int) . coarbitrary x + +coarbitrary_fmb :: (CoArbitrary t1, CoArbitrary t) => FMB t t1 -> Gen a -> Gen a +coarbitrary_fmb E = variant (0 :: Int) +coarbitrary_fmb (I _ k x l (FMB' m) r) = + variant (1 :: Int) . coarbitrary k . coarbitrary_maybe x . + coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r + +instance Ord k => Semigroup (FM k a) where + (<>) = union +instance Ord k => Monoid (FM k a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +-- Testing + +genFM :: (Integral k, Arbitrary a) => Gen (FM k a) +genFM = do + FM <$> arbitrary <*> genFMB_ + +-- Choose the number of elements in the top layer upfront, +-- and distribute it while recursing down. +genFMB_ :: (Integral k, Arbitrary a) => Gen (FMB k a) +genFMB_ = sized $ \sz -> do + n <- choose (0, sz) + resize (sz - n) (genFMB 0 n) + +-- Distribute the size @sz@ to generate the middle children of the nodes in the +-- top layer. +genFMB :: (Integral k, Arbitrary a) => Int -> Int -> Gen (FMB k a) +genFMB i 0 = pure E +genFMB i n = sized $ \sz -> do + let b = if n <= 2 then 0 else (n-1+balance) `div` (balance+1) + l <- choose (b, n-1-b) + z <- choose (0, sz) + m <- resize (min z (sz-z)) genFMB_ + v <- case m of E -> Just <$> arbitrary ; _ -> arbitrary + let k = fromIntegral (i+l) + I n k v + <$> resize z (genFMB i l) + <*> pure (FMB' m) + <*> resize (sz - z) (genFMB (i+l+1) (n-l-1)) + +-- Be careful to preserve balance during shrinking. +shrinkFMB :: Arbitrary a => FMB k a -> [FMB k a] +shrinkFMB E = [] +shrinkFMB (I s k v l m r) = E : l : r : do + let (*-) = shrinkTuple ; infixr 3 *- + (v, (l, (m@(FMB' m'), r))) <- (shrinkJust *- shrinkFMB *- shrinkFMB' *- shrinkFMB) (v, (l, (m, r))) + let s = sizeFMB l + sizeFMB r + 1 + t = I s k v l m r + guard (isBalanced l r && (isJust v || not (nullFMB' m))) + pure t + +nullFMB' :: FMB' k v -> Bool +nullFMB' (FMB' E) = True +nullFMB' _ = False + +shrinkFMB' :: Arbitrary a => FMB' k a -> [FMB' k a] +shrinkFMB' (FMB' m) = coerce $ + tailsFMB m ++ shrinkFMB m + +-- List the middle children of the top layer. +tailsFMB :: FMB k a -> [FMB k a] +tailsFMB E = [] +tailsFMB (I _ _ _ l (FMB' m) r) = m : tailsFMB l ++ tailsFMB r + +-- Don't remove elements +shrinkJust :: Arbitrary a => Maybe a -> [Maybe a] +shrinkJust Nothing = [] +shrinkJust (Just x) = Just <$> shrink x + +shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] +shrinkTuple sa sb (a, b) = [(a', b) | a' <- sa a] ++ [(a, b') | b' <- sb b]
src/Data/Edison/Coll/Defaults.hs view
@@ -1,246 +1,249 @@--- |--- Module : Data.Edison.Coll.Defaults--- Copyright : Copyright (c) 1998, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : internal (unstable)--- Portability : GHC / Hugs (MPTC and FD)------ This module provides default implementations of many of the collection methods. The functions--- in this module are used to fill out collection implementations and are not intended to be--- used directly by end users.--module Data.Edison.Coll.Defaults where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import Control.Monad.Identity--import Data.Edison.Coll-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)--insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c-insertSeqUsingUnion xs c = union (fromSeq xs) c--insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c-insertSeqUsingFoldr xs c = S.foldr insert c xs--memberUsingFold :: Coll c a => c -> a -> Bool-memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h--countUsingMember :: SetX c a => a -> c -> Int-countUsingMember x xs = if member x xs then 1 else 0--lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a-lookupAllUsingLookupM x xs =- case lookupM x xs of- Nothing -> S.empty- Just y -> S.singleton y--deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c-deleteSeqUsingDelete xs c = S.foldr delete c xs--unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c-unionSeqUsingFoldl = S.foldl union empty--unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c-unionSeqUsingFoldl' = S.foldl' union empty--unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c-unionSeqUsingReduce = S.reducel union empty--fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c-fromSeqUsingFoldr = S.foldr insert empty--fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c-fromSeqUsingUnionSeq = unionList . S.foldl singleCons []- where singleCons xs x = S.lcons (singleton x) xs--toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a-toSeqUsingFold = fold S.lcons S.empty--unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c-unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x)--toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a-toOrdSeqUsingFoldr = foldr S.lcons S.empty--unsafeFromOrdSeqUsingUnsafeInsertMin ::- (OrdCollX c a,S.Sequence seq) => seq a -> c-unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty--disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool-disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys)- where disj a@(c:cs) b@(d:ds) =- case compare c d of- LT -> disj cs b- EQ -> False- GT -> disj a ds- disj _ _ = True--intersectWitnessUsingToOrdList ::- (OrdColl c a, Monad m) => c -> c -> m (a,a)-intersectWitnessUsingToOrdList as bs = witness (toOrdList as) (toOrdList bs)- where witness a@(x:xs) b@(y:ys) =- case compare x y of- LT -> witness xs b- EQ -> return (x, y)- GT -> witness a ys- -- XXX- witness _ _ = fail $ instanceName as ++ ".intersect: failed"--lookupUsingLookupM :: Coll c a => a -> c -> a-lookupUsingLookupM x ys = runIdentity (lookupM x ys)--lookupUsingLookupAll :: Coll c a => a -> c -> a-lookupUsingLookupAll x ys =- case lookupAll x ys of- (y:_) -> y- [] -> error $ instanceName ys ++ ".lookup: lookup failed"--lookupMUsingLookupAll :: (Coll c a, Monad m) => a -> c -> m a-lookupMUsingLookupAll x ys =- case lookupAll x ys of- (y:_) -> return y- [] -> fail $ instanceName ys ++ ".lookupM: lookup failed"--lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a-lookupWithDefaultUsingLookupAll dflt x ys =- case lookupAll x ys of- (y:_) -> y- [] -> dflt--lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a-lookupWithDefaultUsingLookupM dflt x ys =- case lookupM x ys of- Just y -> y- Nothing -> dflt--deleteMaxUsingMaxView :: OrdColl c a => c -> c-deleteMaxUsingMaxView c =- case maxView c of- Just (_,c') -> c'- Nothing -> c--fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c-fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty--insertUsingInsertWith :: Set c a => a -> c -> c-insertUsingInsertWith = insertWith (\x _ -> x)--unionUsingUnionWith :: Set c a => c -> c -> c-unionUsingUnionWith = unionWith (\x _ -> x)--filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c-filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList--partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c)-partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs)- where (ys,zs) = L.partition p (toOrdList xs)--intersectionUsingIntersectionWith :: Set c a => c -> c -> c-intersectionUsingIntersectionWith = intersectionWith (\x _ -> x)--differenceUsingOrdLists :: OrdSet c a => c -> c -> c-differenceUsingOrdLists as bs = unsafeFromOrdList $ diff (toOrdList as) (toOrdList bs)- where diff a@(x:xs) b@(y:ys) =- case compare x y of- LT -> x : diff xs b- EQ -> diff xs ys- GT -> diff a ys- diff a _ = a--symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c-symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs)--properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool-properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys)--subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool-subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys)--properSubsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool-properSubsetOnOrdLists [] [] = False-properSubsetOnOrdLists [] (_:_) = True-properSubsetOnOrdLists (_:_) [] = False-properSubsetOnOrdLists a@(x:xs) (y:ys) =- case compare x y of- LT -> False- EQ -> properSubsetOnOrdLists xs ys- GT -> subsetOnOrdLists a ys--subsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool-subsetOnOrdLists [] _ = True-subsetOnOrdLists (_:_) [] = False-subsetOnOrdLists a@(x:xs) (y:ys) =- case compare x y of- LT -> False- EQ -> subsetOnOrdLists xs ys- GT -> subsetOnOrdLists a ys--insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c-insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs--unionlUsingUnionWith :: Set c a => c -> c -> c-unionlUsingUnionWith xs ys = unionWith (\x _ -> x) xs ys--unionrUsingUnionWith :: Set c a => c -> c -> c-unionrUsingUnionWith xs ys = unionWith (\_ y -> y) xs ys--unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c-unionWithUsingOrdLists c as bs = unsafeFromOrdList $ merge (toOrdList as) (toOrdList bs)- where merge a@(x:xs) b@(y:ys) =- case compare x y of- LT -> x : merge xs b- EQ -> c x y : merge xs ys- GT -> y : merge a ys- merge a [] = a- merge [] b = b--unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c-unionSeqWithUsingReducer c = S.reducer (unionWith c) empty--intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c-intersectionWithUsingOrdLists c as bs = unsafeFromOrdList $ inter (toOrdList as) (toOrdList bs)- where inter a@(x:xs) b@(y:ys) =- case compare x y of- LT -> inter xs b- EQ -> c x y : inter xs ys- GT -> inter a ys- inter _ _ = []---unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout)-unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs--showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS-showsPrecUsingToList i xs rest- | i == 0 = concat [ instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest]- | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)]--readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c-readsPrecUsingFromList _ xs =- let result = maybeParens p xs- p ys = tokenMatch ((instanceName x) ++ ".fromSeq") ys- >>= readsPrec 10- >>= \(l,rest) -> return (fromList l,rest)-- -- play games with the typechecker so we don't have to use- -- extensions for scoped type variables- ~[(x,_)] = result-- in result--compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering-compareUsingToOrdList as bs = cmp (toOrdList as) (toOrdList bs)- where- cmp [] [] = EQ- cmp [] _ = LT- cmp _ [] = GT- cmp (x:xs) (y:ys) =- case compare x y of- EQ -> cmp xs ys- c -> c-+-- | +-- Module : Data.Edison.Coll.Defaults +-- Copyright : Copyright (c) 1998, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : internal (unstable) +-- Portability : GHC / Hugs (MPTC and FD) +-- +-- This module provides default implementations of many of the collection methods. The functions +-- in this module are used to fill out collection implementations and are not intended to be +-- used directly by end users. + +module Data.Edison.Coll.Defaults where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Control.Monad.Fail as Fail + +import Data.Edison.Prelude ( runFail_ ) +import Data.Edison.Coll +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) + +insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c +insertSeqUsingUnion xs c = union (fromSeq xs) c + +insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c +insertSeqUsingFoldr xs c = S.foldr insert c xs + +memberUsingFold :: Coll c a => c -> a -> Bool +memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h + +countUsingMember :: SetX c a => a -> c -> Int +countUsingMember x xs = if member x xs then 1 else 0 + +lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a +lookupAllUsingLookupM x xs = + case lookupM x xs of + Nothing -> S.empty + Just y -> S.singleton y + +deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c +deleteSeqUsingDelete xs c = S.foldr delete c xs + +unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c +unionSeqUsingFoldl = S.foldl union empty + +unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c +unionSeqUsingFoldl' = S.foldl' union empty + +unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c +unionSeqUsingReduce = S.reducel union empty + +fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c +fromSeqUsingFoldr = S.foldr insert empty + +fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c +fromSeqUsingUnionSeq = unionList . S.foldl singleCons [] + where singleCons xs x = S.lcons (singleton x) xs + +toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a +toSeqUsingFold = fold S.lcons S.empty + +unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c +unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x) + +toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a +toOrdSeqUsingFoldr = foldr S.lcons S.empty + +unsafeFromOrdSeqUsingUnsafeInsertMin :: + (OrdCollX c a,S.Sequence seq) => seq a -> c +unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty + +disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool +disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys) + where disj a@(c:cs) b@(d:ds) = + case compare c d of + LT -> disj cs b + EQ -> False + GT -> disj a ds + disj _ _ = True + +intersectWitnessUsingToOrdList :: + (OrdColl c a, Fail.MonadFail m) => c -> c -> m (a,a) +intersectWitnessUsingToOrdList as bs = witness (toOrdList as) (toOrdList bs) + where witness a@(x:xs) b@(y:ys) = + case compare x y of + LT -> witness xs b + EQ -> return (x, y) + GT -> witness a ys + -- XXX + witness _ _ = fail $ instanceName as ++ ".intersect: failed" + +lookupUsingLookupM :: Coll c a => a -> c -> a +lookupUsingLookupM x ys = runFail_ (lookupM x ys) + +lookupUsingLookupAll :: Coll c a => a -> c -> a +lookupUsingLookupAll x ys = + case lookupAll x ys of + (y:_) -> y + [] -> error $ instanceName ys ++ ".lookup: lookup failed" + +lookupMUsingLookupAll :: (Coll c a, Fail.MonadFail m) => a -> c -> m a +lookupMUsingLookupAll x ys = + case lookupAll x ys of + (y:_) -> return y + [] -> fail $ instanceName ys ++ ".lookupM: lookup failed" + +lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a +lookupWithDefaultUsingLookupAll dflt x ys = + case lookupAll x ys of + (y:_) -> y + [] -> dflt + +lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a +lookupWithDefaultUsingLookupM dflt x ys = + case lookupM x ys of + Just y -> y + Nothing -> dflt + +deleteMaxUsingMaxView :: OrdColl c a => c -> c +deleteMaxUsingMaxView c = + case maxView c of + Just (_,c') -> c' + Nothing -> c + +fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c +fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty + +insertUsingInsertWith :: Set c a => a -> c -> c +insertUsingInsertWith = insertWith (\x _ -> x) + +unionUsingUnionWith :: Set c a => c -> c -> c +unionUsingUnionWith = unionWith (\x _ -> x) + +filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c +filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList + +partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c) +partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs) + where (ys,zs) = L.partition p (toOrdList xs) + +intersectionUsingIntersectionWith :: Set c a => c -> c -> c +intersectionUsingIntersectionWith = intersectionWith (\x _ -> x) + +differenceUsingOrdLists :: OrdSet c a => c -> c -> c +differenceUsingOrdLists as bs = unsafeFromOrdList $ diff (toOrdList as) (toOrdList bs) + where diff a@(x:xs) b@(y:ys) = + case compare x y of + LT -> x : diff xs b + EQ -> diff xs ys + GT -> diff a ys + diff a _ = a + +symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c +symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs) + +properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool +properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys) + +subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool +subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys) + +properSubsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool +properSubsetOnOrdLists [] [] = False +properSubsetOnOrdLists [] (_:_) = True +properSubsetOnOrdLists (_:_) [] = False +properSubsetOnOrdLists a@(x:xs) (y:ys) = + case compare x y of + LT -> False + EQ -> properSubsetOnOrdLists xs ys + GT -> subsetOnOrdLists a ys + +subsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool +subsetOnOrdLists [] _ = True +subsetOnOrdLists (_:_) [] = False +subsetOnOrdLists a@(x:xs) (y:ys) = + case compare x y of + LT -> False + EQ -> subsetOnOrdLists xs ys + GT -> subsetOnOrdLists a ys + +insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c +insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs + +unionlUsingUnionWith :: Set c a => c -> c -> c +unionlUsingUnionWith xs ys = unionWith (\x _ -> x) xs ys + +unionrUsingUnionWith :: Set c a => c -> c -> c +unionrUsingUnionWith xs ys = unionWith (\_ y -> y) xs ys + +unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c +unionWithUsingOrdLists c as bs = unsafeFromOrdList $ merge (toOrdList as) (toOrdList bs) + where merge a@(x:xs) b@(y:ys) = + case compare x y of + LT -> x : merge xs b + EQ -> c x y : merge xs ys + GT -> y : merge a ys + merge a [] = a + merge [] b = b + +unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c +unionSeqWithUsingReducer c = S.reducer (unionWith c) empty + +intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c +intersectionWithUsingOrdLists c as bs = unsafeFromOrdList $ inter (toOrdList as) (toOrdList bs) + where inter a@(x:xs) b@(y:ys) = + case compare x y of + LT -> inter xs b + EQ -> c x y : inter xs ys + GT -> inter a ys + inter _ _ = [] + + +unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout) +unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs + +showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS +showsPrecUsingToList i xs rest + | i == 0 = concat [ instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest] + | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)] + +readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c +readsPrecUsingFromList _ xs = + let result = maybeParens p xs + p ys = tokenMatch ((instanceName x) ++ ".fromSeq") ys + >>= readsPrec 10 + >>= \(l,rest) -> return (fromList l,rest) + + -- play games with the typechecker so we don't have to use + -- extensions for scoped type variables + x = case result of + [(x',_)] -> x' + _ -> undefined + + in result + +compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering +compareUsingToOrdList as bs = cmp (toOrdList as) (toOrdList bs) + where + cmp [] [] = EQ + cmp [] _ = LT + cmp _ [] = GT + cmp (x:xs) (y:ys) = + case compare x y of + EQ -> cmp xs ys + c -> c +
src/Data/Edison/Coll/EnumSet.hs view
@@ -1,798 +1,808 @@--------------------------------------------------------------------------------- |--- Module : Data.Edison.Coll.EnumSet--- Copyright : (c) David F. Place 2006--- License : BSD------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ An efficient implementation of sets over small enumerations.--- The implementation of 'EnumSet' is based on bit-wise operations.------ For this implementation to work as expected at type @A@, there are a number--- of preconditions on the @Eq@, @Enum@ and @Ord@ instances.------ The @Enum A@ instance must create a bijection between the elements of type @A@ and--- a finite subset of the naturals [0,1,2,3....]. As a corollary we must have:------ > forall x y::A, fromEnum x == fromEnum y <==> x is indistinguishable from y------ Also, the number of distinct elements of @A@ must be less than or equal--- to the number of bits in @Word@.------ The @Enum A@ instance must be consistent with the @Eq A@ instance.--- That is, we must have:------ > forall x y::A, x == y <==> toEnum x == toEnum y------ Additionally, for operations that require an @Ord A@ context, we require that--- toEnum be monotonic with respect to comparison. That is, we must have:------ > forall x y::A, x < y <==> toEnum x < toEnum y------ Derived @Eq@, @Ord@ and @Enum@ instances will fulfill these conditions, if--- the enumerated type has sufficently few constructors.--{--Copyright (c) 2006, 2008, David F. Place-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:---* Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.--* Redistributions in binary form must reproduce the above copyright- notice, this list of conditions and the following disclaimer in- the documentation and/or other materials provided with the- distribution.--* Neither the name of David F. Place nor the names of its- contributors may be used to endorse or promote products derived from- this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--}--module Data.Edison.Coll.EnumSet (- -- * Set type- Set-- -- * CollX operations- , empty- , singleton- , fromSeq- , insert- , insertSeq- , union- , unionSeq- , delete- , deleteAll- , deleteSeq- , null- , size- , member- , count- , strict-- -- * OrdCollX operations- , deleteMin- , deleteMax- , unsafeInsertMin- , unsafeInsertMax- , unsafeFromOrdSeq- , unsafeAppend- , filterLT- , filterLE- , filterGT- , filterGE- , partitionLT_GE- , partitionLE_GT- , partitionLT_GT-- -- * SetX operations- , intersection- , difference- , symmetricDifference- , properSubset- , subset-- -- * Coll operations- , toSeq- , lookup- , lookupM- , lookupAll- , lookupWithDefault- , fold, fold', fold1, fold1'- , filter- , partition- , strictWith-- -- * OrdColl operations- , minView- , minElem- , maxView- , maxElem- , foldr, foldr', foldl, foldl'- , foldr1, foldr1', foldl1, foldl1'- , toOrdSeq- , unsafeMapMonotonic-- -- * Set operations- , fromSeqWith- , fromOrdSeq- , insertWith- , insertSeqWith- , unionl- , unionr- , unionWith- , unionSeqWith- , intersectionWith-- -- * Bonus operations- , map- , setCoerce- , complement- , toBits- , fromBits-- -- * Documenation- , moduleName-) where--import qualified Prelude-import Prelude hiding (filter,foldl,foldr,null,map,lookup,foldl1,foldr1)-import qualified Data.Bits as Bits-import Data.Bits hiding (complement)-import Data.Word-import Data.Monoid (Monoid(..))--import qualified Data.Edison.Seq as S-import qualified Data.Edison.Coll as C-import Data.Edison.Coll.Defaults-import Test.QuickCheck (Arbitrary(..), CoArbitrary(..))--moduleName :: String-moduleName = "Data.Edison.Coll.EnumSet"--{--------------------------------------------------------------------- Sets are bit strings of width wordLength.---------------------------------------------------------------------}--- | A set of values @a@ implemented as bitwise operations. Useful--- for members of class Enum with no more elements than there are bits--- in @Word@.-newtype Set a = Set Word deriving (Eq)--wordLength :: Int-wordLength = bitSize (0::Word)--check :: String -> Int -> Int-check msg x- | x < wordLength = x- | otherwise = error $ "EnumSet."++msg++": element beyond word size."----- no interesting structural invariants-structuralInvariant :: Set a -> Bool-structuralInvariant = const True---------------------------------------------------------- bit twiddly magic--countBits :: Word -> Int-countBits w = w `seq` bitcount 0 w--bitcount :: Int -> Word -> Int-bitcount a 0 = a-bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1))---- stolen from http://aggregate.org/MAGIC/-lsb :: Word -> Int-lsb x = countBits ((x-1) .&. (Bits.complement x))--msb :: Word -> Int-msb x0 = let- x1 = x0 .|. (x0 `shiftR` 1)- x2 = x1 .|. (x1 `shiftR` 2)- x3 = x2 .|. (x2 `shiftR` 4)- x4 = x3 .|. (x3 `shiftR` 8)- x5 = x4 .|. (x4 `shiftR` 16)- in countBits x5 - 1---lowMask :: Int -> Word-lowMask x = bit x - 1--highMask :: Int -> Word-highMask x = Bits.complement (lowMask x)--{--------------------------------------------------------------------- Query---------------------------------------------------------------------}--- | /O(1)/. Is this the empty set?-null :: Set a -> Bool-null (Set 0) = True-null _ = False---- | /O(1)/. The number of elements in the set.-size :: Set a -> Int-size (Set w) = countBits w---- | /O(1)/. Is the element in the set?-member :: (Eq a, Enum a) => a -> Set a -> Bool-member x (Set w) = testBit w $ fromEnum x--count :: (Eq a, Enum a) => a -> Set a -> Int-count = countUsingMember--lookup :: (Eq a, Enum a) => a -> Set a -> a-lookup = lookupUsingLookupAll--lookupM :: (Eq a, Enum a, Monad m) => a -> Set a -> m a-lookupM x s- | member x s = return x- | otherwise = fail (moduleName++".lookupM: lookup failed")--lookupAll :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a-lookupAll = lookupAllUsingLookupM--lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--{--------------------------------------------------------------------- Construction---------------------------------------------------------------------}--- | /O(1)/. The empty set.-empty :: Set a-empty = Set 0---- | /O(1)/. Create a singleton set.-singleton :: (Eq a, Enum a) => a -> Set a-singleton x =- Set $ setBit 0 $ check "singleton" $ fromEnum x--{--------------------------------------------------------------------- Insertion, Deletion---------------------------------------------------------------------}--- | /O(1)/. Insert an element in a set.--- If the set already contains an element equal to the given value,--- it is replaced with the new value.-insert :: (Eq a, Enum a) => a -> Set a -> Set a-insert x (Set w) =- Set $ setBit w $ check "insert" $ fromEnum x---- given the preconditions, we can just ignore the combining function-insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a-insertWith _ x (Set w) =- Set $ setBit w $ check "insertWith" $ fromEnum x---- | /O(1)/. Delete an element from a set.-delete :: (Eq a, Enum a) => a -> Set a -> Set a-delete x (Set w) =- Set $ clearBit w $ fromEnum x--deleteAll :: (Eq a, Enum a) => a -> Set a -> Set a-deleteAll = delete--deleteSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a-deleteSeq = deleteSeqUsingDelete--{--------------------------------------------------------------------- Subset---------------------------------------------------------------------}--- | /O(1)/. Is this a proper subset? (ie. a subset but not equal).-properSubset :: Set a -> Set a -> Bool-properSubset x y = (x /= y) && (subset x y)---- | /O(1)/. Is this a subset?--- @(s1 `subset` s2)@ tells whether @s1@ is a subset of @s2@.-subset :: Set a -> Set a -> Bool-subset x y = (x `union` y) == y--{--------------------------------------------------------------------- Minimal, Maximal---------------------------------------------------------------------}---- | /O(1)/. The minimal element of a set.-minElem :: (Enum a) => Set a -> a-minElem (Set w)- | w == 0 = error $ moduleName++".minElem: empty set"- | otherwise = toEnum $ lsb w---- | /O(1)/. The maximal element of a set.-maxElem :: (Enum a) => Set a -> a-maxElem (Set w)- | w == 0 = error $ moduleName++".maxElem: empty set"- | otherwise = toEnum $ msb w---- | /O(1)/. Delete the minimal element.-deleteMin :: (Enum a) => Set a -> Set a-deleteMin (Set w)- | w == 0 = empty- | otherwise = Set $ clearBit w $ lsb w---- | /O(1)/. Delete the maximal element.-deleteMax :: (Enum a) => Set a -> Set a-deleteMax (Set w)- | w == 0 = empty- | otherwise = Set $ clearBit w $ msb w--minView :: (Enum a, Monad m) => Set a -> m (a, Set a)-minView (Set w)- | w == 0 = fail (moduleName++".minView: empty set")- | otherwise = let i = lsb w in return (toEnum i,Set $ clearBit w i)--maxView :: (Enum a, Monad m) => Set a -> m (a, Set a)-maxView (Set w)- | w == 0 = fail (moduleName++".maxView: empty set")- | otherwise = let i = msb w in return (toEnum i, Set $ clearBit w i)--unsafeInsertMin :: (Ord a, Enum a) => a -> Set a -> Set a-unsafeInsertMin = insert--unsafeInsertMax :: (Ord a, Enum a) => a -> Set a -> Set a-unsafeInsertMax = insert--unsafeAppend :: (Ord a, Enum a) => Set a -> Set a -> Set a-unsafeAppend = union--unsafeFromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a-unsafeFromOrdSeq = fromSeq--filterLT :: (Ord a, Enum a) => a -> Set a -> Set a-filterLT x (Set w) = Set (w .&. lowMask (fromEnum x))--filterLE :: (Ord a, Enum a) => a -> Set a -> Set a-filterLE x (Set w) = Set (w .&. lowMask (fromEnum x + 1))--filterGT :: (Ord a, Enum a) => a -> Set a -> Set a-filterGT x (Set w) = Set (w .&. highMask (fromEnum x + 1))--filterGE :: (Ord a, Enum a) => a -> Set a -> Set a-filterGE x (Set w) = Set (w .&. highMask (fromEnum x))--partitionLT_GE :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)-partitionLT_GE x s = (filterLT x s,filterGE x s)--partitionLE_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)-partitionLE_GT x s = (filterLE x s,filterGT x s)--partitionLT_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a)-partitionLT_GT x s = (filterLT x s,filterGT x s)---{--------------------------------------------------------------------- Union.---------------------------------------------------------------------}--- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@).-unionSeq :: (Eq a, Enum a, S.Sequence s) => s (Set a) -> Set a-unionSeq = unionSeqUsingFoldl'---- | /O(1)/. The union of two sets.-union :: Set a -> Set a -> Set a-union (Set x) (Set y) = Set $ x .|. y--unionl :: Set a -> Set a -> Set a-unionl = union--unionr :: Set a -> Set a -> Set a-unionr = union---- given the preconditions, we can just ignore the combining function-unionWith :: (a -> a -> a) -> Set a -> Set a -> Set a-unionWith _ = union--unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a-unionSeqWith _ = unionSeq--{--------------------------------------------------------------------- Difference---------------------------------------------------------------------}--- | /O(1)/. Difference of two sets.-difference :: Set a -> Set a -> Set a-difference (Set x) (Set y) = Set $ (x .|. y) `xor` y--symmetricDifference :: Set a -> Set a -> Set a-symmetricDifference (Set x) (Set y) = Set $ x `xor` y--{--------------------------------------------------------------------- Intersection---------------------------------------------------------------------}--- | /O(1)/. The intersection of two sets.-intersection :: Set a -> Set a -> Set a-intersection (Set x) (Set y) = Set $ x .&. y--intersectionWith :: (a -> a -> a) -> Set a -> Set a -> Set a-intersectionWith _ = intersection--{--------------------------------------------------------------------- Complement---------------------------------------------------------------------}--- | /O(1)/. The complement of a set with its universe set. @complement@ can be used--- with bounded types for which the universe set--- will be automatically created.-complement :: (Eq a, Bounded a, Enum a) => Set a -> Set a-complement x = symmetricDifference u x- where u = (fromSeq [minBound .. maxBound]) `asTypeOf` x--{--------------------------------------------------------------------- Filter and partition---------------------------------------------------------------------}--- | /O(n)/. Filter all elements that satisfy the predicate.-filter :: (Eq a, Enum a) => (a -> Bool) -> Set a -> Set a-filter p (Set w) = Set $ foldlBits' f 0 w- where- f z i- | p $ toEnum i = setBit z i- | otherwise = z---- | /O(n)/. Partition the set into two sets, one with all elements that satisfy--- the predicate and one with all elements that don't satisfy the predicate.--- See also 'split'.-partition :: (Eq a, Enum a) => (a -> Bool) -> Set a -> (Set a,Set a)-partition p (Set w) = (Set yay,Set nay)- where- (yay,nay) = foldlBits' f (0,0) w- f (x,y) i- | p $ toEnum i = (setBit x i,y)- | otherwise = (x,setBit y i)---{----------------------------------------------------------------------- Map-----------------------------------------------------------------------}--- | /O(n)/.--- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.------ It's worth noting that the size of the result may be smaller if,--- for some @(x,y)@, @x \/= y && f x == f y@-map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b-map f0 (Set w) = Set $ foldlBits' f 0 w- where- f z i = setBit z $ check "map" $ fromEnum $ f0 (toEnum i)--unsafeMapMonotonic :: (Enum a) => (a -> a) -> Set a -> Set a-unsafeMapMonotonic = map---- | /O(1)/ Changes the type of the elements in the set without changing--- the representation. Equivalant to @map (toEnum . fromEnum)@, and--- to @(fromBits . toBits)@. This method is operationally a no-op.-setCoerce :: (Enum a, Enum b) => Set a -> Set b-setCoerce (Set w) = Set w---- | /O(1)/ Get the underlying bit-encoded representation.--- This method is operationally a no-op.-toBits :: Set a -> Word-toBits (Set w) = w---- | /O(1)/ Create an EnumSet from a bit-encoded representation.--- This method is operationally a no-op.-fromBits :: Word -> Set a-fromBits w = Set w---{--------------------------------------------------------------------- Fold---------------------------------------------------------------------}--fold :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c-fold f z (Set w) = foldrBits folder z w- where folder i = f (toEnum i)--fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c-fold' f z (Set w) = foldrBits' folder z w- where folder i = f (toEnum i)--fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a-fold1 _ (Set 0) = error (moduleName++".fold1: empty set")-fold1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)- where- maxi = msb w- folder i z = f (toEnum i) z--fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a-fold1' _ (Set 0) = error (moduleName++".fold1': empty set")-fold1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)- where- maxi = msb w- folder i z = f (toEnum i) z--foldr :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b-foldr f z (Set w) = foldrBits folder z w- where folder i = f (toEnum i)--foldr' :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b-foldr' f z (Set w) = foldrBits' folder z w- where folder i j = f (toEnum i) j--foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldr1 _ (Set 0) = error (moduleName ++ ".foldr1: empty set")-foldr1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)- where- maxi = msb w- folder i z = f (toEnum i) z--foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldr1' _ (Set 0) = error (moduleName++".foldr1': empty set")-foldr1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi)- where- maxi = msb w- folder i z = f (toEnum i) z--foldl :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c-foldl f z (Set w) = foldlBits folder z w- where folder h i = f h (toEnum i)--foldl' :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c-foldl' f z (Set w) = foldlBits' folder z w- where folder h i = f h (toEnum i)--foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldl1 _ (Set 0) = error (moduleName++".foldl1: empty set")-foldl1 f (Set w) = foldlBits folder (toEnum mininum) (clearBit w mininum)- where- mininum = lsb w- folder z i = f z (toEnum i)--foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a-foldl1' _ (Set 0) = error (moduleName++".foldl1': empty set")-foldl1' f (Set w) = foldlBits' folder (toEnum mininum) (clearBit w mininum)- where- mininum = lsb w- folder z i = f z (toEnum i)--{--------------------------------------------------------------------- Lists---------------------------------------------------------------------}-fromSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a-fromSeq xs = Set $ S.fold' f 0 xs- where f x z = setBit z $ check "fromSeq" $ fromEnum x--fromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a-fromOrdSeq = fromSeq--insertSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a-insertSeq = insertSeqUsingUnion---- given the preconditions, we can just ignore the combining function-insertSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a -> Set a-insertSeqWith _ = insertSeq--toSeq :: (Eq a, Enum a, S.Sequence s) => Set a -> s a-toSeq (Set w) = foldrBits f S.empty w- where f i z = S.lcons (toEnum i) z--toOrdSeq :: (Ord a, Enum a, S.Sequence s) => Set a -> s a-toOrdSeq = toSeq--fromSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a-fromSeqWith = fromSeqWithUsingInsertWith---{--------------------------------------------------------------------- Split---------------------------------------------------------------------}-{--splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a)-splitMember x (Set w) = (Set lesser,isMember,Set greater)- where- (lesser,isMember,greater) = foldrBits f (0,False,0) w- f i (lesser,isMember,greater) =- case compare (toEnum i) x of- GT -> (lesser,isMember,setBit greater i)- LT -> (setBit lesser i,isMember,greater)- EQ -> (lesser,True,greater)--}---{----------------------------------------------------------------- Strictness enhancement-----------------------------------------------------------------}--strict :: Set a -> Set a-strict s@(Set w) = w `seq` s--strictWith :: (a -> b) -> Set a -> Set a-strictWith _ s@(Set w) = w `seq` s--{--------------------------------------------------------------------- Utility functions.---------------------------------------------------------------------}--foldrBits :: (Int -> a -> a) -> a -> Word -> a-foldrBits f z w = foldrBits_aux f z 0 w--foldrBits_aux :: (Int -> a -> a) -> a -> Int -> Word -> a-foldrBits_aux _ z _ 0 = z-foldrBits_aux f z i w- | i `seq` w `seq` False = undefined- | otherwise =- case w .&. 0x0F of- 0x00 -> a- 0x01 -> f i $ a- 0x02 -> f (i+1) $ a- 0x03 -> f i $ f (i+1) $ a- 0x04 -> f (i+2) $ a- 0x05 -> f i $ f (i+2) $ a- 0x06 -> f (i+1) $ f (i+2) $ a- 0x07 -> f i $ f (i+1) $ f (i+2) $ a- 0x08 -> f (i+3) $ a- 0x09 -> f i $ f (i+3) $ a- 0x0A -> f (i+1) $ f (i+3) $ a- 0x0B -> f i $ f (i+1) $ f (i+3) $ a- 0x0C -> f (i+2) $ f (i+3) $ a- 0x0D -> f i $ f (i+2) $ f (i+3) $ a- 0x0E -> f (i+1) $ f (i+2) $ f (i+3) $ a- 0x0F -> f i $ f (i+1) $ f (i+2) $ f (i+3) $ a- _ -> error "bug in foldrBits_aux"-- where a = foldrBits_aux f z (i+4) (Bits.shiftR w 4)---foldrBits' :: (Int -> a -> a) -> a -> Word -> a-foldrBits' f z w = foldrBits_aux' f z 0 w--foldrBits_aux' :: (Int -> a -> a) -> a -> Int -> Word -> a-foldrBits_aux' _ z _ 0 = z-foldrBits_aux' f z i w- | i `seq` w `seq` False = undefined- | otherwise =- case w .&. 0x0F of- 0x00 -> a- 0x01 -> f i $! a- 0x02 -> f (i+1) $! a- 0x03 -> f i $! f (i+1) $! a- 0x04 -> f (i+2) $! a- 0x05 -> f i $! f (i+2) $! a- 0x06 -> f (i+1) $! f (i+2) $! a- 0x07 -> f i $! f (i+1) $! f (i+2) $! a- 0x08 -> f (i+3) $! a- 0x09 -> f i $! f (i+3) $! a- 0x0A -> f (i+1) $! f (i+3) $! a- 0x0B -> f i $! f (i+1) $! f (i+3) $! a- 0x0C -> f (i+2) $! f (i+3) $! a- 0x0D -> f i $! f (i+2) $! f (i+3) $! a- 0x0E -> f (i+1) $! f (i+2) $! f (i+3) $! a- 0x0F -> f i $! f (i+1) $! f (i+2) $! f (i+3) $! a- _ -> error "bug in foldrBits_aux'"-- where a = foldrBits_aux' f z (i+4) (Bits.shiftR w 4)---foldlBits :: (a -> Int -> a) -> a -> Word -> a-foldlBits f z w = foldlBits_aux f z 0 w--foldlBits_aux :: (a -> Int -> a) -> a -> Int -> Word -> a-foldlBits_aux _ z _ 0 = z-foldlBits_aux f z i w- | i `seq` w `seq` False = undefined- | otherwise =- case w .&. 0x0F of- 0x00 -> a $ z- 0x01 -> a $ f z i- 0x02 -> a $ f z (i+1)- 0x03 -> a $ f (f z i) (i+1)- 0x04 -> a $ f z (i+2)- 0x05 -> a $ f (f z i) (i+2)- 0x06 -> a $ f (f z (i+1)) (i+2)- 0x07 -> a $ f (f (f z i) (i+1)) (i+2)- 0x08 -> a $ f z (i+3)- 0x09 -> a $ f (f z i) (i+3)- 0x0A -> a $ f (f z (i+1)) (i+3)- 0x0B -> a $ f (f (f z i) (i+1)) (i+3)- 0x0C -> a $ f (f z (i+2)) (i+3)- 0x0D -> a $ f (f (f z i) (i+2)) (i+3)- 0x0E -> a $ f (f (f z (i+1)) (i+2)) (i+3)- 0x0F -> a $ f (f (f (f z i) (i+1)) (i+2)) (i+3)- _ -> error "bug in foldlBits_aux"-- where a b = foldlBits_aux f b (i + 4) (Bits.shiftR w 4)--foldlBits' :: (a -> Int -> a) -> a -> Word -> a-foldlBits' f z w = foldlBits_aux' (\x i -> x `seq` f x i) z 0 w--foldlBits_aux' :: (a -> Int -> a) -> a -> Int -> Word -> a-foldlBits_aux' _ z _ 0 = z-foldlBits_aux' f z i w- | i `seq` w `seq` False = undefined- | otherwise =- case w .&. 0x0F of- 0x00 -> a $! z- 0x01 -> a $! f z i- 0x02 -> a $! f z (i+1)- 0x03 -> a $! f (f z i) (i+1)- 0x04 -> a $! f z (i+2)- 0x05 -> a $! f (f z i) (i+2)- 0x06 -> a $! f (f z (i+1)) (i+2)- 0x07 -> a $! f (f (f z i) (i+1)) (i+2)- 0x08 -> a $! f z (i+3)- 0x09 -> a $! f (f z i) (i+3)- 0x0A -> a $! f (f z (i+1)) (i+3)- 0x0B -> a $! f (f (f z i) (i+1)) (i+3)- 0x0C -> a $! f (f z (i+2)) (i+3)- 0x0D -> a $! f (f (f z i) (i+2)) (i+3)- 0x0E -> a $! f (f (f z (i+1)) (i+2)) (i+3)- 0x0F -> a $! f (f (f (f z i) (i+1)) (i+2)) (i+3)- _ -> error "bug in foldlBits_aux"-- where a b = foldlBits_aux' f b (i + 4) (Bits.shiftR w 4)--instance (Eq a, Enum a) => C.CollX (Set a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance (Ord a, Enum a) => C.OrdCollX (Set a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance (Eq a, Enum a) => C.SetX (Set a) a where- {intersection = intersection; difference = difference;- symmetricDifference = symmetricDifference;- properSubset = properSubset; subset = subset}--instance (Eq a, Enum a) => C.Coll (Set a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance (Ord a, Enum a) => C.OrdColl (Set a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr';- foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';- foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;- unsafeMapMonotonic = unsafeMapMonotonic}--instance (Eq a, Enum a) => C.Set (Set a) a where- {fromSeqWith = fromSeqWith; insertWith = insertWith;- insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;- unionWith = unionWith; unionSeqWith = unionSeqWith;- intersectionWith = intersectionWith}--instance (Ord a, Enum a) => C.OrdSetX (Set a) a-instance (Ord a, Enum a) => C.OrdSet (Set a) a--instance (Eq a, Enum a, Show a) => Show (Set a) where- showsPrec = showsPrecUsingToList--instance (Eq a, Enum a, Read a) => Read (Set a) where- readsPrec = readsPrecUsingFromList--instance (Eq a, Enum a, Arbitrary a) => Arbitrary (Set a) where- arbitrary = do (w::Int) <- arbitrary- return (Set (fromIntegral w))--instance (Eq a, Enum a, CoArbitrary a) => CoArbitrary (Set a) where- coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int)--instance (Eq a, Enum a) => Monoid (Set a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Ord a, Enum a) => Ord (Set a) where- compare = compareUsingToOrdList+----------------------------------------------------------------------------- +-- | +-- Module : Data.Edison.Coll.EnumSet +-- Copyright : (c) David F. Place 2006 +-- License : BSD +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- An efficient implementation of sets over small enumerations. +-- The implementation of 'EnumSet' is based on bit-wise operations. +-- +-- For this implementation to work as expected at type @A@, there are a number +-- of preconditions on the @Eq@, @Enum@ and @Ord@ instances. +-- +-- The @Enum A@ instance must create a bijection between the elements of type @A@ and +-- a finite subset of the naturals [0,1,2,3....]. As a corollary we must have: +-- +-- > forall x y::A, fromEnum x == fromEnum y <==> x is indistinguishable from y +-- +-- Also, the number of distinct elements of @A@ must be less than or equal +-- to the number of bits in @Word@. +-- +-- The @Enum A@ instance must be consistent with the @Eq A@ instance. +-- That is, we must have: +-- +-- > forall x y::A, x == y <==> toEnum x == toEnum y +-- +-- Additionally, for operations that require an @Ord A@ context, we require that +-- toEnum be monotonic with respect to comparison. That is, we must have: +-- +-- > forall x y::A, x < y <==> toEnum x < toEnum y +-- +-- Derived @Eq@, @Ord@ and @Enum@ instances will fulfill these conditions, if +-- the enumerated type has sufficiently few constructors. + +{- +Copyright (c) 2006, 2008, David F. Place +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + +* Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + +* Neither the name of David F. Place nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-} + +module Data.Edison.Coll.EnumSet ( + -- * Set type + Set + + -- * CollX operations + , empty + , singleton + , fromSeq + , insert + , insertSeq + , union + , unionSeq + , delete + , deleteAll + , deleteSeq + , null + , size + , member + , count + , strict + + -- * OrdCollX operations + , deleteMin + , deleteMax + , unsafeInsertMin + , unsafeInsertMax + , unsafeFromOrdSeq + , unsafeAppend + , filterLT + , filterLE + , filterGT + , filterGE + , partitionLT_GE + , partitionLE_GT + , partitionLT_GT + + -- * SetX operations + , intersection + , difference + , symmetricDifference + , properSubset + , subset + + -- * Coll operations + , toSeq + , lookup + , lookupM + , lookupAll + , lookupWithDefault + , fold, fold', fold1, fold1' + , filter + , partition + , strictWith + + -- * OrdColl operations + , minView + , minElem + , maxView + , maxElem + , foldr, foldr', foldl, foldl' + , foldr1, foldr1', foldl1, foldl1' + , toOrdSeq + , unsafeMapMonotonic + + -- * Set operations + , fromSeqWith + , fromOrdSeq + , insertWith + , insertSeqWith + , unionl + , unionr + , unionWith + , unionSeqWith + , intersectionWith + + -- * Bonus operations + , map + , setCoerce + , complement + , toBits + , fromBits + + -- * Documentation + , moduleName +) where + +import qualified Prelude +import Prelude hiding (filter,foldl,foldr,null,map,lookup,foldl1,foldr1,foldl') +import qualified Control.Monad.Fail as Fail +import qualified Data.Bits as Bits +import Data.Bits hiding (complement) +import Data.Word +import Data.Monoid (Monoid(..)) +import Data.Semigroup as SG + +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Coll as C +import Data.Edison.Coll.Defaults +import Test.QuickCheck (Arbitrary(..), CoArbitrary(..)) + +moduleName :: String +moduleName = "Data.Edison.Coll.EnumSet" + +{-------------------------------------------------------------------- + Sets are bit strings of width wordLength. +--------------------------------------------------------------------} +-- | A set of values @a@ implemented as bitwise operations. Useful +-- for members of class Enum with no more elements than there are bits +-- in @Word@. +newtype Set a = Set Word deriving (Eq) + +wordLength :: Int +wordLength = +#if MIN_VERSION_base(4,7,0) + finiteBitSize +#else + bitSize +#endif + (0::Word) + +check :: String -> Int -> Int +check msg x + | x < wordLength = x + | otherwise = error $ "EnumSet."++msg++": element beyond word size." + + +-- no interesting structural invariants +structuralInvariant :: Set a -> Bool +structuralInvariant = const True + + +---------------------------------------------------- +-- bit twiddly magic + +countBits :: Word -> Int +countBits w = w `seq` bitcount 0 w + +bitcount :: Int -> Word -> Int +bitcount a 0 = a +bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1)) + +-- stolen from http://aggregate.org/MAGIC/ +lsb :: Word -> Int +lsb x = countBits ((x-1) .&. (Bits.complement x)) + +msb :: Word -> Int +msb x0 = let + x1 = x0 .|. (x0 `shiftR` 1) + x2 = x1 .|. (x1 `shiftR` 2) + x3 = x2 .|. (x2 `shiftR` 4) + x4 = x3 .|. (x3 `shiftR` 8) + x5 = x4 .|. (x4 `shiftR` 16) + in countBits x5 - 1 + + +lowMask :: Int -> Word +lowMask x = bit x - 1 + +highMask :: Int -> Word +highMask x = Bits.complement (lowMask x) + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is this the empty set? +null :: Set a -> Bool +null (Set 0) = True +null _ = False + +-- | /O(1)/. The number of elements in the set. +size :: Set a -> Int +size (Set w) = countBits w + +-- | /O(1)/. Is the element in the set? +member :: (Eq a, Enum a) => a -> Set a -> Bool +member x (Set w) = testBit w $ fromEnum x + +count :: (Eq a, Enum a) => a -> Set a -> Int +count = countUsingMember + +lookup :: (Eq a, Enum a) => a -> Set a -> a +lookup = lookupUsingLookupAll + +lookupM :: (Eq a, Enum a, Fail.MonadFail m) => a -> Set a -> m a +lookupM x s + | member x s = return x + | otherwise = fail (moduleName++".lookupM: lookup failed") + +lookupAll :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a +lookupAll = lookupAllUsingLookupM + +lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a +lookupWithDefault = lookupWithDefaultUsingLookupM + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty set. +empty :: Set a +empty = Set 0 + +-- | /O(1)/. Create a singleton set. +singleton :: (Eq a, Enum a) => a -> Set a +singleton x = + Set $ setBit 0 $ check "singleton" $ fromEnum x + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(1)/. Insert an element in a set. +-- If the set already contains an element equal to the given value, +-- it is replaced with the new value. +insert :: (Eq a, Enum a) => a -> Set a -> Set a +insert x (Set w) = + Set $ setBit w $ check "insert" $ fromEnum x + +-- given the preconditions, we can just ignore the combining function +insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a +insertWith _ x (Set w) = + Set $ setBit w $ check "insertWith" $ fromEnum x + +-- | /O(1)/. Delete an element from a set. +delete :: (Eq a, Enum a) => a -> Set a -> Set a +delete x (Set w) = + Set $ clearBit w $ fromEnum x + +deleteAll :: (Eq a, Enum a) => a -> Set a -> Set a +deleteAll = delete + +deleteSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a +deleteSeq = deleteSeqUsingDelete + +{-------------------------------------------------------------------- + Subset +--------------------------------------------------------------------} +-- | /O(1)/. Is this a proper subset? (ie. a subset but not equal). +properSubset :: Set a -> Set a -> Bool +properSubset x y = (x /= y) && (subset x y) + +-- | /O(1)/. Is this a subset? +-- @(s1 `subset` s2)@ tells whether @s1@ is a subset of @s2@. +subset :: Set a -> Set a -> Bool +subset x y = (x `union` y) == y + +{-------------------------------------------------------------------- + Minimal, Maximal +--------------------------------------------------------------------} + +-- | /O(1)/. The minimal element of a set. +minElem :: (Enum a) => Set a -> a +minElem (Set w) + | w == 0 = error $ moduleName++".minElem: empty set" + | otherwise = toEnum $ lsb w + +-- | /O(1)/. The maximal element of a set. +maxElem :: (Enum a) => Set a -> a +maxElem (Set w) + | w == 0 = error $ moduleName++".maxElem: empty set" + | otherwise = toEnum $ msb w + +-- | /O(1)/. Delete the minimal element. +deleteMin :: (Enum a) => Set a -> Set a +deleteMin (Set w) + | w == 0 = empty + | otherwise = Set $ clearBit w $ lsb w + +-- | /O(1)/. Delete the maximal element. +deleteMax :: (Enum a) => Set a -> Set a +deleteMax (Set w) + | w == 0 = empty + | otherwise = Set $ clearBit w $ msb w + +minView :: (Enum a, Fail.MonadFail m) => Set a -> m (a, Set a) +minView (Set w) + | w == 0 = fail (moduleName++".minView: empty set") + | otherwise = let i = lsb w in return (toEnum i,Set $ clearBit w i) + +maxView :: (Enum a, Fail.MonadFail m) => Set a -> m (a, Set a) +maxView (Set w) + | w == 0 = fail (moduleName++".maxView: empty set") + | otherwise = let i = msb w in return (toEnum i, Set $ clearBit w i) + +unsafeInsertMin :: (Ord a, Enum a) => a -> Set a -> Set a +unsafeInsertMin = insert + +unsafeInsertMax :: (Ord a, Enum a) => a -> Set a -> Set a +unsafeInsertMax = insert + +unsafeAppend :: (Ord a, Enum a) => Set a -> Set a -> Set a +unsafeAppend = union + +unsafeFromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a +unsafeFromOrdSeq = fromSeq + +filterLT :: (Ord a, Enum a) => a -> Set a -> Set a +filterLT x (Set w) = Set (w .&. lowMask (fromEnum x)) + +filterLE :: (Ord a, Enum a) => a -> Set a -> Set a +filterLE x (Set w) = Set (w .&. lowMask (fromEnum x + 1)) + +filterGT :: (Ord a, Enum a) => a -> Set a -> Set a +filterGT x (Set w) = Set (w .&. highMask (fromEnum x + 1)) + +filterGE :: (Ord a, Enum a) => a -> Set a -> Set a +filterGE x (Set w) = Set (w .&. highMask (fromEnum x)) + +partitionLT_GE :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a) +partitionLT_GE x s = (filterLT x s,filterGE x s) + +partitionLE_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a) +partitionLE_GT x s = (filterLE x s,filterGT x s) + +partitionLT_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a) +partitionLT_GT x s = (filterLT x s,filterGT x s) + + +{-------------------------------------------------------------------- + Union. +--------------------------------------------------------------------} +-- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). +unionSeq :: (Eq a, Enum a, S.Sequence s) => s (Set a) -> Set a +unionSeq = unionSeqUsingFoldl' + +-- | /O(1)/. The union of two sets. +union :: Set a -> Set a -> Set a +union (Set x) (Set y) = Set $ x .|. y + +unionl :: Set a -> Set a -> Set a +unionl = union + +unionr :: Set a -> Set a -> Set a +unionr = union + +-- given the preconditions, we can just ignore the combining function +unionWith :: (a -> a -> a) -> Set a -> Set a -> Set a +unionWith _ = union + +unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a +unionSeqWith _ = unionSeq + +{-------------------------------------------------------------------- + Difference +--------------------------------------------------------------------} +-- | /O(1)/. Difference of two sets. +difference :: Set a -> Set a -> Set a +difference (Set x) (Set y) = Set $ (x .|. y) `xor` y + +symmetricDifference :: Set a -> Set a -> Set a +symmetricDifference (Set x) (Set y) = Set $ x `xor` y + +{-------------------------------------------------------------------- + Intersection +--------------------------------------------------------------------} +-- | /O(1)/. The intersection of two sets. +intersection :: Set a -> Set a -> Set a +intersection (Set x) (Set y) = Set $ x .&. y + +intersectionWith :: (a -> a -> a) -> Set a -> Set a -> Set a +intersectionWith _ = intersection + +{-------------------------------------------------------------------- + Complement +--------------------------------------------------------------------} +-- | /O(1)/. The complement of a set with its universe set. @complement@ can be used +-- with bounded types for which the universe set +-- will be automatically created. +complement :: (Eq a, Bounded a, Enum a) => Set a -> Set a +complement x = symmetricDifference u x + where u = (fromSeq [minBound .. maxBound]) `asTypeOf` x + +{-------------------------------------------------------------------- + Filter and partition +--------------------------------------------------------------------} +-- | /O(n)/. Filter all elements that satisfy the predicate. +filter :: (Eq a, Enum a) => (a -> Bool) -> Set a -> Set a +filter p (Set w) = Set $ foldlBits' f 0 w + where + f z i + | p $ toEnum i = setBit z i + | otherwise = z + +-- | /O(n)/. Partition the set into two sets, one with all elements that satisfy +-- the predicate and one with all elements that don't satisfy the predicate. +-- See also 'split'. +partition :: (Eq a, Enum a) => (a -> Bool) -> Set a -> (Set a,Set a) +partition p (Set w) = (Set yay,Set nay) + where + (yay,nay) = foldlBits' f (0,0) w + f (x,y) i + | p $ toEnum i = (setBit x i,y) + | otherwise = (x,setBit y i) + + +{---------------------------------------------------------------------- + Map +----------------------------------------------------------------------} +-- | /O(n)/. +-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. +-- +-- It's worth noting that the size of the result may be smaller if, +-- for some @(x,y)@, @x \/= y && f x == f y@ +map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b +map f0 (Set w) = Set $ foldlBits' f 0 w + where + f z i = setBit z $ check "map" $ fromEnum $ f0 (toEnum i) + +unsafeMapMonotonic :: (Enum a) => (a -> a) -> Set a -> Set a +unsafeMapMonotonic = map + +-- | /O(1)/ Changes the type of the elements in the set without changing +-- the representation. Equivalent to @map (toEnum . fromEnum)@, and +-- to @(fromBits . toBits)@. This method is operationally a no-op. +setCoerce :: (Enum a, Enum b) => Set a -> Set b +setCoerce (Set w) = Set w + +-- | /O(1)/ Get the underlying bit-encoded representation. +-- This method is operationally a no-op. +toBits :: Set a -> Word +toBits (Set w) = w + +-- | /O(1)/ Create an EnumSet from a bit-encoded representation. +-- This method is operationally a no-op. +fromBits :: Word -> Set a +fromBits w = Set w + + +{-------------------------------------------------------------------- + Fold +--------------------------------------------------------------------} + +fold :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c +fold f z (Set w) = foldrBits folder z w + where folder i = f (toEnum i) + +fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c +fold' f z (Set w) = foldrBits' folder z w + where folder i = f (toEnum i) + +fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a +fold1 _ (Set 0) = error (moduleName++".fold1: empty set") +fold1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) + where + maxi = msb w + folder i z = f (toEnum i) z + +fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a +fold1' _ (Set 0) = error (moduleName++".fold1': empty set") +fold1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) + where + maxi = msb w + folder i z = f (toEnum i) z + +foldr :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b +foldr f z (Set w) = foldrBits folder z w + where folder i = f (toEnum i) + +foldr' :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b +foldr' f z (Set w) = foldrBits' folder z w + where folder i j = f (toEnum i) j + +foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldr1 _ (Set 0) = error (moduleName ++ ".foldr1: empty set") +foldr1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) + where + maxi = msb w + folder i z = f (toEnum i) z + +foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldr1' _ (Set 0) = error (moduleName++".foldr1': empty set") +foldr1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) + where + maxi = msb w + folder i z = f (toEnum i) z + +foldl :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c +foldl f z (Set w) = foldlBits folder z w + where folder h i = f h (toEnum i) + +foldl' :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c +foldl' f z (Set w) = foldlBits' folder z w + where folder h i = f h (toEnum i) + +foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldl1 _ (Set 0) = error (moduleName++".foldl1: empty set") +foldl1 f (Set w) = foldlBits folder (toEnum minimum) (clearBit w minimum) + where + minimum = lsb w + folder z i = f z (toEnum i) + +foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldl1' _ (Set 0) = error (moduleName++".foldl1': empty set") +foldl1' f (Set w) = foldlBits' folder (toEnum minimum) (clearBit w minimum) + where + minimum = lsb w + folder z i = f z (toEnum i) + +{-------------------------------------------------------------------- + Lists +--------------------------------------------------------------------} +fromSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a +fromSeq xs = Set $ S.fold' f 0 xs + where f x z = setBit z $ check "fromSeq" $ fromEnum x + +fromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a +fromOrdSeq = fromSeq + +insertSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a +insertSeq = insertSeqUsingUnion + +-- given the preconditions, we can just ignore the combining function +insertSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a -> Set a +insertSeqWith _ = insertSeq + +toSeq :: (Eq a, Enum a, S.Sequence s) => Set a -> s a +toSeq (Set w) = foldrBits f S.empty w + where f i z = S.lcons (toEnum i) z + +toOrdSeq :: (Ord a, Enum a, S.Sequence s) => Set a -> s a +toOrdSeq = toSeq + +fromSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a +fromSeqWith = fromSeqWithUsingInsertWith + + +{-------------------------------------------------------------------- + Split +--------------------------------------------------------------------} +{- +splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a) +splitMember x (Set w) = (Set lesser,isMember,Set greater) + where + (lesser,isMember,greater) = foldrBits f (0,False,0) w + f i (lesser,isMember,greater) = + case compare (toEnum i) x of + GT -> (lesser,isMember,setBit greater i) + LT -> (setBit lesser i,isMember,greater) + EQ -> (lesser,True,greater) +-} + + +{---------------------------------------------------------------- + Strictness enhancement +----------------------------------------------------------------} + +strict :: Set a -> Set a +strict s@(Set w) = w `seq` s + +strictWith :: (a -> b) -> Set a -> Set a +strictWith _ s@(Set w) = w `seq` s + +{-------------------------------------------------------------------- + Utility functions. +--------------------------------------------------------------------} + +foldrBits :: (Int -> a -> a) -> a -> Word -> a +foldrBits f z w = foldrBits_aux f z 0 w + +foldrBits_aux :: (Int -> a -> a) -> a -> Int -> Word -> a +foldrBits_aux _ z _ 0 = z +foldrBits_aux f z i w + | i `seq` w `seq` False = undefined + | otherwise = + case w .&. 0x0F of + 0x00 -> a + 0x01 -> f i $ a + 0x02 -> f (i+1) $ a + 0x03 -> f i $ f (i+1) $ a + 0x04 -> f (i+2) $ a + 0x05 -> f i $ f (i+2) $ a + 0x06 -> f (i+1) $ f (i+2) $ a + 0x07 -> f i $ f (i+1) $ f (i+2) $ a + 0x08 -> f (i+3) $ a + 0x09 -> f i $ f (i+3) $ a + 0x0A -> f (i+1) $ f (i+3) $ a + 0x0B -> f i $ f (i+1) $ f (i+3) $ a + 0x0C -> f (i+2) $ f (i+3) $ a + 0x0D -> f i $ f (i+2) $ f (i+3) $ a + 0x0E -> f (i+1) $ f (i+2) $ f (i+3) $ a + 0x0F -> f i $ f (i+1) $ f (i+2) $ f (i+3) $ a + _ -> error "bug in foldrBits_aux" + + where a = foldrBits_aux f z (i+4) (Bits.shiftR w 4) + + +foldrBits' :: (Int -> a -> a) -> a -> Word -> a +foldrBits' f z w = foldrBits_aux' f z 0 w + +foldrBits_aux' :: (Int -> a -> a) -> a -> Int -> Word -> a +foldrBits_aux' _ z _ 0 = z +foldrBits_aux' f z i w + | i `seq` w `seq` False = undefined + | otherwise = + case w .&. 0x0F of + 0x00 -> a + 0x01 -> f i $! a + 0x02 -> f (i+1) $! a + 0x03 -> f i $! f (i+1) $! a + 0x04 -> f (i+2) $! a + 0x05 -> f i $! f (i+2) $! a + 0x06 -> f (i+1) $! f (i+2) $! a + 0x07 -> f i $! f (i+1) $! f (i+2) $! a + 0x08 -> f (i+3) $! a + 0x09 -> f i $! f (i+3) $! a + 0x0A -> f (i+1) $! f (i+3) $! a + 0x0B -> f i $! f (i+1) $! f (i+3) $! a + 0x0C -> f (i+2) $! f (i+3) $! a + 0x0D -> f i $! f (i+2) $! f (i+3) $! a + 0x0E -> f (i+1) $! f (i+2) $! f (i+3) $! a + 0x0F -> f i $! f (i+1) $! f (i+2) $! f (i+3) $! a + _ -> error "bug in foldrBits_aux'" + + where a = foldrBits_aux' f z (i+4) (Bits.shiftR w 4) + + +foldlBits :: (a -> Int -> a) -> a -> Word -> a +foldlBits f z w = foldlBits_aux f z 0 w + +foldlBits_aux :: (a -> Int -> a) -> a -> Int -> Word -> a +foldlBits_aux _ z _ 0 = z +foldlBits_aux f z i w + | i `seq` w `seq` False = undefined + | otherwise = + case w .&. 0x0F of + 0x00 -> a $ z + 0x01 -> a $ f z i + 0x02 -> a $ f z (i+1) + 0x03 -> a $ f (f z i) (i+1) + 0x04 -> a $ f z (i+2) + 0x05 -> a $ f (f z i) (i+2) + 0x06 -> a $ f (f z (i+1)) (i+2) + 0x07 -> a $ f (f (f z i) (i+1)) (i+2) + 0x08 -> a $ f z (i+3) + 0x09 -> a $ f (f z i) (i+3) + 0x0A -> a $ f (f z (i+1)) (i+3) + 0x0B -> a $ f (f (f z i) (i+1)) (i+3) + 0x0C -> a $ f (f z (i+2)) (i+3) + 0x0D -> a $ f (f (f z i) (i+2)) (i+3) + 0x0E -> a $ f (f (f z (i+1)) (i+2)) (i+3) + 0x0F -> a $ f (f (f (f z i) (i+1)) (i+2)) (i+3) + _ -> error "bug in foldlBits_aux" + + where a b = foldlBits_aux f b (i + 4) (Bits.shiftR w 4) + +foldlBits' :: (a -> Int -> a) -> a -> Word -> a +foldlBits' f z w = foldlBits_aux' (\x i -> x `seq` f x i) z 0 w + +foldlBits_aux' :: (a -> Int -> a) -> a -> Int -> Word -> a +foldlBits_aux' _ z _ 0 = z +foldlBits_aux' f z i w + | i `seq` w `seq` False = undefined + | otherwise = + case w .&. 0x0F of + 0x00 -> a $! z + 0x01 -> a $! f z i + 0x02 -> a $! f z (i+1) + 0x03 -> a $! f (f z i) (i+1) + 0x04 -> a $! f z (i+2) + 0x05 -> a $! f (f z i) (i+2) + 0x06 -> a $! f (f z (i+1)) (i+2) + 0x07 -> a $! f (f (f z i) (i+1)) (i+2) + 0x08 -> a $! f z (i+3) + 0x09 -> a $! f (f z i) (i+3) + 0x0A -> a $! f (f z (i+1)) (i+3) + 0x0B -> a $! f (f (f z i) (i+1)) (i+3) + 0x0C -> a $! f (f z (i+2)) (i+3) + 0x0D -> a $! f (f (f z i) (i+2)) (i+3) + 0x0E -> a $! f (f (f z (i+1)) (i+2)) (i+3) + 0x0F -> a $! f (f (f (f z i) (i+1)) (i+2)) (i+3) + _ -> error "bug in foldlBits_aux" + + where a b = foldlBits_aux' f b (i + 4) (Bits.shiftR w 4) + +instance (Eq a, Enum a) => C.CollX (Set a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance (Ord a, Enum a) => C.OrdCollX (Set a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance (Eq a, Enum a) => C.SetX (Set a) a where + {intersection = intersection; difference = difference; + symmetricDifference = symmetricDifference; + properSubset = properSubset; subset = subset} + +instance (Eq a, Enum a) => C.Coll (Set a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance (Ord a, Enum a) => C.OrdColl (Set a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic} + +instance (Eq a, Enum a) => C.Set (Set a) a where + {fromSeqWith = fromSeqWith; insertWith = insertWith; + insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; + unionWith = unionWith; unionSeqWith = unionSeqWith; + intersectionWith = intersectionWith} + +instance (Ord a, Enum a) => C.OrdSetX (Set a) a +instance (Ord a, Enum a) => C.OrdSet (Set a) a + +instance (Eq a, Enum a, Show a) => Show (Set a) where + showsPrec = showsPrecUsingToList + +instance (Eq a, Enum a, Read a) => Read (Set a) where + readsPrec = readsPrecUsingFromList + +instance (Eq a, Enum a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = do (w::Int) <- arbitrary + return (Set (fromIntegral w)) + +instance (Eq a, Enum a, CoArbitrary a) => CoArbitrary (Set a) where + coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int) + +instance (Eq a, Enum a) => Semigroup (Set a) where + (<>) = union +instance (Eq a, Enum a) => Monoid (Set a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Ord a, Enum a) => Ord (Set a) where + compare = compareUsingToOrdList
src/Data/Edison/Coll/LazyPairingHeap.hs view
@@ -1,565 +1,572 @@--- |--- Module : Data.Edison.Coll.LazyPairingHeap--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Lazy Paring Heaps------ /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.--- Section 6.5.--module Data.Edison.Coll.LazyPairingHeap (- -- * Type of pairing heaps- Heap, -- instance of Coll/CollX, OrdColl/OrdCollX-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,structuralInvariant,-- -- * Coll operations- toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',- fold1, fold1', filter, partition, strictWith,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,- unsafeMapMonotonic,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..),- Coll(..), OrdColl(..), toOrdList )-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.List (sort)-import Data.Monoid-import Control.Monad-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.LazyPairingHeap"---data Heap a = E- | H1 a (Heap a)- | H2 a !(Heap a) (Heap a)----- Invariants:--- * left child of H2 not empty-structuralInvariant :: Heap a -> Bool-structuralInvariant E = True-structuralInvariant (H1 _ h) = structuralInvariant h-structuralInvariant (H2 _ E _) = False-structuralInvariant (H2 _ l r) = structuralInvariant l && structuralInvariant r---- second arg is not empty--- not used!--- link E h = h--- link (H1 x b) a = H2 x a b--- link (H2 x a b) a' = H1 x (union (union a a') b)--makeH2 :: a -> Heap a -> Heap a -> Heap a-makeH2 x E xs = H1 x xs-makeH2 x h xs = H2 x h xs--empty :: Heap a-empty = E--singleton :: a -> Heap a-singleton x = H1 x E--insert :: Ord a => a -> Heap a -> Heap a-insert x E = H1 x E-insert x h@(H1 y b)- | x <= y = H1 x h- | otherwise = H2 y (H1 x E) b-insert x h@(H2 y a b)- | x <= y = H1 x h- | otherwise = H1 y (union (insert x a) b)--union :: Ord a => Heap a -> Heap a -> Heap a-union E h = h-union hx@(H1 _ _) E = hx-union hx@(H1 x xs) hy@(H1 y ys)- | x <= y = H2 x hy xs- | otherwise = H2 y hx ys-union hx@(H1 x xs) hy@(H2 y a ys)- | x <= y = H2 x hy xs- | otherwise = H1 y (union (union hx a) ys)-union hx@(H2 _ _ _) E = hx-union hx@(H2 x a xs) hy@(H1 y ys)- | x <= y = H1 x (union (union hy a) xs)- | otherwise = H2 y hx ys-union hx@(H2 x a xs) hy@(H2 y b ys)- | x <= y = H1 x (union (union hy a) xs)- | otherwise = H1 y (union (union hx b) ys)--delete :: Ord a => a -> Heap a -> Heap a-delete y h = case del h of Just h' -> h'- Nothing -> h- where del E = Nothing- del (H1 x xs) =- case compare x y of- LT -> case del xs of- Just ys -> Just (H1 x ys)- Nothing -> Nothing- EQ -> Just xs- GT -> Nothing- del (H2 x a xs) =- case compare x y of- LT -> case del a of- Just a' -> Just (makeH2 x a' xs)- Nothing -> case del xs of- Just xs' -> Just (H2 x a xs')- Nothing -> Nothing- EQ -> Just (union a xs)- GT -> Nothing--deleteAll :: Ord a => a -> Heap a -> Heap a-deleteAll _ E = E-deleteAll y h@(H1 x xs) =- case compare x y of- LT -> H1 x (deleteAll y xs)- EQ -> deleteAll y xs- GT -> h-deleteAll y h@(H2 x a xs) =- case compare x y of- LT -> makeH2 x (deleteAll y a) (deleteAll y xs)- EQ -> union (deleteAll y a) (deleteAll y xs)- GT -> h--deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-deleteSeq = delList . sort . S.toList- where delList [] h = h- delList (y:ys) h = del y ys h-- del _ _ E = E- del y ys h@(H1 x xs) =- case compare x y of- LT -> H1 x (del y ys xs)- EQ -> delList ys xs- GT -> delList ys h- del y ys h@(H2 x a xs) =- case compare x y of- LT -> H1 x (del y ys (union a xs))- EQ -> delList ys (union a xs)- GT -> delList ys h- {-- could write the two GT cases as- delList (dropWhile (< x) ys) h- but this is only a win if we expect many of the ys- to be missing from the tree. However, we expect most- of the ys to be present.- -}--null :: Heap a -> Bool-null E = True-null _ = False--size :: Heap a -> Int-size E = 0-size (H1 _ xs) = 1 + size xs-size (H2 _ h xs) = 1 + size h + size xs--member :: Ord a => a -> Heap a -> Bool-member _ E = False-member x (H1 y ys) =- case compare x y of- LT -> False- EQ -> True- GT -> member x ys-member x (H2 y h ys) =- case compare x y of- LT -> False- EQ -> True- GT -> member x h || member x ys--count :: Ord a => a -> Heap a -> Int-count _ E = 0-count x (H1 y ys) =- case compare x y of- LT -> 0- EQ -> 1 + count x ys- GT -> count x ys-count x (H2 y h ys) =- case compare x y of- LT -> 0- EQ -> 1 + count x h + count x ys- GT -> count x h + count x ys--deleteMin :: Ord a => Heap a -> Heap a-deleteMin E = E-deleteMin (H1 _ xs) = xs-deleteMin (H2 _ h xs) = union h xs--unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMin = H1--unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax x E = H1 x E-unsafeInsertMax x (H1 y ys) = H2 y (H1 x E) ys-unsafeInsertMax x (H2 y h ys) = H1 y (union (unsafeInsertMax x h) ys)--unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-unsafeAppend h E = h-unsafeAppend E h = h-unsafeAppend (H1 x xs) h = H2 x h xs-unsafeAppend (H2 x a xs) h = H1 x (union (unsafeAppend a h) xs)--filterLT :: Ord a => a -> Heap a -> Heap a-filterLT _ E = E-filterLT y (H1 x xs)- | x < y = H1 x (filterLT y xs)- | otherwise = E-filterLT y (H2 x h xs)- | x < y = makeH2 x (filterLT y h) (filterLT y xs)- | otherwise = E--filterLE :: Ord a => a -> Heap a -> Heap a-filterLE _ E = E-filterLE y (H1 x xs)- | x <= y = H1 x (filterLE y xs)- | otherwise = E-filterLE y (H2 x h xs)- | x <= y = makeH2 x (filterLE y h) (filterLE y xs)- | otherwise = E--filterGT :: Ord a => a -> Heap a -> Heap a-filterGT y h = fgt h E- where fgt E rest = rest- fgt i@(H1 x xs) rest- | x > y = union i rest- | otherwise = fgt xs rest- fgt i@(H2 x a xs) rest- | x > y = union i rest- | otherwise = fgt a (fgt xs rest)--filterGE :: Ord a => a -> Heap a -> Heap a-filterGE y h = fge h E- where fge E rest = rest- fge i@(H1 x xs) rest- | x >= y = union i rest- | otherwise = fge xs rest- fge i@(H2 x a xs) rest- | x >= y = union i rest- | otherwise = fge a (fge xs rest)--partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GE _ E = (E,E)-partitionLT_GE y h@(H1 x xs)- | x < y = let (xs',xs'') = partitionLT_GE y xs- in (H1 x xs',xs'')- | otherwise = (E, h)-partitionLT_GE y h@(H2 x a xs)- | x < y = let (a',a'') = partitionLT_GE y a- (xs',xs'') = partitionLT_GE y xs- in (makeH2 x a' xs',union a'' xs'')- | otherwise = (E, h)--partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT _ E = (E,E)-partitionLE_GT y h@(H1 x xs)- | x <= y = let (xs',xs'') = partitionLE_GT y xs- in (H1 x xs',xs'')- | otherwise = (E, h)-partitionLE_GT y h@(H2 x a xs)- | x <= y = let (a',a'') = partitionLE_GT y a- (xs',xs'') = partitionLE_GT y xs- in (makeH2 x a' xs',union a'' xs'')- | otherwise = (E, h)--partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT _ E = (E,E)-partitionLT_GT y h@(H1 x xs) =- case compare x y of- LT -> let (xs',xs'') = partitionLT_GT y xs- in (H1 x xs',xs'')- EQ -> (E, filterGT y xs)- GT -> (E, h)-partitionLT_GT y h@(H2 x a xs) =- case compare x y of- LT -> let (a',a'') = partitionLT_GT y a- (xs',xs'') = partitionLT_GT y xs- in (makeH2 x a' xs',union a'' xs'')- EQ -> (E, union (filterGT y a) (filterGT y xs))- GT -> (E, h)--toSeq :: S.Sequence seq => Heap a -> seq a-toSeq h = tol h S.empty- where tol E rest = rest- tol (H1 x xs) rest = S.lcons x (tol xs rest)- tol (H2 x i xs) rest = S.lcons x $ tol i $ tol xs rest--fold :: (a -> b -> b) -> b -> Heap a -> b-fold _ c E = c-fold f c (H1 x xs) = f x (fold f c xs)-fold f c (H2 x h xs) = f x (fold f (fold f c xs) h)--fold' :: (a -> b -> b) -> b -> Heap a -> b-fold' _ c E = c-fold' f c (H1 x xs) = c `seq` f x $! (fold' f c xs)-fold' f c (H2 x h xs) = c `seq` f x $! (fold' f (fold' f c xs) h)---fold1 :: (a -> a -> a) -> Heap a -> a-fold1 _ E = error "LazyPairingHeap.fold1: empty heap"-fold1 f (H1 x xs) = fold f x xs-fold1 f (H2 x h xs) = fold f (fold f x xs) h--fold1' :: (a -> a -> a) -> Heap a -> a-fold1' _ E = error "LazyPairingHeap.fold1': empty heap"-fold1' f (H1 x xs) = fold' f x xs-fold1' f (H2 x h xs) = fold' f (fold' f x xs) h---filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-filter _ E = E-filter p (H1 x xs) = if p x then H1 x (filter p xs) else filter p xs-filter p (H2 x h xs) =- if p x then makeH2 x (filter p h) (filter p xs)- else union (filter p h) (filter p xs)--partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ E = (E, E)-partition p (H1 x xs) = if p x then (H1 x xs',xs'') else (xs',H1 x xs'')- where (xs',xs'') = partition p xs-partition p (H2 x h xs) =- if p x then (makeH2 x h' xs', union h'' xs'')- else (union h' xs', makeH2 x h'' xs'')- where (h',h'') = partition p h- (xs',xs'') = partition p xs--lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a-lookupAll y h = look h S.empty- where look E rest = rest- look (H1 x xs) rest =- case compare x y of- LT -> look xs rest- EQ -> S.lcons x (look xs rest)- GT -> rest- look (H2 x i xs) rest =- case compare x y of- LT -> look i $ look xs rest- EQ -> S.lcons x $ look i $ look xs rest- GT -> rest--minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)-minView E = fail "LazyPairingHeap.minView: empty heap"-minView (H1 x xs) = return (x,xs)-minView (H2 x h xs) = return (x,union h xs)--minElem :: Heap a -> a-minElem E = error "LazyPairingHeap.minElem: empty heap"-minElem (H1 x _) = x-minElem (H2 x _ _) = x--maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)-maxView E = fail "LazyPairingHeap.maxView: empty heap"-maxView xs = return (y,xs')- where (xs', y) = maxView' xs---- not exported-maxView' :: (Ord a) => Heap a -> (Heap a, a)-maxView' (H1 x E) = (E, x)-maxView' (H1 x xs) = (H1 x xs', y)- where (xs', y) = maxView' xs-maxView' (H2 x a E) = (H1 x a', y)- where (a', y) = maxView' a-maxView' (H2 x a xs) =- if y > z then (makeH2 x a' xs, y) else (H2 x a xs', z)- where (a', y) = maxView' a- (xs', z) = maxView' xs-maxView' E = error "LazyPairingHeap.maxView': bug!"--maxElem :: Ord a => Heap a -> a-maxElem E = error "LazyPairingHeap.maxElem: empty heap"-maxElem (H1 x E) = x-maxElem (H1 _ xs) = maxElem xs-maxElem (H2 _ h E) = maxElem h-maxElem (H2 _ h xs) = max (maxElem h) (maxElem xs)--foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr _ c E = c-foldr f c (H1 x xs) = f x (foldr f c xs)-foldr f c (H2 x h xs) = f x (foldr f c (union h xs))--foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr' _ c E = c-foldr' f c (H1 x xs) = c `seq` f x $! (foldr' f c xs)-foldr' f c (H2 x h xs) = c `seq` f x $! (foldr' f c (union h xs))--foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl _ c E = c-foldl f c (H1 x xs) = foldl f (f c x) xs-foldl f c (H2 x h xs) = foldl f (f c x) (union h xs)--foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl' _ c E = c-foldl' f c (H1 x xs) = c `seq` foldl' f (f c x) xs-foldl' f c (H2 x h xs) = c `seq` foldl' f (f c x) (union h xs)--foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1 _ E = error "LazyPairingHeap.foldr1: empty heap"-foldr1 _ (H1 x E) = x-foldr1 f (H1 x xs) = f x (foldr1 f xs)-foldr1 f (H2 x h xs) = f x (foldr1 f (union h xs))--foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1' _ E = error "LazyPairingHeap.foldr1': empty heap"-foldr1' _ (H1 x E) = x-foldr1' f (H1 x xs) = f x $! (foldr1' f xs)-foldr1' f (H2 x h xs) = f x $! (foldr1' f (union h xs))--foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 _ E = error "LazyPairingHeap.foldl1: empty heap"-foldl1 f (H1 x xs) = foldl f x xs-foldl1 f (H2 x h xs) = foldl f x (union h xs)--foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' _ E = error "LazyPairingHeap.foldl1': empty heap"-foldl1' f (H1 x xs) = foldl' f x xs-foldl1' f (H2 x h xs) = foldl' f x (union h xs)--unsafeMapMonotonic :: (Ord a,Ord b) => (a -> b) -> Heap a -> Heap b-unsafeMapMonotonic = mapm- where mapm _ E = E- mapm f (H1 x xs) = H1 (f x) (mapm f xs)- mapm f (H2 x h xs) = H2 (f x) (mapm f h) (mapm f xs)---strict :: Heap a -> Heap a-strict h@E = h-strict h@(H1 _ xs) = strict xs `seq` h-strict h@(H2 _ h' xs) = strict h' `seq` strict xs `seq` h--strictWith :: (a -> b) -> Heap a -> Heap a-strictWith _ h@E = h-strictWith f h@(H1 x xs) = f x `seq` strictWith f xs `seq` h-strictWith f h@(H2 x h' xs) = f x `seq` strictWith f h' `seq` strictWith f xs `seq` h----- the remaining functions all use default definitions--fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-fromSeq = fromSeqUsingFoldr--insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-insertSeq = insertSeqUsingFoldr--unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a-unionSeq = unionSeqUsingFoldl--unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin--deleteMax :: Ord a => Heap a -> Heap a-deleteMax = deleteMaxUsingMaxView--lookup :: Ord a => a -> Heap a -> a-lookup = lookupUsingLookupAll--lookupM :: (Ord a, Monad m) => a -> Heap a -> m a-lookupM = lookupMUsingLookupAll--lookupWithDefault :: Ord a => a -> a -> Heap a -> a-lookupWithDefault = lookupWithDefaultUsingLookupAll--toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toOrdSeq = toOrdSeqUsingFoldr---- instance declarations--instance Ord a => C.CollX (Heap a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Heap a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr';- foldl = foldl; foldl' = foldl'; foldr1 = foldr1;- foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => Eq (Heap a) where- xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where- showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where- readsPrec = readsPrecUsingFromList--instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where- arbitrary = sized (\n -> arbTree n)- where arbTree 0 = return E- arbTree n =- frequency [(1, return E),- (2, liftM2 sift1 arbitrary (arbTree (n - 1))),- (3, liftM3 sift arbitrary (arbTree (n `div` 4))- (arbTree (n `div` 2)))]-- sift x E a = sift1 x a- sift x a E = let H1 x' a' = sift1 x a in H2 x' a' E- sift x a b- | x <= ma && x <= mb = H2 x a b- | ma < x && ma <= mb = H2 ma (siftInto x a) b- | otherwise = H2 mb a (siftInto x b)- where ma = minElem a- mb = minElem b-- sift1 x E = H1 x E- sift1 x a- | x <= ma = H1 x a- | otherwise = H1 ma (siftInto x a)- where ma = minElem a-- siftInto x (H1 _ a) = sift1 x a- siftInto x (H2 _ a b) = sift x a b- siftInto _ E = error "LazyPairingHeap.arbitrary: bug!"--instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where- coarbitrary E = variant 0- coarbitrary (H1 x a) = variant 1 . coarbitrary x . coarbitrary a- coarbitrary (H2 x a b) =- variant 2 . coarbitrary x . coarbitrary a . coarbitrary b--instance (Ord a) => Monoid (Heap a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where- compare = compareUsingToOrdList+-- | +-- Module : Data.Edison.Coll.LazyPairingHeap +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Lazy Paring Heaps +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. +-- Section 6.5. + +module Data.Edison.Coll.LazyPairingHeap ( + -- * Type of pairing heaps + Heap, -- instance of Coll/CollX, OrdColl/OrdCollX + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict,structuralInvariant, + + -- * Coll operations + toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', + fold1, fold1', filter, partition, strictWith, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq, + unsafeMapMonotonic, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), + Coll(..), OrdColl(..), toOrdList ) +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.List (sort) +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + +moduleName :: String +moduleName = "Data.Edison.Coll.LazyPairingHeap" + + +data Heap a = E + | H1 a (Heap a) + | H2 a !(Heap a) (Heap a) + + +-- Invariants: +-- * left child of H2 not empty +structuralInvariant :: Heap a -> Bool +structuralInvariant E = True +structuralInvariant (H1 _ h) = structuralInvariant h +structuralInvariant (H2 _ E _) = False +structuralInvariant (H2 _ l r) = structuralInvariant l && structuralInvariant r + +-- second arg is not empty +-- not used! +-- link E h = h +-- link (H1 x b) a = H2 x a b +-- link (H2 x a b) a' = H1 x (union (union a a') b) + +makeH2 :: a -> Heap a -> Heap a -> Heap a +makeH2 x E xs = H1 x xs +makeH2 x h xs = H2 x h xs + +empty :: Heap a +empty = E + +singleton :: a -> Heap a +singleton x = H1 x E + +insert :: Ord a => a -> Heap a -> Heap a +insert x E = H1 x E +insert x h@(H1 y b) + | x <= y = H1 x h + | otherwise = H2 y (H1 x E) b +insert x h@(H2 y a b) + | x <= y = H1 x h + | otherwise = H1 y (union (insert x a) b) + +union :: Ord a => Heap a -> Heap a -> Heap a +union E h = h +union hx@(H1 _ _) E = hx +union hx@(H1 x xs) hy@(H1 y ys) + | x <= y = H2 x hy xs + | otherwise = H2 y hx ys +union hx@(H1 x xs) hy@(H2 y a ys) + | x <= y = H2 x hy xs + | otherwise = H1 y (union (union hx a) ys) +union hx@(H2 _ _ _) E = hx +union hx@(H2 x a xs) hy@(H1 y ys) + | x <= y = H1 x (union (union hy a) xs) + | otherwise = H2 y hx ys +union hx@(H2 x a xs) hy@(H2 y b ys) + | x <= y = H1 x (union (union hy a) xs) + | otherwise = H1 y (union (union hx b) ys) + +delete :: Ord a => a -> Heap a -> Heap a +delete y h = case del h of Just h' -> h' + Nothing -> h + where del E = Nothing + del (H1 x xs) = + case compare x y of + LT -> case del xs of + Just ys -> Just (H1 x ys) + Nothing -> Nothing + EQ -> Just xs + GT -> Nothing + del (H2 x a xs) = + case compare x y of + LT -> case del a of + Just a' -> Just (makeH2 x a' xs) + Nothing -> case del xs of + Just xs' -> Just (H2 x a xs') + Nothing -> Nothing + EQ -> Just (union a xs) + GT -> Nothing + +deleteAll :: Ord a => a -> Heap a -> Heap a +deleteAll _ E = E +deleteAll y h@(H1 x xs) = + case compare x y of + LT -> H1 x (deleteAll y xs) + EQ -> deleteAll y xs + GT -> h +deleteAll y h@(H2 x a xs) = + case compare x y of + LT -> makeH2 x (deleteAll y a) (deleteAll y xs) + EQ -> union (deleteAll y a) (deleteAll y xs) + GT -> h + +deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a +deleteSeq = delList . sort . S.toList + where delList [] h = h + delList (y:ys) h = del y ys h + + del _ _ E = E + del y ys h@(H1 x xs) = + case compare x y of + LT -> H1 x (del y ys xs) + EQ -> delList ys xs + GT -> delList ys h + del y ys h@(H2 x a xs) = + case compare x y of + LT -> H1 x (del y ys (union a xs)) + EQ -> delList ys (union a xs) + GT -> delList ys h + {- + could write the two GT cases as + delList (dropWhile (< x) ys) h + but this is only a win if we expect many of the ys + to be missing from the tree. However, we expect most + of the ys to be present. + -} + +null :: Heap a -> Bool +null E = True +null _ = False + +size :: Heap a -> Int +size E = 0 +size (H1 _ xs) = 1 + size xs +size (H2 _ h xs) = 1 + size h + size xs + +member :: Ord a => a -> Heap a -> Bool +member _ E = False +member x (H1 y ys) = + case compare x y of + LT -> False + EQ -> True + GT -> member x ys +member x (H2 y h ys) = + case compare x y of + LT -> False + EQ -> True + GT -> member x h || member x ys + +count :: Ord a => a -> Heap a -> Int +count _ E = 0 +count x (H1 y ys) = + case compare x y of + LT -> 0 + EQ -> 1 + count x ys + GT -> count x ys +count x (H2 y h ys) = + case compare x y of + LT -> 0 + EQ -> 1 + count x h + count x ys + GT -> count x h + count x ys + +deleteMin :: Ord a => Heap a -> Heap a +deleteMin E = E +deleteMin (H1 _ xs) = xs +deleteMin (H2 _ h xs) = union h xs + +unsafeInsertMin :: Ord a => a -> Heap a -> Heap a +unsafeInsertMin = H1 + +unsafeInsertMax :: Ord a => a -> Heap a -> Heap a +unsafeInsertMax x E = H1 x E +unsafeInsertMax x (H1 y ys) = H2 y (H1 x E) ys +unsafeInsertMax x (H2 y h ys) = H1 y (union (unsafeInsertMax x h) ys) + +unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a +unsafeAppend h E = h +unsafeAppend E h = h +unsafeAppend (H1 x xs) h = H2 x h xs +unsafeAppend (H2 x a xs) h = H1 x (union (unsafeAppend a h) xs) + +filterLT :: Ord a => a -> Heap a -> Heap a +filterLT _ E = E +filterLT y (H1 x xs) + | x < y = H1 x (filterLT y xs) + | otherwise = E +filterLT y (H2 x h xs) + | x < y = makeH2 x (filterLT y h) (filterLT y xs) + | otherwise = E + +filterLE :: Ord a => a -> Heap a -> Heap a +filterLE _ E = E +filterLE y (H1 x xs) + | x <= y = H1 x (filterLE y xs) + | otherwise = E +filterLE y (H2 x h xs) + | x <= y = makeH2 x (filterLE y h) (filterLE y xs) + | otherwise = E + +filterGT :: Ord a => a -> Heap a -> Heap a +filterGT y h = fgt h E + where fgt E rest = rest + fgt i@(H1 x xs) rest + | x > y = union i rest + | otherwise = fgt xs rest + fgt i@(H2 x a xs) rest + | x > y = union i rest + | otherwise = fgt a (fgt xs rest) + +filterGE :: Ord a => a -> Heap a -> Heap a +filterGE y h = fge h E + where fge E rest = rest + fge i@(H1 x xs) rest + | x >= y = union i rest + | otherwise = fge xs rest + fge i@(H2 x a xs) rest + | x >= y = union i rest + | otherwise = fge a (fge xs rest) + +partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GE _ E = (E,E) +partitionLT_GE y h@(H1 x xs) + | x < y = let (xs',xs'') = partitionLT_GE y xs + in (H1 x xs',xs'') + | otherwise = (E, h) +partitionLT_GE y h@(H2 x a xs) + | x < y = let (a',a'') = partitionLT_GE y a + (xs',xs'') = partitionLT_GE y xs + in (makeH2 x a' xs',union a'' xs'') + | otherwise = (E, h) + +partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLE_GT _ E = (E,E) +partitionLE_GT y h@(H1 x xs) + | x <= y = let (xs',xs'') = partitionLE_GT y xs + in (H1 x xs',xs'') + | otherwise = (E, h) +partitionLE_GT y h@(H2 x a xs) + | x <= y = let (a',a'') = partitionLE_GT y a + (xs',xs'') = partitionLE_GT y xs + in (makeH2 x a' xs',union a'' xs'') + | otherwise = (E, h) + +partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GT _ E = (E,E) +partitionLT_GT y h@(H1 x xs) = + case compare x y of + LT -> let (xs',xs'') = partitionLT_GT y xs + in (H1 x xs',xs'') + EQ -> (E, filterGT y xs) + GT -> (E, h) +partitionLT_GT y h@(H2 x a xs) = + case compare x y of + LT -> let (a',a'') = partitionLT_GT y a + (xs',xs'') = partitionLT_GT y xs + in (makeH2 x a' xs',union a'' xs'') + EQ -> (E, union (filterGT y a) (filterGT y xs)) + GT -> (E, h) + +toSeq :: S.Sequence seq => Heap a -> seq a +toSeq h = tol h S.empty + where tol E rest = rest + tol (H1 x xs) rest = S.lcons x (tol xs rest) + tol (H2 x i xs) rest = S.lcons x $ tol i $ tol xs rest + +fold :: (a -> b -> b) -> b -> Heap a -> b +fold _ c E = c +fold f c (H1 x xs) = f x (fold f c xs) +fold f c (H2 x h xs) = f x (fold f (fold f c xs) h) + +fold' :: (a -> b -> b) -> b -> Heap a -> b +fold' _ c E = c +fold' f c (H1 x xs) = c `seq` f x $! (fold' f c xs) +fold' f c (H2 x h xs) = c `seq` f x $! (fold' f (fold' f c xs) h) + + +fold1 :: (a -> a -> a) -> Heap a -> a +fold1 _ E = error "LazyPairingHeap.fold1: empty heap" +fold1 f (H1 x xs) = fold f x xs +fold1 f (H2 x h xs) = fold f (fold f x xs) h + +fold1' :: (a -> a -> a) -> Heap a -> a +fold1' _ E = error "LazyPairingHeap.fold1': empty heap" +fold1' f (H1 x xs) = fold' f x xs +fold1' f (H2 x h xs) = fold' f (fold' f x xs) h + + +filter :: Ord a => (a -> Bool) -> Heap a -> Heap a +filter _ E = E +filter p (H1 x xs) = if p x then H1 x (filter p xs) else filter p xs +filter p (H2 x h xs) = + if p x then makeH2 x (filter p h) (filter p xs) + else union (filter p h) (filter p xs) + +partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) +partition _ E = (E, E) +partition p (H1 x xs) = if p x then (H1 x xs',xs'') else (xs',H1 x xs'') + where (xs',xs'') = partition p xs +partition p (H2 x h xs) = + if p x then (makeH2 x h' xs', union h'' xs'') + else (union h' xs', makeH2 x h'' xs'') + where (h',h'') = partition p h + (xs',xs'') = partition p xs + +lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a +lookupAll y h = look h S.empty + where look E rest = rest + look (H1 x xs) rest = + case compare x y of + LT -> look xs rest + EQ -> S.lcons x (look xs rest) + GT -> rest + look (H2 x i xs) rest = + case compare x y of + LT -> look i $ look xs rest + EQ -> S.lcons x $ look i $ look xs rest + GT -> rest + +minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +minView E = fail "LazyPairingHeap.minView: empty heap" +minView (H1 x xs) = return (x,xs) +minView (H2 x h xs) = return (x,union h xs) + +minElem :: Heap a -> a +minElem E = error "LazyPairingHeap.minElem: empty heap" +minElem (H1 x _) = x +minElem (H2 x _ _) = x + +maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +maxView E = fail "LazyPairingHeap.maxView: empty heap" +maxView xs = return (y,xs') + where (xs', y) = maxView' xs + +-- not exported +maxView' :: (Ord a) => Heap a -> (Heap a, a) +maxView' (H1 x E) = (E, x) +maxView' (H1 x xs) = (H1 x xs', y) + where (xs', y) = maxView' xs +maxView' (H2 x a E) = (H1 x a', y) + where (a', y) = maxView' a +maxView' (H2 x a xs) = + if y > z then (makeH2 x a' xs, y) else (H2 x a xs', z) + where (a', y) = maxView' a + (xs', z) = maxView' xs +maxView' E = error "LazyPairingHeap.maxView': bug!" + +maxElem :: Ord a => Heap a -> a +maxElem E = error "LazyPairingHeap.maxElem: empty heap" +maxElem (H1 x E) = x +maxElem (H1 _ xs) = maxElem xs +maxElem (H2 _ h E) = maxElem h +maxElem (H2 _ h xs) = max (maxElem h) (maxElem xs) + +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr _ c E = c +foldr f c (H1 x xs) = f x (foldr f c xs) +foldr f c (H2 x h xs) = f x (foldr f c (union h xs)) + +foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr' _ c E = c +foldr' f c (H1 x xs) = c `seq` f x $! (foldr' f c xs) +foldr' f c (H2 x h xs) = c `seq` f x $! (foldr' f c (union h xs)) + +foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldl _ c E = c +foldl f c (H1 x xs) = foldl f (f c x) xs +foldl f c (H2 x h xs) = foldl f (f c x) (union h xs) + +foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldl' _ c E = c +foldl' f c (H1 x xs) = c `seq` foldl' f (f c x) xs +foldl' f c (H2 x h xs) = c `seq` foldl' f (f c x) (union h xs) + +foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldr1 _ E = error "LazyPairingHeap.foldr1: empty heap" +foldr1 _ (H1 x E) = x +foldr1 f (H1 x xs) = f x (foldr1 f xs) +foldr1 f (H2 x h xs) = f x (foldr1 f (union h xs)) + +foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldr1' _ E = error "LazyPairingHeap.foldr1': empty heap" +foldr1' _ (H1 x E) = x +foldr1' f (H1 x xs) = f x $! (foldr1' f xs) +foldr1' f (H2 x h xs) = f x $! (foldr1' f (union h xs)) + +foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1 _ E = error "LazyPairingHeap.foldl1: empty heap" +foldl1 f (H1 x xs) = foldl f x xs +foldl1 f (H2 x h xs) = foldl f x (union h xs) + +foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1' _ E = error "LazyPairingHeap.foldl1': empty heap" +foldl1' f (H1 x xs) = foldl' f x xs +foldl1' f (H2 x h xs) = foldl' f x (union h xs) + +unsafeMapMonotonic :: (Ord a,Ord b) => (a -> b) -> Heap a -> Heap b +unsafeMapMonotonic = mapm + where mapm _ E = E + mapm f (H1 x xs) = H1 (f x) (mapm f xs) + mapm f (H2 x h xs) = H2 (f x) (mapm f h) (mapm f xs) + + +strict :: Heap a -> Heap a +strict h@E = h +strict h@(H1 _ xs) = strict xs `seq` h +strict h@(H2 _ h' xs) = strict h' `seq` strict xs `seq` h + +strictWith :: (a -> b) -> Heap a -> Heap a +strictWith _ h@E = h +strictWith f h@(H1 x xs) = f x `seq` strictWith f xs `seq` h +strictWith f h@(H2 x h' xs) = f x `seq` strictWith f h' `seq` strictWith f xs `seq` h + + +-- the remaining functions all use default definitions + +fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a +fromSeq = fromSeqUsingFoldr + +insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a +insertSeq = insertSeqUsingFoldr + +unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a +unionSeq = unionSeqUsingFoldl + +unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a +unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin + +deleteMax :: Ord a => Heap a -> Heap a +deleteMax = deleteMaxUsingMaxView + +lookup :: Ord a => a -> Heap a -> a +lookup = lookupUsingLookupAll + +lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a +lookupM = lookupMUsingLookupAll + +lookupWithDefault :: Ord a => a -> a -> Heap a -> a +lookupWithDefault = lookupWithDefaultUsingLookupAll + +toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a +toOrdSeq = toOrdSeqUsingFoldr + +-- instance declarations + +instance Ord a => C.CollX (Heap a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord a => C.OrdCollX (Heap a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Heap a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Heap a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; + foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} + +instance Ord a => Eq (Heap a) where + xs == ys = C.toOrdList xs == C.toOrdList ys + +instance (Ord a, Show a) => Show (Heap a) where + showsPrec = showsPrecUsingToList + +instance (Ord a, Read a) => Read (Heap a) where + readsPrec = readsPrecUsingFromList + +instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where + arbitrary = sized (\n -> arbTree n) + where arbTree 0 = return E + arbTree n = + frequency [(1, return E), + (2, liftM2 sift1 arbitrary (arbTree (n - 1))), + (3, liftM3 sift arbitrary (arbTree (n `div` 4)) + (arbTree (n `div` 2)))] + + sift x E a = sift1 x a + sift x a E = case sift1 x a of + H1 x' a' -> H2 x' a' E + _ -> undefined + sift x a b + | x <= ma && x <= mb = H2 x a b + | ma < x && ma <= mb = H2 ma (siftInto x a) b + | otherwise = H2 mb a (siftInto x b) + where ma = minElem a + mb = minElem b + + sift1 x E = H1 x E + sift1 x a + | x <= ma = H1 x a + | otherwise = H1 ma (siftInto x a) + where ma = minElem a + + siftInto x (H1 _ a) = sift1 x a + siftInto x (H2 _ a b) = sift x a b + siftInto _ E = error "LazyPairingHeap.arbitrary: bug!" + +instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (H1 x a) = variant (1 :: Int) . coarbitrary x . coarbitrary a + coarbitrary (H2 x a b) = + variant (2 :: Int) . coarbitrary x . coarbitrary a . coarbitrary b + +instance (Ord a) => Semigroup (Heap a) where + (<>) = union + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList
src/Data/Edison/Coll/LeftistHeap.hs view
@@ -1,491 +1,497 @@--- |--- Module : Data.Edison.Coll.LeftistHeap--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Leftist Heaps------ /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998. Section 3.1.--module Data.Edison.Coll.LeftistHeap (- -- * Type of leftist heaps- Heap, -- instance of Coll/CollX, OrdColl/OrdCollX-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,structuralInvariant,-- -- * Coll operations- toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',- fold1, fold1', filter, partition, strictWith,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,- unsafeMapMonotonic,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..),- unionList, toOrdList )-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Control.Monad-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.LeftistHeap"--data Heap a = E | L !Int !a !(Heap a) !(Heap a)---- invariants:--- * Heap ordered--- * Leftist; the rank of any left node is >= the--- rank of its right sibling. The rank of a node--- is the length of its right spine.--structuralInvariant :: Ord a => Heap a -> Bool-structuralInvariant E = True-structuralInvariant t@(L i x _ _) =- i == rank t && isMin x t && checkLeftist t-- where rank :: Heap a -> Int- rank E = 0- rank (L _ _ _ s) = (rank s) + 1-- isMin _ E = True- isMin z (L _ y l r) = z <= y && (isMin y l) && (isMin y r)-- checkLeftist E = True- checkLeftist (L _ _ l r) =- rank l >= rank r && checkLeftist l && checkLeftist r--node :: a -> Heap a -> Heap a -> Heap a-node x a E = L 1 x a E-node x E b = L 1 x b E-node x a@(L m _ _ _) b@(L n _ _ _)- | m <= n = L (m + 1) x b a- | otherwise = L (n + 1) x a b--{--Note: when we want to recurse down both sides, and we have a choice,-recursing down the smaller side first will minimize stack usage.--For delete,deleteAll,filter,partition: could compute fringe and reduce-rather that rebuilding with union at every deleted node--}--empty :: Ord a => Heap a-empty = E--singleton :: Ord a => a -> Heap a-singleton x = L 1 x E E--insert :: Ord a => a -> Heap a -> Heap a-insert x E = L 1 x E E-insert x h@(L _ y a b)- | x <= y = L 1 x h E- | otherwise = node y a (insert x b)--union :: Ord a => Heap a -> Heap a -> Heap a-union E h = h-union h@(L _ x a b) h' = union' h x a b h'- where union' i _ _ _ E = i- union' hx z q e hy@(L _ y c d)- | z <= y = node z q (union' hy y c d e)- | otherwise = node y c (union' hx z q e d)--{--union E h = h-union h E = h-union h1@(L _ x a b) h2@(L _ y c d)- | x <= y = node x a (union b h2)- | otherwise = node y c (union h1 d)- -- ??? optimize to catch fact that h1 or h2 is known to be L case?--}--delete :: Ord a => a -> Heap a -> Heap a-delete x h = case del h of- Just h' -> h'- Nothing -> h- where del (L _ y a b) =- case compare x y of- LT -> Nothing- EQ -> Just (union a b)- GT -> case del b of- Just b' -> Just (node y a b')- Nothing -> case del a of- Just a' -> Just (node y a' b)- Nothing -> Nothing- del E = Nothing--deleteAll :: Ord a => a -> Heap a -> Heap a-deleteAll x h@(L _ y a b) =- case compare x y of- LT -> h- EQ -> union (deleteAll x a) (deleteAll x b)- GT -> node y (deleteAll x a) (deleteAll x b)-deleteAll _ E = E--null :: Ord a => Heap a -> Bool-null E = True-null _ = False--size :: Ord a => Heap a -> Int-size h = sz h 0- where sz E i = i- sz (L _ _ a b) i = sz a (sz b (i + 1))--member :: Ord a => a -> Heap a -> Bool-member _ E = False-member x (L _ y a b) =- case compare x y of- LT -> False- EQ -> True- GT -> member x b || member x a--count :: Ord a => a -> Heap a -> Int-count _ E = 0-count x (L _ y a b) =- case compare x y of- LT -> 0- EQ -> 1 + count x b + count x a- GT -> count x b + count x a--toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toSeq h = tol h S.empty- where tol E rest = rest- tol (L _ x a b) rest = S.lcons x (tol b (tol a rest))--lookupM :: (Ord a, Monad m) => a -> Heap a -> m a-lookupM _ E = fail "LeftistHeap.lookupM: XXX"-lookupM x (L _ y a b) =- case compare x y of- LT -> fail "LeftistHeap.lookupM: XXX"- EQ -> return y- GT -> case lookupM x b `mplus` lookupM x a of- Nothing -> fail "LeftistHeap.lookupM: XXX"- Just q -> return q--lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a-lookupAll x h = look h S.empty- where look E ys = ys- look (L _ y a b) ys =- case compare x y of- LT -> ys- EQ -> S.lcons y (look b (look a ys))- GT -> look b (look a ys)--fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold _ e E = e-fold f e (L _ x a b) = f x (fold f (fold f e a) b)--fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold' _ e E = e-fold' f e (L _ x a b) = e `seq` f x $! (fold' f (fold' f e a) b)--fold1 :: Ord a => (a -> a -> a) -> Heap a -> a-fold1 _ E = error "LeftistHeap.fold1: empty collection"-fold1 f (L _ x a b) = fold f (fold f x a) b--fold1' :: Ord a => (a -> a -> a) -> Heap a -> a-fold1' _ E = error "LeftistHeap.fold1': empty collection"-fold1' f (L _ x a b) = fold' f (fold' f x a) b---filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-filter _ E = E-filter p (L _ x a b)- | p x = node x (filter p a) (filter p b)- | otherwise = union (filter p a) (filter p b)--partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ E = (E, E)-partition p (L _ x a b)- | p x = (node x a' b', union a'' b'')- | otherwise = (union a' b', node x a'' b'')- where (a', a'') = partition p a- (b', b'') = partition p b---deleteMin :: Ord a => Heap a -> Heap a-deleteMin E = E-deleteMin (L _ _ a b) = union a b--deleteMax :: Ord a => Heap a -> Heap a-deleteMax h = case maxView h of- Nothing -> E- Just (_,h') -> h'--unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMin x h = L 1 x h E--unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-unsafeAppend E h = h-unsafeAppend (L _ y a b) h = node y a (unsafeAppend b h)--filterLT :: Ord a => a -> Heap a -> Heap a-filterLT y (L _ x a b) | x < y = node x (filterLT y a) (filterLT y b)-filterLT _ _ = E--filterLE :: Ord a => a -> Heap a -> Heap a-filterLE y (L _ x a b) | x <= y = node x (filterLE y a) (filterLE y b)-filterLE _ _ = E--filterGT :: Ord a => a -> Heap a -> Heap a-filterGT y h = C.unionList (collect h [])- where collect E hs = hs- collect h@(L _ x a b) hs- | x > y = h : hs- | otherwise = collect a (collect b hs)--filterGE :: Ord a => a -> Heap a -> Heap a-filterGE y h = C.unionList (collect h [])- where collect E hs = hs- collect h@(L _ x a b) hs- | x >= y = h : hs- | otherwise = collect b (collect a hs)--partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GE y h = (h', C.unionList hs)- where (h', hs) = collect h []-- collect E hs = (E, hs)- collect h@(L _ x a b) hs- | x >= y = (E, h:hs)- | otherwise = let (a', hs') = collect a hs- (b', hs'') = collect b hs'- in (node x a' b', hs'')--partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT y h = (h', C.unionList hs)- where (h', hs) = collect h []-- collect E hs = (E, hs)- collect h@(L _ x a b) hs- | x > y = (E, h:hs)- | otherwise = let (a', hs') = collect a hs- (b', hs'') = collect b hs'- in (node x a' b', hs'')--partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT y h = (h', C.unionList hs)- where (h', hs) = collect h []-- collect E hs = (E, hs)- collect h@(L _ x a b) is =- case compare x y of- GT -> (E, h:is)- EQ -> let (a', hs') = collect a is- (b', hs'') = collect b hs'- in (union a' b', hs'')- LT -> let (a', hs') = collect a is- (b', hs'') = collect b hs'- in (node x a' b', hs'')--minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)-minView E = fail "LeftistHeap.minView: empty collection"-minView (L _ x a b) = return (x, union a b)--minElem :: Ord a => Heap a -> a-minElem E = error "LeftistHeap.minElem: empty collection"-minElem (L _ x _ _) = x--maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)-maxView E = fail "LeftistHeap.maxView: empty collection"-maxView (L _ x E _) = return (x, E)-maxView (L _ x a E) = return (y, L 1 x a' E)- where Just (y,a') = maxView a-maxView (L _ x a b)- | y >= z = return (y, node x a' b)- | otherwise = return (z, node x a b')- where Just (y, a') = maxView a- Just (z, b') = maxView b---- warning: maxView and maxElem may disagree if root is equal to max!--maxElem :: Ord a => Heap a -> a-maxElem E = error "LeftistHeap.maxElem: empty collection"-maxElem (L _ x E _) = x-maxElem (L _ _ a b) = findMax b (findLeaf a)- where findMax E m = m- findMax (L _ x E _) m- | m >= x = m- | otherwise = x- findMax (L _ _ d c) m = findMax d (findMax c m)-- findLeaf E = error "LeftistHeap.maxElem: bug"- findLeaf (L _ x E _) = x- findLeaf (L _ _ y c) = findMax c (findLeaf y)--foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr _ e E = e-foldr f e (L _ x a b) = f x (foldr f e (union a b))--foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr' _ e E = e-foldr' f e (L _ x a b) = e `seq` f x $! (foldr' f e (union a b))--foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl _ e E = e-foldl f e (L _ x a b) = foldl f (f e x) (union a b)--foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl' _ e E = e-foldl' f e (L _ x a b) = e `seq` foldl' f (f e x) (union a b)--foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1 _ E = error "LeftistHeap.foldr1: empty collection"-foldr1 _ (L _ x E _) = x-foldr1 f (L _ x a b) = f x (foldr1 f (union a b))--foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1' _ E = error "LeftistHeap.foldr1': empty collection"-foldr1' _ (L _ x E _) = x-foldr1' f (L _ x a b) = f x $! (foldr1' f (union a b))--foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 _ E = error "LeftistHeap.foldl1: empty collection"-foldl1 f (L _ x a b) = foldl f x (union a b)--foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' _ E = error "LeftistHeap.foldl1: empty collection"-foldl1' f (L _ x a b) = foldl' f x (union a b)--{- ???? -}-unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a-unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (L i x a b) =- L i (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)----- all fields are already fully strict!-strict :: Heap a -> Heap a-strict h = h--strictWith :: (a -> b) -> Heap a -> Heap a-strictWith _ h@E = h-strictWith f h@(L _ x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h---- the remaining functions all use default definitions--fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-fromSeq = fromSeqUsingUnionSeq--insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-insertSeq = insertSeqUsingUnion--unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a-unionSeq = unionSeqUsingReduce--deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-deleteSeq = deleteSeqUsingDelete--lookup :: Ord a => a -> Heap a -> a-lookup = lookupUsingLookupM--lookupWithDefault :: Ord a => a -> a -> Heap a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend--unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin--toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toOrdSeq = toOrdSeqUsingFoldr----- instance declarations--instance Ord a => C.CollX (Heap a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Heap a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr';- foldl = foldl; foldl' = foldl'; foldr1 = foldr1;- foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => Eq (Heap a) where- xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where- showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where- readsPrec = readsPrecUsingFromList---instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where- arbitrary = sized (\n -> arbTree n)- where arbTree 0 = return E- arbTree n =- frequency [(1, return E),- (4, liftM3 snode arbitrary (arbTree (n `div` 2))- (arbTree (n `div` 4)))]-- snode x a b = sift (node x a b)-- sift E = E- sift t@(L _ x a E)- | a == E || x <= minElem a = t- sift (L r x (L r' y a b) E) =- L r y (sift (L r' x a b)) E- sift t@(L _ x a b)- | x <= minElem a && x <= minElem b = t- sift (L r x (L r' y a b) c)- | y <= minElem c =- L r y (sift (L r' x a b)) c- sift (L r x a (L r' y b c)) =- L r y a (sift (L r' x b c))- sift _ = error "LeftistHeap.arbitrary: bug!"--instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where- coarbitrary E = variant 0- coarbitrary (L _ x a b) =- variant 1 . coarbitrary x . coarbitrary a . coarbitrary b--instance (Ord a) => Monoid (Heap a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where- compare = compareUsingToOrdList+-- | +-- Module : Data.Edison.Coll.LeftistHeap +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Leftist Heaps +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. Section 3.1. + +module Data.Edison.Coll.LeftistHeap ( + -- * Type of leftist heaps + Heap, -- instance of Coll/CollX, OrdColl/OrdCollX + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict,structuralInvariant, + + -- * Coll operations + toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', + fold1, fold1', filter, partition, strictWith, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq, + unsafeMapMonotonic, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..), + unionList, toOrdList ) +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Maybe (fromJust) +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + +moduleName :: String +moduleName = "Data.Edison.Coll.LeftistHeap" + +data Heap a = E | L !Int !a !(Heap a) !(Heap a) + +-- invariants: +-- * Heap ordered +-- * Leftist; the rank of any left node is >= the +-- rank of its right sibling. The rank of a node +-- is the length of its right spine. + +structuralInvariant :: Ord a => Heap a -> Bool +structuralInvariant E = True +structuralInvariant t@(L i x _ _) = + i == rank t && isMin x t && checkLeftist t + + where rank :: Heap a -> Int + rank E = 0 + rank (L _ _ _ s) = (rank s) + 1 + + isMin _ E = True + isMin z (L _ y l r) = z <= y && (isMin y l) && (isMin y r) + + checkLeftist E = True + checkLeftist (L _ _ l r) = + rank l >= rank r && checkLeftist l && checkLeftist r + +node :: a -> Heap a -> Heap a -> Heap a +node x a E = L 1 x a E +node x E b = L 1 x b E +node x a@(L m _ _ _) b@(L n _ _ _) + | m <= n = L (m + 1) x b a + | otherwise = L (n + 1) x a b + +{- +Note: when we want to recurse down both sides, and we have a choice, +recursing down the smaller side first will minimize stack usage. + +For delete,deleteAll,filter,partition: could compute fringe and reduce +rather that rebuilding with union at every deleted node +-} + +empty :: Ord a => Heap a +empty = E + +singleton :: Ord a => a -> Heap a +singleton x = L 1 x E E + +insert :: Ord a => a -> Heap a -> Heap a +insert x E = L 1 x E E +insert x h@(L _ y a b) + | x <= y = L 1 x h E + | otherwise = node y a (insert x b) + +union :: Ord a => Heap a -> Heap a -> Heap a +union E h = h +union h@(L _ x a b) h' = union' h x a b h' + where union' i _ _ _ E = i + union' hx z q e hy@(L _ y c d) + | z <= y = node z q (union' hy y c d e) + | otherwise = node y c (union' hx z q e d) + +{- +union E h = h +union h E = h +union h1@(L _ x a b) h2@(L _ y c d) + | x <= y = node x a (union b h2) + | otherwise = node y c (union h1 d) + -- ??? optimize to catch fact that h1 or h2 is known to be L case? +-} + +delete :: Ord a => a -> Heap a -> Heap a +delete x h = case del h of + Just h' -> h' + Nothing -> h + where del (L _ y a b) = + case compare x y of + LT -> Nothing + EQ -> Just (union a b) + GT -> case del b of + Just b' -> Just (node y a b') + Nothing -> case del a of + Just a' -> Just (node y a' b) + Nothing -> Nothing + del E = Nothing + +deleteAll :: Ord a => a -> Heap a -> Heap a +deleteAll x h@(L _ y a b) = + case compare x y of + LT -> h + EQ -> union (deleteAll x a) (deleteAll x b) + GT -> node y (deleteAll x a) (deleteAll x b) +deleteAll _ E = E + +null :: Ord a => Heap a -> Bool +null E = True +null _ = False + +size :: Ord a => Heap a -> Int +size h = sz h 0 + where sz E i = i + sz (L _ _ a b) i = sz a (sz b (i + 1)) + +member :: Ord a => a -> Heap a -> Bool +member _ E = False +member x (L _ y a b) = + case compare x y of + LT -> False + EQ -> True + GT -> member x b || member x a + +count :: Ord a => a -> Heap a -> Int +count _ E = 0 +count x (L _ y a b) = + case compare x y of + LT -> 0 + EQ -> 1 + count x b + count x a + GT -> count x b + count x a + +toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a +toSeq h = tol h S.empty + where tol E rest = rest + tol (L _ x a b) rest = S.lcons x (tol b (tol a rest)) + +lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a +lookupM _ E = fail "LeftistHeap.lookupM: XXX" +lookupM x (L _ y a b) = + case compare x y of + LT -> fail "LeftistHeap.lookupM: XXX" + EQ -> return y + GT -> case lookupM x b `mplus` lookupM x a of + Nothing -> fail "LeftistHeap.lookupM: XXX" + Just q -> return q + +lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a +lookupAll x h = look h S.empty + where look E ys = ys + look (L _ y a b) ys = + case compare x y of + LT -> ys + EQ -> S.lcons y (look b (look a ys)) + GT -> look b (look a ys) + +fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b +fold _ e E = e +fold f e (L _ x a b) = f x (fold f (fold f e a) b) + +fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +fold' _ e E = e +fold' f e (L _ x a b) = e `seq` f x $! (fold' f (fold' f e a) b) + +fold1 :: Ord a => (a -> a -> a) -> Heap a -> a +fold1 _ E = error "LeftistHeap.fold1: empty collection" +fold1 f (L _ x a b) = fold f (fold f x a) b + +fold1' :: Ord a => (a -> a -> a) -> Heap a -> a +fold1' _ E = error "LeftistHeap.fold1': empty collection" +fold1' f (L _ x a b) = fold' f (fold' f x a) b + + +filter :: Ord a => (a -> Bool) -> Heap a -> Heap a +filter _ E = E +filter p (L _ x a b) + | p x = node x (filter p a) (filter p b) + | otherwise = union (filter p a) (filter p b) + +partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) +partition _ E = (E, E) +partition p (L _ x a b) + | p x = (node x a' b', union a'' b'') + | otherwise = (union a' b', node x a'' b'') + where (a', a'') = partition p a + (b', b'') = partition p b + + +deleteMin :: Ord a => Heap a -> Heap a +deleteMin E = E +deleteMin (L _ _ a b) = union a b + +deleteMax :: Ord a => Heap a -> Heap a +deleteMax h = case maxView h of + Nothing -> E + Just (_,h') -> h' + +unsafeInsertMin :: Ord a => a -> Heap a -> Heap a +unsafeInsertMin x h = L 1 x h E + +unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a +unsafeAppend E h = h +unsafeAppend (L _ y a b) h = node y a (unsafeAppend b h) + +filterLT :: Ord a => a -> Heap a -> Heap a +filterLT y (L _ x a b) | x < y = node x (filterLT y a) (filterLT y b) +filterLT _ _ = E + +filterLE :: Ord a => a -> Heap a -> Heap a +filterLE y (L _ x a b) | x <= y = node x (filterLE y a) (filterLE y b) +filterLE _ _ = E + +filterGT :: Ord a => a -> Heap a -> Heap a +filterGT y h = C.unionList (collect h []) + where collect E hs = hs + collect h@(L _ x a b) hs + | x > y = h : hs + | otherwise = collect a (collect b hs) + +filterGE :: Ord a => a -> Heap a -> Heap a +filterGE y h = C.unionList (collect h []) + where collect E hs = hs + collect h@(L _ x a b) hs + | x >= y = h : hs + | otherwise = collect b (collect a hs) + +partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GE y h = (h', C.unionList hs) + where (h', hs) = collect h [] + + collect E hs = (E, hs) + collect h@(L _ x a b) hs + | x >= y = (E, h:hs) + | otherwise = let (a', hs') = collect a hs + (b', hs'') = collect b hs' + in (node x a' b', hs'') + +partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLE_GT y h = (h', C.unionList hs) + where (h', hs) = collect h [] + + collect E hs = (E, hs) + collect h@(L _ x a b) hs + | x > y = (E, h:hs) + | otherwise = let (a', hs') = collect a hs + (b', hs'') = collect b hs' + in (node x a' b', hs'') + +partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GT y h = (h', C.unionList hs) + where (h', hs) = collect h [] + + collect E hs = (E, hs) + collect h@(L _ x a b) is = + case compare x y of + GT -> (E, h:is) + EQ -> let (a', hs') = collect a is + (b', hs'') = collect b hs' + in (union a' b', hs'') + LT -> let (a', hs') = collect a is + (b', hs'') = collect b hs' + in (node x a' b', hs'') + +minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +minView E = fail "LeftistHeap.minView: empty collection" +minView (L _ x a b) = return (x, union a b) + +minElem :: Ord a => Heap a -> a +minElem E = error "LeftistHeap.minElem: empty collection" +minElem (L _ x _ _) = x + +maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +maxView E = fail "LeftistHeap.maxView: empty collection" +maxView (L _ x E _) = return (x, E) +maxView (L _ x a E) = return (y, L 1 x a' E) + where (y,a') = fromJust (maxView a) +maxView (L _ x a b) + | y >= z = return (y, node x a' b) + | otherwise = return (z, node x a b') + where (y, a') = fromJust (maxView a) + (z, b') = fromJust (maxView b) + +-- warning: maxView and maxElem may disagree if root is equal to max! + +maxElem :: Ord a => Heap a -> a +maxElem E = error "LeftistHeap.maxElem: empty collection" +maxElem (L _ x E _) = x +maxElem (L _ _ a b) = findMax b (findLeaf a) + where findMax E m = m + findMax (L _ x E _) m + | m >= x = m + | otherwise = x + findMax (L _ _ d c) m = findMax d (findMax c m) + + findLeaf E = error "LeftistHeap.maxElem: bug" + findLeaf (L _ x E _) = x + findLeaf (L _ _ y c) = findMax c (findLeaf y) + +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr _ e E = e +foldr f e (L _ x a b) = f x (foldr f e (union a b)) + +foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr' _ e E = e +foldr' f e (L _ x a b) = e `seq` f x $! (foldr' f e (union a b)) + +foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldl _ e E = e +foldl f e (L _ x a b) = foldl f (f e x) (union a b) + +foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldl' _ e E = e +foldl' f e (L _ x a b) = e `seq` foldl' f (f e x) (union a b) + +foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldr1 _ E = error "LeftistHeap.foldr1: empty collection" +foldr1 _ (L _ x E _) = x +foldr1 f (L _ x a b) = f x (foldr1 f (union a b)) + +foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldr1' _ E = error "LeftistHeap.foldr1': empty collection" +foldr1' _ (L _ x E _) = x +foldr1' f (L _ x a b) = f x $! (foldr1' f (union a b)) + +foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1 _ E = error "LeftistHeap.foldl1: empty collection" +foldl1 f (L _ x a b) = foldl f x (union a b) + +foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1' _ E = error "LeftistHeap.foldl1: empty collection" +foldl1' f (L _ x a b) = foldl' f x (union a b) + +{- ???? -} +unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a +unsafeMapMonotonic _ E = E +unsafeMapMonotonic f (L i x a b) = + L i (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b) + + +-- all fields are already fully strict! +strict :: Heap a -> Heap a +strict h = h + +strictWith :: (a -> b) -> Heap a -> Heap a +strictWith _ h@E = h +strictWith f h@(L _ x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h + +-- the remaining functions all use default definitions + +fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a +fromSeq = fromSeqUsingUnionSeq + +insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a +insertSeq = insertSeqUsingUnion + +unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a +unionSeq = unionSeqUsingReduce + +deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a +deleteSeq = deleteSeqUsingDelete + +lookup :: Ord a => a -> Heap a -> a +lookup = lookupUsingLookupM + +lookupWithDefault :: Ord a => a -> a -> Heap a -> a +lookupWithDefault = lookupWithDefaultUsingLookupM + +unsafeInsertMax :: Ord a => a -> Heap a -> Heap a +unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend + +unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a +unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin + +toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a +toOrdSeq = toOrdSeqUsingFoldr + + +-- instance declarations + +instance Ord a => C.CollX (Heap a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord a => C.OrdCollX (Heap a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Heap a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Heap a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; + foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} + +instance Ord a => Eq (Heap a) where + xs == ys = C.toOrdList xs == C.toOrdList ys + +instance (Ord a, Show a) => Show (Heap a) where + showsPrec = showsPrecUsingToList + +instance (Ord a, Read a) => Read (Heap a) where + readsPrec = readsPrecUsingFromList + + +instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where + arbitrary = sized (\n -> arbTree n) + where arbTree 0 = return E + arbTree n = + frequency [(1, return E), + (4, liftM3 snode arbitrary (arbTree (n `div` 2)) + (arbTree (n `div` 4)))] + + snode x a b = sift (node x a b) + + sift E = E + sift t@(L _ x a E) + | a == E || x <= minElem a = t + sift (L r x (L r' y a b) E) = + L r y (sift (L r' x a b)) E + sift t@(L _ x a b) + | x <= minElem a && x <= minElem b = t + sift (L r x (L r' y a b) c) + | y <= minElem c = + L r y (sift (L r' x a b)) c + sift (L r x a (L r' y b c)) = + L r y a (sift (L r' x b c)) + sift _ = error "LeftistHeap.arbitrary: bug!" + +instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (L _ x a b) = + variant (1 :: Int) . coarbitrary x . coarbitrary a . coarbitrary b + +instance (Ord a) => Semigroup (Heap a) where + (<>) = union + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList
src/Data/Edison/Coll/MinHeap.hs view
@@ -1,406 +1,410 @@--- |--- Module : Data.Edison.Coll.MinHeap--- Copyright : Copyright (c) 1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ A generic adaptor for bags to keep the minimum element separately.--module Data.Edison.Coll.MinHeap (- -- * Min heap adaptor type- Min, -- instance of Coll/CollX, OrdColl/OrdCollX-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,structuralInvariant,-- -- * Coll operations- toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',- fold1, fold1', filter, partition, strictWith,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,- unsafeMapMonotonic,-- -- * Other supported operations- toColl,fromColl,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Edison.Seq.Defaults (tokenMatch,maybeParens)-import Data.Monoid-import Control.Monad-import Test.QuickCheck--data Min h a = E | M a h deriving (Eq)--moduleName :: String-moduleName = "Data.Edison.Coll.MinHeap"--structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool-structuralInvariant E = True-structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h--empty :: Min h a-singleton :: (C.CollX h a,Ord a) => a -> Min h a-fromSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a-insert :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a-union :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a-unionSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a-delete :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a-null :: Min h a -> Bool-size :: C.CollX h a => Min h a -> Int-member :: (C.CollX h a,Ord a) => a -> Min h a -> Bool-count :: (C.CollX h a,Ord a) => a -> Min h a -> Int-strict :: (C.CollX h a,Ord a) => Min h a -> Min h a--toSeq :: (C.Coll h a,S.Sequence s) => Min h a -> s a-lookup :: (C.Coll h a,Ord a) => a -> Min h a -> a-lookupM :: (C.Coll h a,Ord a,Monad m) => a -> Min h a -> m a-lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a-lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a-fold :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b-fold1 :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a-fold' :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b-fold1' :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a-filter :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a-partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a)-strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a--deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a-deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a-unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a-unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a-filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a-filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a-partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)-partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)-partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a)--minView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a)-minElem :: (C.OrdColl h a,Ord a) => Min h a -> a-maxView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a)-maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a-foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b-foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b-foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b-foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b-foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a-toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a-unsafeMapMonotonic :: (C.OrdColl h a,Ord a) =>- (a -> a) -> Min h a -> Min h a--fromColl :: C.OrdColl h a => h -> Min h a-fromColl = fromPrim--toColl :: C.OrdColl h a => Min h a -> h-toColl = toPrim--fromPrim :: (C.OrdColl c a) => c -> Min c a-fromPrim xs = case C.minView xs of- Nothing -> E- Just (x, xs') -> M x xs'--toPrim :: (C.OrdCollX c a) => Min c a -> c-toPrim E = C.empty-toPrim (M x xs) = C.unsafeInsertMin x xs--empty = E-singleton x = M x C.empty--fromSeq = fromPrim . C.fromSeq--insert x E = M x C.empty-insert x (M y xs)- | x <= y = M x (C.unsafeInsertMin y xs)- | otherwise = M y (C.insert x xs)--insertSeq xs E = fromSeq xs-insertSeq xs (M y ys) =- case C.minView xs_ys of- Nothing -> M y C.empty- Just (x, rest)- | x < y -> M x (C.insert y rest)- | otherwise -> M y xs_ys- where xs_ys = C.insertSeq xs ys--union E ys = ys-union xs E = xs-union (M x xs) (M y ys)- | x <= y = M x (C.union xs (C.unsafeInsertMin y ys))- | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys)--unionSeq = unionSeqUsingReduce--delete _ E = E-delete x m@(M y ys)- | x > y = M y (C.delete x ys)- | x == y = fromPrim ys- | otherwise = m--deleteAll _ E = E-deleteAll x m@(M y ys)- | x > y = M y (C.deleteAll x ys)- | x == y = fromPrim (C.deleteAll x ys)- | otherwise = m--deleteSeq = deleteSeqUsingDelete--null E = True-null (M _ _) = False--size E = 0-size (M _ xs) = 1 + C.size xs---member _ E = False-member x (M y ys)- | x > y = C.member x ys- | otherwise = (x == y)--count _ E = 0-count x (M y ys)- | x > y = C.count x ys- | x == y = 1 + C.count x ys- | otherwise = 0--toSeq E = S.empty-toSeq (M x xs) = S.lcons x (C.toSeq xs)--lookup x (M y ys)- | x > y = C.lookup x ys- | x == y = y-lookup _ _ = error "MinHeap.lookup: empty heap"--lookupM x (M y ys)- | x > y = C.lookupM x ys- | x == y = return y-lookupM _ _ = fail "lookupM.lookup: XXX"--lookupAll x (M y ys)- | x > y = C.lookupAll x ys- | x == y = S.lcons y (C.lookupAll x ys)-lookupAll _ _ = S.empty--lookupWithDefault d x (M y ys)- | x > y = C.lookupWithDefault d x ys- | x == y = y-lookupWithDefault d _ _ = d--fold _ e E = e-fold f e (M x xs) = f x (C.fold f e xs)--fold' _ e E = e-fold' f e (M x xs) = f x $! (C.fold' f e xs)--fold1 _ E = error "MinHeap.fold1: empty heap"-fold1 f (M x xs) = C.fold f x xs--fold1' _ E = error "MinHeap.fold1': empty heap"-fold1' f (M x xs) = C.fold' f x xs--filter _ E = E-filter p (M x xs)- | p x = M x (C.filter p xs)- | otherwise = fromPrim (C.filter p xs)--partition _ E = (E, E)-partition p (M x xs)- | p x = (M x ys, fromPrim zs)- | otherwise = (fromPrim ys, M x zs)- where (ys,zs) = C.partition p xs--deleteMin E = E-deleteMin (M _ xs) = fromPrim xs--deleteMax E = E-deleteMax (M x xs)- | C.null xs = E- | otherwise = M x (C.deleteMax xs)--unsafeInsertMin x xs = M x (toPrim xs)--unsafeInsertMax x E = M x C.empty-unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys)--unsafeFromOrdSeq xs =- case S.lview xs of- Nothing -> E- Just (x,xs') -> M x (C.unsafeFromOrdSeq xs')--unsafeAppend E ys = ys-unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys))--filterLT x (M y ys) | y < x = M y (C.filterLT x ys)-filterLT _ _ = E--filterLE x (M y ys) | y <= x = M y (C.filterLE x ys)-filterLE _ _ = E--filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys)-filterGT _ h = h--filterGE x (M y ys) | y < x = fromPrim (C.filterGE x ys)-filterGE _ h = h--partitionLT_GE x (M y ys)- | y < x = (M y lows, fromPrim highs)- where (lows,highs) = C.partitionLT_GE x ys-partitionLT_GE _ h = (E, h)--partitionLE_GT x (M y ys)- | y <= x = (M y lows, fromPrim highs)- where (lows,highs) = C.partitionLE_GT x ys-partitionLE_GT _ h = (E, h)--partitionLT_GT x (M y ys)- | y < x = let (lows,highs) = C.partitionLT_GT x ys- in (M y lows, fromPrim highs)- | y == x = (E, fromPrim (C.filterGT x ys))-partitionLT_GT _ h = (E, h)---minView E = fail "MinHeap.minView: empty heap"-minView (M x xs) = return (x, fromPrim xs)--minElem E = error "MinHeap.minElem: empty heap"-minElem (M x _) = x--maxView E = fail "MinHeap.maxView: empty heap"-maxView (M x xs) = case C.maxView xs of- Nothing -> return (x, E)- Just (y,ys) -> return (y, M x ys)--maxElem E = error "MinHeap.minElem: empty heap"-maxElem (M x xs)- | C.null xs = x- | otherwise = C.maxElem xs--foldr _ e E = e-foldr f e (M x xs) = f x (C.foldr f e xs)--foldr' _ e E = e-foldr' f e (M x xs) = f x $! (C.foldr' f e xs)--foldl _ e E = e-foldl f e (M x xs) = C.foldl f (f e x) xs--foldl' _ e E = e-foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs--foldr1 _ E = error "MinHeap.foldr1: empty heap"-foldr1 f (M x xs)- | C.null xs = x- | otherwise = f x (C.foldr1 f xs)--foldr1' _ E = error "MinHeap.foldr1': empty heap"-foldr1' f (M x xs)- | C.null xs = x- | otherwise = f x $! (C.foldr1' f xs)--foldl1 _ E = error "MinHeap.foldl1: empty heap"-foldl1 f (M x xs) = C.foldl f x xs--foldl1' _ E = error "MinHeap.foldl1': empty heap"-foldl1' f (M x xs) = C.foldl' f x xs--toOrdSeq E = S.empty-toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs)--unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr--strict h@E = h-strict h@(M _ xs) = C.strict xs `seq` h--strictWith _ h@E = h-strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h----- instance declarations--instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr';- foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';- foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;- unsafeMapMonotonic = unsafeMapMonotonic}---- instance Eq is derived--instance (C.OrdColl h a, Show h) => Show (Min h a) where- showsPrec i xs rest- | i == 0 = concat [ moduleName,".fromColl ",showsPrec 10 (toColl xs) rest]- | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)]--instance (C.OrdColl h a, Read h) => Read (Min h a) where- readsPrec _ xs = maybeParens p xs- where p ys = tokenMatch (moduleName++".fromColl") ys- >>= readsPrec 10- >>= \(coll,rest) -> return (fromColl coll,rest)--instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where- arbitrary = do xs <- arbitrary- x <- arbitrary- i <- arbitrary :: Gen Int- return (if C.null xs || x <= C.minElem xs then M x xs- else if odd i then M (C.minElem xs) xs- else fromPrim xs)--instance (C.OrdColl h a,CoArbitrary h,CoArbitrary a) => CoArbitrary (Min h a) where- coarbitrary E = variant 0- coarbitrary (M x xs) = variant 1 . coarbitrary x . coarbitrary xs--instance (C.OrdColl h a) => Monoid (Min h a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Eq h, C.OrdColl h a) => Ord (Min h a) where- compare = compareUsingToOrdList+-- | +-- Module : Data.Edison.Coll.MinHeap +-- Copyright : Copyright (c) 1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- A generic adaptor for bags to keep the minimum element separately. + +module Data.Edison.Coll.MinHeap ( + -- * Min heap adaptor type + Min, -- instance of Coll/CollX, OrdColl/OrdCollX + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict,structuralInvariant, + + -- * Coll operations + toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', + fold1, fold1', filter, partition, strictWith, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq, + unsafeMapMonotonic, + + -- * Other supported operations + toColl,fromColl, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) +import Data.Monoid +import qualified Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + +data Min h a = E | M a h deriving (Eq) + +moduleName :: String +moduleName = "Data.Edison.Coll.MinHeap" + +structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool +structuralInvariant E = True +structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h + +empty :: Min h a +singleton :: (C.CollX h a,Ord a) => a -> Min h a +fromSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a +insert :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a +insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a +union :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a +unionSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a +delete :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a +deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a +deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a +null :: Min h a -> Bool +size :: C.CollX h a => Min h a -> Int +member :: (C.CollX h a,Ord a) => a -> Min h a -> Bool +count :: (C.CollX h a,Ord a) => a -> Min h a -> Int +strict :: (C.CollX h a,Ord a) => Min h a -> Min h a + +toSeq :: (C.Coll h a,S.Sequence s) => Min h a -> s a +lookup :: (C.Coll h a,Ord a) => a -> Min h a -> a +lookupM :: (C.Coll h a, Ord a, Fail.MonadFail m) => a -> Min h a -> m a +lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a +lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a +fold :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b +fold1 :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a +fold' :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b +fold1' :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a +filter :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a +partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a) +strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a + +deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a +deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a +unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a +unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a +unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a +unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a +filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a +filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a +filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a +filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a +partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) +partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) +partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) + +minView :: (C.OrdColl h a, Ord a, Fail.MonadFail m) => Min h a -> m (a, Min h a) +minElem :: (C.OrdColl h a,Ord a) => Min h a -> a +maxView :: (C.OrdColl h a, Ord a, Fail.MonadFail m) => Min h a -> m (a, Min h a) +maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a +foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b +foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b +foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a +foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a +foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b +foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b +foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a +foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a +toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a +unsafeMapMonotonic :: (C.OrdColl h a,Ord a) => + (a -> a) -> Min h a -> Min h a + +fromColl :: C.OrdColl h a => h -> Min h a +fromColl = fromPrim + +toColl :: C.OrdColl h a => Min h a -> h +toColl = toPrim + +fromPrim :: (C.OrdColl c a) => c -> Min c a +fromPrim xs = case C.minView xs of + Nothing -> E + Just (x, xs') -> M x xs' + +toPrim :: (C.OrdCollX c a) => Min c a -> c +toPrim E = C.empty +toPrim (M x xs) = C.unsafeInsertMin x xs + +empty = E +singleton x = M x C.empty + +fromSeq = fromPrim . C.fromSeq + +insert x E = M x C.empty +insert x (M y xs) + | x <= y = M x (C.unsafeInsertMin y xs) + | otherwise = M y (C.insert x xs) + +insertSeq xs E = fromSeq xs +insertSeq xs (M y ys) = + case C.minView xs_ys of + Nothing -> M y C.empty + Just (x, rest) + | x < y -> M x (C.insert y rest) + | otherwise -> M y xs_ys + where xs_ys = C.insertSeq xs ys + +union E ys = ys +union xs E = xs +union (M x xs) (M y ys) + | x <= y = M x (C.union xs (C.unsafeInsertMin y ys)) + | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys) + +unionSeq = unionSeqUsingReduce + +delete _ E = E +delete x m@(M y ys) + | x > y = M y (C.delete x ys) + | x == y = fromPrim ys + | otherwise = m + +deleteAll _ E = E +deleteAll x m@(M y ys) + | x > y = M y (C.deleteAll x ys) + | x == y = fromPrim (C.deleteAll x ys) + | otherwise = m + +deleteSeq = deleteSeqUsingDelete + +null E = True +null (M _ _) = False + +size E = 0 +size (M _ xs) = 1 + C.size xs + + +member _ E = False +member x (M y ys) + | x > y = C.member x ys + | otherwise = (x == y) + +count _ E = 0 +count x (M y ys) + | x > y = C.count x ys + | x == y = 1 + C.count x ys + | otherwise = 0 + +toSeq E = S.empty +toSeq (M x xs) = S.lcons x (C.toSeq xs) + +lookup x (M y ys) + | x > y = C.lookup x ys + | x == y = y +lookup _ _ = error "MinHeap.lookup: empty heap" + +lookupM x (M y ys) + | x > y = C.lookupM x ys + | x == y = return y +lookupM _ _ = fail "lookupM.lookup: XXX" + +lookupAll x (M y ys) + | x > y = C.lookupAll x ys + | x == y = S.lcons y (C.lookupAll x ys) +lookupAll _ _ = S.empty + +lookupWithDefault d x (M y ys) + | x > y = C.lookupWithDefault d x ys + | x == y = y +lookupWithDefault d _ _ = d + +fold _ e E = e +fold f e (M x xs) = f x (C.fold f e xs) + +fold' _ e E = e +fold' f e (M x xs) = f x $! (C.fold' f e xs) + +fold1 _ E = error "MinHeap.fold1: empty heap" +fold1 f (M x xs) = C.fold f x xs + +fold1' _ E = error "MinHeap.fold1': empty heap" +fold1' f (M x xs) = C.fold' f x xs + +filter _ E = E +filter p (M x xs) + | p x = M x (C.filter p xs) + | otherwise = fromPrim (C.filter p xs) + +partition _ E = (E, E) +partition p (M x xs) + | p x = (M x ys, fromPrim zs) + | otherwise = (fromPrim ys, M x zs) + where (ys,zs) = C.partition p xs + +deleteMin E = E +deleteMin (M _ xs) = fromPrim xs + +deleteMax E = E +deleteMax (M x xs) + | C.null xs = E + | otherwise = M x (C.deleteMax xs) + +unsafeInsertMin x xs = M x (toPrim xs) + +unsafeInsertMax x E = M x C.empty +unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys) + +unsafeFromOrdSeq xs = + case S.lview xs of + Nothing -> E + Just (x,xs') -> M x (C.unsafeFromOrdSeq xs') + +unsafeAppend E ys = ys +unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys)) + +filterLT x (M y ys) | y < x = M y (C.filterLT x ys) +filterLT _ _ = E + +filterLE x (M y ys) | y <= x = M y (C.filterLE x ys) +filterLE _ _ = E + +filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys) +filterGT _ h = h + +filterGE x (M y ys) | y < x = fromPrim (C.filterGE x ys) +filterGE _ h = h + +partitionLT_GE x (M y ys) + | y < x = (M y lows, fromPrim highs) + where (lows,highs) = C.partitionLT_GE x ys +partitionLT_GE _ h = (E, h) + +partitionLE_GT x (M y ys) + | y <= x = (M y lows, fromPrim highs) + where (lows,highs) = C.partitionLE_GT x ys +partitionLE_GT _ h = (E, h) + +partitionLT_GT x (M y ys) + | y < x = let (lows,highs) = C.partitionLT_GT x ys + in (M y lows, fromPrim highs) + | y == x = (E, fromPrim (C.filterGT x ys)) +partitionLT_GT _ h = (E, h) + + +minView E = fail "MinHeap.minView: empty heap" +minView (M x xs) = return (x, fromPrim xs) + +minElem E = error "MinHeap.minElem: empty heap" +minElem (M x _) = x + +maxView E = fail "MinHeap.maxView: empty heap" +maxView (M x xs) = case C.maxView xs of + Nothing -> return (x, E) + Just (y,ys) -> return (y, M x ys) + +maxElem E = error "MinHeap.minElem: empty heap" +maxElem (M x xs) + | C.null xs = x + | otherwise = C.maxElem xs + +foldr _ e E = e +foldr f e (M x xs) = f x (C.foldr f e xs) + +foldr' _ e E = e +foldr' f e (M x xs) = f x $! (C.foldr' f e xs) + +foldl _ e E = e +foldl f e (M x xs) = C.foldl f (f e x) xs + +foldl' _ e E = e +foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs + +foldr1 _ E = error "MinHeap.foldr1: empty heap" +foldr1 f (M x xs) + | C.null xs = x + | otherwise = f x (C.foldr1 f xs) + +foldr1' _ E = error "MinHeap.foldr1': empty heap" +foldr1' f (M x xs) + | C.null xs = x + | otherwise = f x $! (C.foldr1' f xs) + +foldl1 _ E = error "MinHeap.foldl1: empty heap" +foldl1 f (M x xs) = C.foldl f x xs + +foldl1' _ E = error "MinHeap.foldl1': empty heap" +foldl1' f (M x xs) = C.foldl' f x xs + +toOrdSeq E = S.empty +toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs) + +unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr + +strict h@E = h +strict h@(M _ xs) = C.strict xs `seq` h + +strictWith _ h@E = h +strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h + + +-- instance declarations + +instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic} + +-- instance Eq is derived + +instance (C.OrdColl h a, Show h) => Show (Min h a) where + showsPrec i xs rest + | i == 0 = concat [ moduleName,".fromColl ",showsPrec 10 (toColl xs) rest] + | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)] + +instance (C.OrdColl h a, Read h) => Read (Min h a) where + readsPrec _ xs = maybeParens p xs + where p ys = tokenMatch (moduleName++".fromColl") ys + >>= readsPrec 10 + >>= \(coll,rest) -> return (fromColl coll,rest) + +instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where + arbitrary = do xs <- arbitrary + x <- arbitrary + i <- arbitrary :: Gen Int + return (if C.null xs || x <= C.minElem xs then M x xs + else if odd i then M (C.minElem xs) xs + else fromPrim xs) + +instance (C.OrdColl h a,CoArbitrary h,CoArbitrary a) => CoArbitrary (Min h a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (M x xs) = variant (1 :: Int) . coarbitrary x . coarbitrary xs + +instance (C.OrdColl h a) => SG.Semigroup (Min h a) where + (<>) = union +instance (C.OrdColl h a) => Monoid (Min h a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Eq h, C.OrdColl h a) => Ord (Min h a) where + compare = compareUsingToOrdList
src/Data/Edison/Coll/SkewHeap.hs view
@@ -1,458 +1,465 @@--- |--- Module : Data.Edison.Coll.SkewHeap--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Skew heaps.------ /References:/------ * Daniel Sleator and Robert Tarjan. \"Self-Adjusting Heaps\".--- /SIAM Journal on Computing/, 15(1):52-69, February 1986.--module Data.Edison.Coll.SkewHeap (- -- * Type of skew heaps- Heap, -- instance of Coll/CollX, OrdColl/OrdCollX-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,structuralInvariant,-- -- * Coll operations- toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',- fold1, fold1', filter, partition, strictWith,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,- unsafeMapMonotonic,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Control.Monad-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.SkewHeap"--data Heap a = E | T a (Heap a) (Heap a)---- invariants:--- * Heap order-structuralInvariant :: Ord a => Heap a -> Bool-structuralInvariant E = True-structuralInvariant t@(T x _ _) = isMin x t- where isMin _ E = True- isMin x (T y l r) = x <= y && isMin y l && isMin y r---{--For delete,deleteAll,filter,partition: could compute fringe and reduce-rather that rebuilding with union at every deleted node--}--empty :: Ord a => Heap a-empty = E--singleton :: Ord a => a -> Heap a-singleton x = T x E E--insert :: Ord a => a -> Heap a -> Heap a-insert x E = T x E E-insert x h@(T y a b)- | x <= y = T x h E- | otherwise = T y (insert x b) a--union :: Ord a => Heap a -> Heap a -> Heap a-union E h = h-union h@(T x a b) h' = union' h x a b h'- where union' h _ _ _ E = h- union' hx x a b hy@(T y c d)- | x <= y = T x (union' hy y c d b) a- | otherwise = T y (union' hx x a b d) c--delete :: Ord a => a -> Heap a -> Heap a-delete x h = case del h of- Just h' -> h'- Nothing -> h- where del (T y a b) =- case compare x y of- LT -> Nothing- EQ -> Just (union a b)- GT -> case del b of- Just b' -> Just (T y a b')- Nothing -> case del a of- Just a' -> Just (T y a' b)- Nothing -> Nothing- del E = Nothing--deleteAll :: Ord a => a -> Heap a -> Heap a-deleteAll x h@(T y a b) =- case compare x y of- LT -> h- EQ -> union (deleteAll x a) (deleteAll x b)- GT -> T y (deleteAll x a) (deleteAll x b)-deleteAll _ E = E--null :: Ord a => Heap a -> Bool-null E = True-null _ = False--size :: Ord a => Heap a -> Int-size h = sz h 0- where sz E i = i- sz (T _ a b) i = sz a (sz b (i + 1))--member :: Ord a => a -> Heap a -> Bool-member _ E = False-member x (T y a b) =- case compare x y of- LT -> False- EQ -> True- GT -> member x b || member x a--count :: Ord a => a -> Heap a -> Int-count _ E = 0-count x (T y a b) =- case compare x y of- LT -> 0- EQ -> 1 + count x b + count x a- GT -> count x b + count x a--toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toSeq h = tol h S.empty- where tol E rest = rest- tol (T x a b) rest = S.lcons x (tol b (tol a rest))--lookupM :: (Ord a, Monad m) => a -> Heap a -> m a-lookupM _ E = fail "SkewHeap.lookupM: XXX"-lookupM x (T y a b) =- case compare x y of- LT -> fail "SkewHeap.lookupM: XXX"- EQ -> return y- GT -> case lookupM x b `mplus` lookupM x a of- Nothing -> fail "SkewHeap.lookupM: XXX"- Just x -> return x--lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a-lookupAll x h = look h S.empty- where look E ys = ys- look (T y a b) ys =- case compare x y of- LT -> ys- EQ -> S.lcons y (look b (look a ys))- GT -> look b (look a ys)--fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold _ e E = e-fold f e (T x a b) = f x (fold f (fold f e a) b)--fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold' _ e E = e-fold' f e (T x a b) = e `seq` f x $! (fold' f (fold' f e a) b)--fold1 :: Ord a => (a -> a -> a) -> Heap a -> a-fold1 _ E = error "SkewHeap.fold1: empty collection"-fold1 f (T x a b) = fold f (fold f x a) b--fold1' :: Ord a => (a -> a -> a) -> Heap a -> a-fold1' _ E = error "SkewHeap.fold1': empty collection"-fold1' f (T x a b) = fold' f (fold' f x a) b--filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-filter _ E = E-filter p (T x a b)- | p x = T x (filter p a) (filter p b)- | otherwise = union (filter p a) (filter p b)--partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-partition _ E = (E, E)-partition p (T x a b)- | p x = (T x a' b', union a'' b'')- | otherwise = (union a' b', T x a'' b'')- where (a', a'') = partition p a- (b', b'') = partition p b---deleteMin :: Ord a => Heap a -> Heap a-deleteMin E = E-deleteMin (T _ a b) = union a b--deleteMax :: Ord a => Heap a -> Heap a-deleteMax h = case maxView h of- Nothing -> E- Just (_,h') -> h'--unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMin x h = T x h E--unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-unsafeAppend E h = h-unsafeAppend (T x a b) h = T x (unsafeAppend b h) a--filterLT :: Ord a => a -> Heap a -> Heap a-filterLT y (T x a b) | x < y = T x (filterLT y a) (filterLT y b)-filterLT _ _ = E--filterLE :: Ord a => a -> Heap a -> Heap a-filterLE y (T x a b) | x <= y = T x (filterLE y a) (filterLE y b)-filterLE _ _ = E--filterGT :: Ord a => a -> Heap a -> Heap a-filterGT y h = C.unionList (collect h [])- where collect E hs = hs- collect h@(T x a b) hs- | x > y = h : hs- | otherwise = collect a (collect b hs)--filterGE :: Ord a => a -> Heap a -> Heap a-filterGE y h = C.unionList (collect h [])- where collect E hs = hs- collect h@(T x a b) hs- | x >= y = h : hs- | otherwise = collect b (collect a hs)--partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GE y h = (h', C.unionList hs)- where (h', hs) = collect h []-- collect E hs = (E, hs)- collect h@(T x a b) hs- | x >= y = (E, h:hs)- | otherwise = let (a', hs') = collect a hs- (b', hs'') = collect b hs'- in (T x a' b', hs'')--partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT y h = (h', C.unionList hs)- where (h', hs) = collect h []-- collect E hs = (E, hs)- collect h@(T x a b) hs- | x > y = (E, h:hs)- | otherwise = let (a', hs') = collect a hs- (b', hs'') = collect b hs'- in (T x a' b', hs'')--partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT y h = (h', C.unionList hs)- where (h', hs) = collect h []-- collect E hs = (E, hs)- collect h@(T x a b) hs =- case compare x y of- GT -> (E, h:hs)- EQ -> let (a', hs') = collect a hs- (b', hs'') = collect b hs'- in (union a' b', hs'')- LT -> let (a', hs') = collect a hs- (b', hs'') = collect b hs'- in (T x a' b', hs'')--minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)-minView E = fail "SkewHeap.minView: empty heap"-minView (T x a b) = return (x, union a b)--minElem :: Ord a => Heap a -> a-minElem E = error "SkewHeap.minElem: empty collection"-minElem (T x _ _) = x--maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a)-maxView E = fail "SkewHeap.maxView: empty heap"-maxView (T x E E) = return (x, E)-maxView (T x a E) = return (y, T x a' E)- where Just (y, a') = maxView a-maxView (T x E a) = return (y, T x a' E)- where Just (y, a') = maxView a-maxView (T x a b)- | y >= z = return (y, T x a' b)- | otherwise = return (z, T x a b')- where Just (y, a') = maxView a- Just (z, b') = maxView b---- warning: maxView and maxElem may disagree if root is equal to max!--maxElem :: Ord a => Heap a -> a-maxElem E = error "SkewHeap.maxElem: empty collection"-maxElem (T x E E) = x-maxElem (T _ a E) = maxElem a-maxElem (T _ E a) = maxElem a-maxElem (T _ a b) = findMax b (findLeaf a)- where findMax E m = m- findMax (T x E E) m- | m >= x = m- | otherwise = x- findMax (T _ a E) m = findMax a m- findMax (T _ E a) m = findMax a m- findMax (T _ a b) m = findMax a (findMax b m)-- findLeaf E = error "SkewHeap.maxElem: bug"- findLeaf (T x E E) = x- findLeaf (T _ a E) = findLeaf a- findLeaf (T _ E a) = findLeaf a- findLeaf (T _ a b) = findMax b (findLeaf a)--foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr _ e E = e-foldr f e (T x a b) = f x (foldr f e (union a b))--foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldr' _ e E = e-foldr' f e (T x a b) = e `seq` f x $! (foldr' f e (union a b))--foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl _ e E = e-foldl f e (T x a b) = foldl f (f e x) (union a b)--foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldl' _ e E = e-foldl' f e (T x a b) = e `seq` foldl' f (f e x) (union a b)--foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1 _ E = error "SkewHeap.foldr1: empty collection"-foldr1 _ (T x E E) = x-foldr1 f (T x a b) = f x (foldr1 f (union a b))--foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldr1' _ E = error "SkewHeap.foldr1': empty collection"-foldr1' _ (T x E E) = x-foldr1' f (T x a b) = f x $! (foldr1' f (union a b))--foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 _ E = error "SkewHeap.foldl1: empty collection"-foldl1 f (T x a b) = foldl f x (union a b)--foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' _ E = error "SkewHeap.foldl1': empty collection"-foldl1' f (T x a b) = foldl' f x (union a b)--{- ???? -}-unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a-unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (T x a b) =- T (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b)---strict :: Heap a -> Heap a-strict h@E = h-strict h@(T _ l r) = strict l `seq` strict r `seq` h--strictWith :: (a -> b) -> Heap a -> Heap a-strictWith _ h@E = h-strictWith f h@(T x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h---- the remaining functions all use default definitions--fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-fromSeq = fromSeqUsingUnionSeq--insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-insertSeq = insertSeqUsingUnion--unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a-unionSeq = unionSeqUsingReduce--deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a-deleteSeq = deleteSeqUsingDelete--lookup :: Ord a => a -> Heap a -> a-lookup = lookupUsingLookupM--lookupWithDefault :: Ord a => a -> a -> Heap a -> a-lookupWithDefault = lookupWithDefaultUsingLookupM--unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend--unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin--toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a-toOrdSeq = toOrdSeqUsingFoldr---- instance declarations--instance Ord a => C.CollX (Heap a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Heap a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr';- foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';- foldl1 = foldl1; foldl1' = fold1'; toOrdSeq = toOrdSeq;- unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => Eq (Heap a) where- xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where- showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where- readsPrec = readsPrecUsingFromList---instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where- arbitrary = sized (\n -> arbTree n)- where arbTree 0 = return E- arbTree n =- frequency [(1, return E),- (4, liftM3 sift arbitrary (arbTree (n `div` 2))- (arbTree (n `div` 4)))]-- sift x (T y a b) E- | y < x = T y (sift x a b) E- sift x E (T y a b)- | y < x = T y E (sift x a b)- sift x s@(T y a b) t@(T z c d)- | y < x && y <= z = T y (sift x a b) t- | z < x = T z s (sift x c d)- sift x a b = T x a b--instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where- coarbitrary E = variant 0- coarbitrary (T x a b) =- variant 1 . coarbitrary x . coarbitrary a . coarbitrary b--instance (Ord a) => Monoid (Heap a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where- compare = compareUsingToOrdList+-- | +-- Module : Data.Edison.Coll.SkewHeap +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Skew heaps. +-- +-- /References:/ +-- +-- * Daniel Sleator and Robert Tarjan. \"Self-Adjusting Heaps\". +-- /SIAM Journal on Computing/, 15(1):52-69, February 1986. + +module Data.Edison.Coll.SkewHeap ( + -- * Type of skew heaps + Heap, -- instance of Coll/CollX, OrdColl/OrdCollX + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict,structuralInvariant, + + -- * Coll operations + toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', + fold1, fold1', filter, partition, strictWith, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq, + unsafeMapMonotonic, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Maybe (fromJust) +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail + +import Test.QuickCheck + +moduleName :: String +moduleName = "Data.Edison.Coll.SkewHeap" + +data Heap a = E | T a (Heap a) (Heap a) + +-- invariants: +-- * Heap order +structuralInvariant :: Ord a => Heap a -> Bool +structuralInvariant E = True +structuralInvariant t@(T x _ _) = isMin x t + where isMin _ E = True + isMin x (T y l r) = x <= y && isMin y l && isMin y r + + +{- +For delete,deleteAll,filter,partition: could compute fringe and reduce +rather that rebuilding with union at every deleted node +-} + +empty :: Ord a => Heap a +empty = E + +singleton :: Ord a => a -> Heap a +singleton x = T x E E + +insert :: Ord a => a -> Heap a -> Heap a +insert x E = T x E E +insert x h@(T y a b) + | x <= y = T x h E + | otherwise = T y (insert x b) a + +union :: Ord a => Heap a -> Heap a -> Heap a +union E h = h +union h@(T x a b) h' = union' h x a b h' + where union' h _ _ _ E = h + union' hx x a b hy@(T y c d) + | x <= y = T x (union' hy y c d b) a + | otherwise = T y (union' hx x a b d) c + +delete :: Ord a => a -> Heap a -> Heap a +delete x h = case del h of + Just h' -> h' + Nothing -> h + where del (T y a b) = + case compare x y of + LT -> Nothing + EQ -> Just (union a b) + GT -> case del b of + Just b' -> Just (T y a b') + Nothing -> case del a of + Just a' -> Just (T y a' b) + Nothing -> Nothing + del E = Nothing + +deleteAll :: Ord a => a -> Heap a -> Heap a +deleteAll x h@(T y a b) = + case compare x y of + LT -> h + EQ -> union (deleteAll x a) (deleteAll x b) + GT -> T y (deleteAll x a) (deleteAll x b) +deleteAll _ E = E + +null :: Ord a => Heap a -> Bool +null E = True +null _ = False + +size :: Ord a => Heap a -> Int +size h = sz h 0 + where sz E i = i + sz (T _ a b) i = sz a (sz b (i + 1)) + +member :: Ord a => a -> Heap a -> Bool +member _ E = False +member x (T y a b) = + case compare x y of + LT -> False + EQ -> True + GT -> member x b || member x a + +count :: Ord a => a -> Heap a -> Int +count _ E = 0 +count x (T y a b) = + case compare x y of + LT -> 0 + EQ -> 1 + count x b + count x a + GT -> count x b + count x a + +toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a +toSeq h = tol h S.empty + where tol E rest = rest + tol (T x a b) rest = S.lcons x (tol b (tol a rest)) + +lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a +lookupM _ E = fail "SkewHeap.lookupM: XXX" +lookupM x (T y a b) = + case compare x y of + LT -> fail "SkewHeap.lookupM: XXX" + EQ -> return y + GT -> case lookupM x b `mplus` lookupM x a of + Nothing -> fail "SkewHeap.lookupM: XXX" + Just x -> return x + +lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a +lookupAll x h = look h S.empty + where look E ys = ys + look (T y a b) ys = + case compare x y of + LT -> ys + EQ -> S.lcons y (look b (look a ys)) + GT -> look b (look a ys) + +fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b +fold _ e E = e +fold f e (T x a b) = f x (fold f (fold f e a) b) + +fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +fold' _ e E = e +fold' f e (T x a b) = e `seq` f x $! (fold' f (fold' f e a) b) + +fold1 :: Ord a => (a -> a -> a) -> Heap a -> a +fold1 _ E = error "SkewHeap.fold1: empty collection" +fold1 f (T x a b) = fold f (fold f x a) b + +fold1' :: Ord a => (a -> a -> a) -> Heap a -> a +fold1' _ E = error "SkewHeap.fold1': empty collection" +fold1' f (T x a b) = fold' f (fold' f x a) b + +filter :: Ord a => (a -> Bool) -> Heap a -> Heap a +filter _ E = E +filter p (T x a b) + | p x = T x (filter p a) (filter p b) + | otherwise = union (filter p a) (filter p b) + +partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) +partition _ E = (E, E) +partition p (T x a b) + | p x = (T x a' b', union a'' b'') + | otherwise = (union a' b', T x a'' b'') + where (a', a'') = partition p a + (b', b'') = partition p b + + +deleteMin :: Ord a => Heap a -> Heap a +deleteMin E = E +deleteMin (T _ a b) = union a b + +deleteMax :: Ord a => Heap a -> Heap a +deleteMax h = case maxView h of + Nothing -> E + Just (_,h') -> h' + +unsafeInsertMin :: Ord a => a -> Heap a -> Heap a +unsafeInsertMin x h = T x h E + +unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a +unsafeAppend E h = h +unsafeAppend (T x a b) h = T x (unsafeAppend b h) a + +filterLT :: Ord a => a -> Heap a -> Heap a +filterLT y (T x a b) | x < y = T x (filterLT y a) (filterLT y b) +filterLT _ _ = E + +filterLE :: Ord a => a -> Heap a -> Heap a +filterLE y (T x a b) | x <= y = T x (filterLE y a) (filterLE y b) +filterLE _ _ = E + +filterGT :: Ord a => a -> Heap a -> Heap a +filterGT y h = C.unionList (collect h []) + where collect E hs = hs + collect h@(T x a b) hs + | x > y = h : hs + | otherwise = collect a (collect b hs) + +filterGE :: Ord a => a -> Heap a -> Heap a +filterGE y h = C.unionList (collect h []) + where collect E hs = hs + collect h@(T x a b) hs + | x >= y = h : hs + | otherwise = collect b (collect a hs) + +partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GE y h = (h', C.unionList hs) + where (h', hs) = collect h [] + + collect E hs = (E, hs) + collect h@(T x a b) hs + | x >= y = (E, h:hs) + | otherwise = let (a', hs') = collect a hs + (b', hs'') = collect b hs' + in (T x a' b', hs'') + +partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLE_GT y h = (h', C.unionList hs) + where (h', hs) = collect h [] + + collect E hs = (E, hs) + collect h@(T x a b) hs + | x > y = (E, h:hs) + | otherwise = let (a', hs') = collect a hs + (b', hs'') = collect b hs' + in (T x a' b', hs'') + +partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GT y h = (h', C.unionList hs) + where (h', hs) = collect h [] + + collect E hs = (E, hs) + collect h@(T x a b) hs = + case compare x y of + GT -> (E, h:hs) + EQ -> let (a', hs') = collect a hs + (b', hs'') = collect b hs' + in (union a' b', hs'') + LT -> let (a', hs') = collect a hs + (b', hs'') = collect b hs' + in (T x a' b', hs'') + +minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +minView E = fail "SkewHeap.minView: empty heap" +minView (T x a b) = return (x, union a b) + +minElem :: Ord a => Heap a -> a +minElem E = error "SkewHeap.minElem: empty collection" +minElem (T x _ _) = x + +maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +maxView E = fail "SkewHeap.maxView: empty heap" +maxView (T x E E) = return (x, E) +maxView (T x a E) = return (y, T x a' E) + where (y, a') = fromJust (maxView a) +maxView (T x E a) = return (y, T x a' E) + where (y, a') = fromJust (maxView a) +maxView (T x a b) + | y >= z = return (y, T x a' b) + | otherwise = return (z, T x a b') + where (y, a') = fromJust (maxView a) + (z, b') = fromJust (maxView b) + +-- warning: maxView and maxElem may disagree if root is equal to max! + +maxElem :: Ord a => Heap a -> a +maxElem E = error "SkewHeap.maxElem: empty collection" +maxElem (T x E E) = x +maxElem (T _ a E) = maxElem a +maxElem (T _ E a) = maxElem a +maxElem (T _ a b) = findMax b (findLeaf a) + where findMax E m = m + findMax (T x E E) m + | m >= x = m + | otherwise = x + findMax (T _ a E) m = findMax a m + findMax (T _ E a) m = findMax a m + findMax (T _ a b) m = findMax a (findMax b m) + + findLeaf E = error "SkewHeap.maxElem: bug" + findLeaf (T x E E) = x + findLeaf (T _ a E) = findLeaf a + findLeaf (T _ E a) = findLeaf a + findLeaf (T _ a b) = findMax b (findLeaf a) + +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr _ e E = e +foldr f e (T x a b) = f x (foldr f e (union a b)) + +foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr' _ e E = e +foldr' f e (T x a b) = e `seq` f x $! (foldr' f e (union a b)) + +foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldl _ e E = e +foldl f e (T x a b) = foldl f (f e x) (union a b) + +foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldl' _ e E = e +foldl' f e (T x a b) = e `seq` foldl' f (f e x) (union a b) + +foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldr1 _ E = error "SkewHeap.foldr1: empty collection" +foldr1 _ (T x E E) = x +foldr1 f (T x a b) = f x (foldr1 f (union a b)) + +foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldr1' _ E = error "SkewHeap.foldr1': empty collection" +foldr1' _ (T x E E) = x +foldr1' f (T x a b) = f x $! (foldr1' f (union a b)) + +foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1 _ E = error "SkewHeap.foldl1: empty collection" +foldl1 f (T x a b) = foldl f x (union a b) + +foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1' _ E = error "SkewHeap.foldl1': empty collection" +foldl1' f (T x a b) = foldl' f x (union a b) + +{- ???? -} +unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a +unsafeMapMonotonic _ E = E +unsafeMapMonotonic f (T x a b) = + T (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b) + + +strict :: Heap a -> Heap a +strict h@E = h +strict h@(T _ l r) = strict l `seq` strict r `seq` h + +strictWith :: (a -> b) -> Heap a -> Heap a +strictWith _ h@E = h +strictWith f h@(T x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h + +-- the remaining functions all use default definitions + +fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a +fromSeq = fromSeqUsingUnionSeq + +insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a +insertSeq = insertSeqUsingUnion + +unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a +unionSeq = unionSeqUsingReduce + +deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a +deleteSeq = deleteSeqUsingDelete + +lookup :: Ord a => a -> Heap a -> a +lookup = lookupUsingLookupM + +lookupWithDefault :: Ord a => a -> a -> Heap a -> a +lookupWithDefault = lookupWithDefaultUsingLookupM + +unsafeInsertMax :: Ord a => a -> Heap a -> Heap a +unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend + +unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a +unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin + +toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a +toOrdSeq = toOrdSeqUsingFoldr + +-- instance declarations + +instance Ord a => C.CollX (Heap a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord a => C.OrdCollX (Heap a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Heap a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Heap a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = fold1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic} + +instance Ord a => Eq (Heap a) where + xs == ys = C.toOrdList xs == C.toOrdList ys + +instance (Ord a, Show a) => Show (Heap a) where + showsPrec = showsPrecUsingToList + +instance (Ord a, Read a) => Read (Heap a) where + readsPrec = readsPrecUsingFromList + + +instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where + arbitrary = sized (\n -> arbTree n) + where arbTree 0 = return E + arbTree n = + frequency [(1, return E), + (4, liftM3 sift arbitrary (arbTree (n `div` 2)) + (arbTree (n `div` 4)))] + + sift x (T y a b) E + | y < x = T y (sift x a b) E + sift x E (T y a b) + | y < x = T y E (sift x a b) + sift x s@(T y a b) t@(T z c d) + | y < x && y <= z = T y (sift x a b) t + | z < x = T z s (sift x c d) + sift x a b = T x a b + +instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (T x a b) = + variant (1 :: Int) . coarbitrary x . coarbitrary a . coarbitrary b + +instance (Ord a) => Semigroup (Heap a) where + (<>) = union + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList
src/Data/Edison/Coll/SplayHeap.hs view
@@ -1,494 +1,498 @@--- |--- Module : Data.Edison.Coll.SplayHeap--- Copyright : Copyright (c) 1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Splay heaps.------ If 'minElem' is called frequently, then SplayHeap should--- be used in conjunction with "Data.Edison.Coll.MinHeap".------ /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.--- Section 5.4.--module Data.Edison.Coll.SplayHeap (- -- * Type of splay heaps- Heap, -- instance of Coll/CollX, OrdColl/OrdCollX-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,structuralInvariant,-- -- * Coll operations- toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold',- fold1, fold1', filter, partition, strictWith,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,- unsafeMapMonotonic,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Control.Monad-import Test.QuickCheck--moduleName :: String-moduleName = "Data.Edison.Coll.SplayHeap"--data Heap a = E | T (Heap a) a (Heap a)---- invariants:--- * Binary Search Tree order (allowing duplicates)--structuralInvariant :: Ord a => Heap a -> Bool-structuralInvariant t = bounded Nothing Nothing t- where bounded _ _ E = True- bounded lo hi (T l x r) = cmp_l lo x- && cmp_r x hi- && bounded lo (Just x) l- && bounded (Just x) hi r-- cmp_l Nothing _ = True- cmp_l (Just x) y = x <= y-- cmp_r _ Nothing = True- cmp_r x (Just y) = x <= y---empty :: Heap a-singleton :: a -> Heap a-fromSeq :: (Ord a,S.Sequence s) => s a -> Heap a-insert :: Ord a => a -> Heap a -> Heap a-insertSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a-union :: Ord a => Heap a -> Heap a -> Heap a-unionSeq :: (Ord a,S.Sequence s) => s (Heap a) -> Heap a-delete :: Ord a => a -> Heap a -> Heap a-deleteAll :: Ord a => a -> Heap a -> Heap a-deleteSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a-null :: Heap a -> Bool-size :: Heap a -> Int-member :: Ord a => a -> Heap a -> Bool-count :: Ord a => a -> Heap a -> Int-strict :: Heap a -> Heap a--toSeq :: (Ord a, S.Sequence s) => Heap a -> s a-lookup :: Ord a => a -> Heap a -> a-lookupM :: (Ord a,Monad m) => a -> Heap a -> m a-lookupAll :: (Ord a,S.Sequence s) => a -> Heap a -> s a-lookupWithDefault :: Ord a => a -> a -> Heap a -> a-fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold1 :: Ord a => (a -> a -> a) -> Heap a -> a-fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-fold1' :: Ord a => (a -> a -> a) -> Heap a -> a-filter :: Ord a => (a -> Bool) -> Heap a -> Heap a-partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a)-strictWith :: (a -> b) -> Heap a -> Heap a--deleteMin :: Ord a => Heap a -> Heap a-deleteMax :: Ord a => Heap a -> Heap a-unsafeInsertMin :: Ord a => a -> Heap a -> Heap a-unsafeInsertMax :: Ord a => a -> Heap a -> Heap a-unsafeFromOrdSeq :: (Ord a,S.Sequence s) => s a -> Heap a-unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a-filterLT :: Ord a => a -> Heap a -> Heap a-filterLE :: Ord a => a -> Heap a -> Heap a-filterGT :: Ord a => a -> Heap a -> Heap a-filterGE :: Ord a => a -> Heap a -> Heap a-partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)-partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a)--minView :: (Ord a,Monad m) => Heap a -> m (a, Heap a)-minElem :: Ord a => Heap a -> a-maxView :: (Ord a,Monad m) => Heap a -> m (a, Heap a)-maxElem :: Ord a => Heap a -> a-foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a-foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b-foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b-foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a-foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a-toOrdSeq :: (Ord a,S.Sequence s) => Heap a -> s a--unsafeMapMonotonic :: (a -> b) -> Heap a -> Heap b--empty = E-singleton x = T E x E--insert x xs = T a x b- where (a,b) = partitionLE_GT x xs--union E ys = ys-union (T a x b) ys = T (union c a) x (union d b)- where (c,d) = partitionLE_GT x ys--delete x xs =- let (a,b) = partitionLE_GT x xs- in case maxView a of- Nothing -> b- Just (y, a')- | x > y -> T a' y b- | otherwise -> unsafeAppend a' b--deleteAll x xs = unsafeAppend a b- where (a,b) = partitionLT_GT x xs--null E = True-null (T _ _ _) = False--size = sz 0- where sz n E = n- sz n (T a _ b) = sz (sz (1+n) a) b--member _ E = False-member x (T a y b) = if x < y then member x a else x==y || member x b--count = cnt 0- where cnt n _ E = n- cnt n x (T a y b)- | x < y = cnt n x a- | x > y = cnt n x b- | otherwise = cnt (cnt (1+n) x a) x b--toSeq xs = tos xs S.empty- where tos E rest = rest- tos (T a x b) rest = S.lcons x (tos a (tos b rest))--lookup _ E = error "SplayHeap.lookup: empty heap"-lookup x (T a y b)- | x < y = lookup x a- | x > y = lookup x b- | otherwise = y--lookupM _ E = fail "SplayHeap.lookup: empty heap"-lookupM x (T a y b)- | x < y = lookupM x a- | x > y = lookupM x b- | otherwise = return y--lookupWithDefault d _ E = d-lookupWithDefault d x (T a y b)- | x < y = lookupWithDefault d x a- | x > y = lookupWithDefault d x b- | otherwise = y--lookupAll x xs = look xs x S.empty- where look E _ rest = rest- look (T a y b) x rest- | x < y = look a x rest- | x > y = look b x rest- | otherwise = look a x (S.lcons y (look b x rest))--fold _ e E = e-fold f e (T a x b) = f x (fold f (fold f e b) a)--fold' _ e E = e-fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a)--fold1 _ E = error "SplayHeap.fold1: empty heap"-fold1 f (T a x b) = fold f (fold f x b) a--fold1' _ E = error "SplayHeap.fold1': empty heap"-fold1' f (T a x b) = fold' f (fold' f x b) a--filter _ E = E-filter p (T a x b)- | p x = T (filter p a) x (filter p b)- | otherwise = unsafeAppend (filter p a) (filter p b)--partition _ E = (E, E)-partition p (T a x b)- | p x = (T a0 x b0, unsafeAppend a1 b1)- | otherwise = (unsafeAppend a0 b0, T a1 x b1)- where (a0,a1) = partition p a- (b0,b1) = partition p b--deleteMin E = E-deleteMin (T a x b) = del a x b- where del E _ b = b- del (T E _ b) y c = T b y c- del (T (T a x b) y c) z d = T (del a x b) y (T c z d)--deleteMax E = E-deleteMax (T a x b) = del a x b- where del a _ E = a- del a x (T b _ E) = T a x b- del a x (T b y (T c z d)) = T (T a x b) y (del c z d)--unsafeInsertMin x xs = T E x xs-unsafeInsertMax x xs = T xs x E--unsafeAppend a b = case maxView a of- Nothing -> b- Just (x, a') -> T a' x b--filterLT _ E = E-filterLT k t@(T a x b) =- if x >= k then filterLT k a- else case b of- E -> t- T ba y bb ->- if y >= k then T a x (filterLT k ba)- else T (T a x ba) y (filterLT k bb)--filterLE _ E = E-filterLE k t@(T a x b) =- if x > k then filterLE k a- else case b of- E -> t- T ba y bb ->- if y > k then T a x (filterLE k ba)- else T (T a x ba) y (filterLE k bb)--filterGT _ E = E-filterGT k t@(T a x b) =- if x <= k then filterGT k b- else case a of- E -> t- T aa y ab ->- if y <= k then T (filterGT k ab) x b- else T (filterGT k aa) y (T ab x b)--filterGE _ E = E-filterGE k t@(T a x b) =- if x < k then filterGE k b- else case a of- E -> t- T aa y ab ->- if y < k then T (filterGE k ab) x b- else T (filterGE k aa) y (T ab x b)--partitionLT_GE _ E = (E,E)-partitionLT_GE k t@(T a x b) =- if x >= k then- case a of- E -> (E,t)- T aa y ab ->- if y >= k then- let (small,big) = partitionLT_GE k aa- in (small, T big y (T ab x b))- else- let (small,big) = partitionLT_GE k ab- in (T aa y small, T big x b)- else- case b of- E -> (t,E)- T ba y bb ->- if y >= k then- let (small,big) = partitionLT_GE k ba- in (T a x small, T big y bb)- else- let (small,big) = partitionLT_GE k bb- in (T (T a x ba) y small, big)--partitionLE_GT _ E = (E,E)-partitionLE_GT k t@(T a x b) =- if x > k then- case a of- E -> (E,t)- T aa y ab ->- if y > k then- let (small,big) = partitionLE_GT k aa- in (small, T big y (T ab x b))- else- let (small,big) = partitionLE_GT k ab- in (T aa y small, T big x b)- else- case b of- E -> (t,E)- T ba y bb ->- if y > k then- let (small,big) = partitionLE_GT k ba- in (T a x small, T big y bb)- else- let (small,big) = partitionLE_GT k bb- in (T (T a x ba) y small, big)----- could specialize calls to filterLT/filterGT-partitionLT_GT _ E = (E,E)-partitionLT_GT k t@(T a x b) =- if x > k then- case a of- E -> (E,t)- T aa y ab ->- if y > k then- let (small,big) = partitionLT_GT k aa- in (small, T big y (T ab x b))- else if y < k then- let (small,big) = partitionLT_GT k ab- in (T aa y small, T big x b)- else (filterLT k aa, T (filterGT k ab) x b)- else if x < k then- case b of- E -> (t,E)- T ba y bb ->- if y > k then- let (small,big) = partitionLT_GT k ba- in (T a x small, T big y bb)- else if y < k then- let (small,big) = partitionLT_GT k bb- in (T (T a x ba) y small, big)- else (T a x (filterLT k ba), filterGT k bb)- else (filterLT k a, filterGT k b)--minView E = fail "SplayHeap.minView: empty heap"-minView (T a x b) = return (y, ys)- where (y,ys) = minv a x b- minv E x b = (x,b)- minv (T E x b) y c = (x,T b y c)- minv (T (T a x b) y c) z d = (w,T ab y (T c z d))- where (w,ab) = minv a x b--minElem E = error "SplayHeap.minElem: empty heap"-minElem (T a x _) = minel a x- where minel E x = x- minel (T a x _) _ = minel a x---maxView E = fail "SplayHeap.maxView: empty heap"-maxView (T a x b) = return (y,ys)- where (ys,y) = maxv a x b- maxv a x E = (a,x)- maxv a x (T b y E) = (T a x b,y)- maxv a x (T b y (T c z d)) = (T (T a x b) y cd,w)- where (cd,w) = maxv c z d--maxElem E = error "SplayHeap.minElem: empty heap"-maxElem (T _ x b) = maxel x b- where maxel x E = x- maxel _ (T _ x b) = maxel x b--foldr _ e E = e-foldr f e (T a x b) = foldr f (f x (foldr f e b)) a--foldr' _ e E = e-foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a--foldl _ e E = e-foldl f e (T a x b) = foldl f (f (foldl f e a) x) b--foldl' _ e E = e-foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b--foldr1 _ E = error "SplayHeap.foldr1: empty heap"-foldr1 f (T a x b) = foldr f (myfold f x b) a- where myfold _ x E = x- myfold f x (T a y b) = f x (foldr f (myfold f y b) a)--foldr1' _ E = error "SplayHeap.foldr1': empty heap"-foldr1' f (T a x b) = foldr' f (myfold f x b) a- where myfold _ x E = x- myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a)--foldl1 _ E = error "SplayHeap.foldl1: empty heap"-foldl1 f (T a x b) = foldl f (myfold f a x) b- where myfold _ E x = x- myfold f (T a x b) y = f (foldl f (myfold f a x) b) y--foldl1' _ E = error "SplayHeap.foldl1': empty heap"-foldl1' f (T a x b) = foldl' f (myfold f a x) b- where myfold _ E x = x- myfold f (T a x b) y = (f $! (foldl f (myfold f a x) b)) y--toOrdSeq xs = tos xs S.empty- where tos E rest = rest- tos (T a x b) rest = tos a (S.lcons x (tos b rest))--unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (T a x b) =- T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)--strict h@E = h-strict h@(T l _ r) = strict l `seq` strict r `seq` h--strictWith _ h@E = h-strictWith f h@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h---- the remaining functions all use defaults--fromSeq = fromSeqUsingFoldr-insertSeq = insertSeqUsingFoldr-unionSeq = unionSeqUsingReduce-deleteSeq = deleteSeqUsingDelete-unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin---- instance declarations--instance Ord a => C.CollX (Heap a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Heap a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Heap a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- strictWith = strictWith;- filter = filter; partition = partition}--instance Ord a => C.OrdColl (Heap a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;- foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';- foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;- unsafeMapMonotonic = unsafeMapMonotonic}---instance Ord a => Eq (Heap a) where- xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Heap a) where- showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Heap a) where- readsPrec = readsPrecUsingFromList--instance (Ord a,Arbitrary a) => Arbitrary (Heap a) where- arbitrary = do xs <- arbitrary- return (C.fromList xs)--instance (Ord a,CoArbitrary a) => CoArbitrary (Heap a) where- coarbitrary E = variant 0- coarbitrary (T a x b) =- variant 1 . coarbitrary a . coarbitrary x . coarbitrary b--instance (Ord a) => Monoid (Heap a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Ord a) => Ord (Heap a) where- compare = compareUsingToOrdList+-- | +-- Module : Data.Edison.Coll.SplayHeap +-- Copyright : Copyright (c) 1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Splay heaps. +-- +-- If 'minElem' is called frequently, then SplayHeap should +-- be used in conjunction with "Data.Edison.Coll.MinHeap". +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. +-- Section 5.4. + +module Data.Edison.Coll.SplayHeap ( + -- * Type of splay heaps + Heap, -- instance of Coll/CollX, OrdColl/OrdCollX + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict,structuralInvariant, + + -- * Coll operations + toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', + fold1, fold1', filter, partition, strictWith, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq, + unsafeMapMonotonic, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + +moduleName :: String +moduleName = "Data.Edison.Coll.SplayHeap" + +data Heap a = E | T (Heap a) a (Heap a) + +-- invariants: +-- * Binary Search Tree order (allowing duplicates) + +structuralInvariant :: Ord a => Heap a -> Bool +structuralInvariant t = bounded Nothing Nothing t + where bounded _ _ E = True + bounded lo hi (T l x r) = cmp_l lo x + && cmp_r x hi + && bounded lo (Just x) l + && bounded (Just x) hi r + + cmp_l Nothing _ = True + cmp_l (Just x) y = x <= y + + cmp_r _ Nothing = True + cmp_r x (Just y) = x <= y + + +empty :: Heap a +singleton :: a -> Heap a +fromSeq :: (Ord a,S.Sequence s) => s a -> Heap a +insert :: Ord a => a -> Heap a -> Heap a +insertSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a +union :: Ord a => Heap a -> Heap a -> Heap a +unionSeq :: (Ord a,S.Sequence s) => s (Heap a) -> Heap a +delete :: Ord a => a -> Heap a -> Heap a +deleteAll :: Ord a => a -> Heap a -> Heap a +deleteSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a +null :: Heap a -> Bool +size :: Heap a -> Int +member :: Ord a => a -> Heap a -> Bool +count :: Ord a => a -> Heap a -> Int +strict :: Heap a -> Heap a + +toSeq :: (Ord a, S.Sequence s) => Heap a -> s a +lookup :: Ord a => a -> Heap a -> a +lookupM :: (Ord a, Fail.MonadFail m) => a -> Heap a -> m a +lookupAll :: (Ord a,S.Sequence s) => a -> Heap a -> s a +lookupWithDefault :: Ord a => a -> a -> Heap a -> a +fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b +fold1 :: Ord a => (a -> a -> a) -> Heap a -> a +fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +fold1' :: Ord a => (a -> a -> a) -> Heap a -> a +filter :: Ord a => (a -> Bool) -> Heap a -> Heap a +partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) +strictWith :: (a -> b) -> Heap a -> Heap a + +deleteMin :: Ord a => Heap a -> Heap a +deleteMax :: Ord a => Heap a -> Heap a +unsafeInsertMin :: Ord a => a -> Heap a -> Heap a +unsafeInsertMax :: Ord a => a -> Heap a -> Heap a +unsafeFromOrdSeq :: (Ord a,S.Sequence s) => s a -> Heap a +unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a +filterLT :: Ord a => a -> Heap a -> Heap a +filterLE :: Ord a => a -> Heap a -> Heap a +filterGT :: Ord a => a -> Heap a -> Heap a +filterGE :: Ord a => a -> Heap a -> Heap a +partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) + +minView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +minElem :: Ord a => Heap a -> a +maxView :: (Ord a, Fail.MonadFail m) => Heap a -> m (a, Heap a) +maxElem :: Ord a => Heap a -> a +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a +foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b +foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a +foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a +toOrdSeq :: (Ord a,S.Sequence s) => Heap a -> s a + +unsafeMapMonotonic :: (a -> b) -> Heap a -> Heap b + +empty = E +singleton x = T E x E + +insert x xs = T a x b + where (a,b) = partitionLE_GT x xs + +union E ys = ys +union (T a x b) ys = T (union c a) x (union d b) + where (c,d) = partitionLE_GT x ys + +delete x xs = + let (a,b) = partitionLE_GT x xs + in case maxView a of + Nothing -> b + Just (y, a') + | x > y -> T a' y b + | otherwise -> unsafeAppend a' b + +deleteAll x xs = unsafeAppend a b + where (a,b) = partitionLT_GT x xs + +null E = True +null (T _ _ _) = False + +size = sz 0 + where sz n E = n + sz n (T a _ b) = sz (sz (1+n) a) b + +member _ E = False +member x (T a y b) = if x < y then member x a else x==y || member x b + +count = cnt 0 + where cnt n _ E = n + cnt n x (T a y b) + | x < y = cnt n x a + | x > y = cnt n x b + | otherwise = cnt (cnt (1+n) x a) x b + +toSeq xs = tos xs S.empty + where tos E rest = rest + tos (T a x b) rest = S.lcons x (tos a (tos b rest)) + +lookup _ E = error "SplayHeap.lookup: empty heap" +lookup x (T a y b) + | x < y = lookup x a + | x > y = lookup x b + | otherwise = y + +lookupM _ E = fail "SplayHeap.lookup: empty heap" +lookupM x (T a y b) + | x < y = lookupM x a + | x > y = lookupM x b + | otherwise = return y + +lookupWithDefault d _ E = d +lookupWithDefault d x (T a y b) + | x < y = lookupWithDefault d x a + | x > y = lookupWithDefault d x b + | otherwise = y + +lookupAll x xs = look xs x S.empty + where look E _ rest = rest + look (T a y b) x rest + | x < y = look a x rest + | x > y = look b x rest + | otherwise = look a x (S.lcons y (look b x rest)) + +fold _ e E = e +fold f e (T a x b) = f x (fold f (fold f e b) a) + +fold' _ e E = e +fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a) + +fold1 _ E = error "SplayHeap.fold1: empty heap" +fold1 f (T a x b) = fold f (fold f x b) a + +fold1' _ E = error "SplayHeap.fold1': empty heap" +fold1' f (T a x b) = fold' f (fold' f x b) a + +filter _ E = E +filter p (T a x b) + | p x = T (filter p a) x (filter p b) + | otherwise = unsafeAppend (filter p a) (filter p b) + +partition _ E = (E, E) +partition p (T a x b) + | p x = (T a0 x b0, unsafeAppend a1 b1) + | otherwise = (unsafeAppend a0 b0, T a1 x b1) + where (a0,a1) = partition p a + (b0,b1) = partition p b + +deleteMin E = E +deleteMin (T a x b) = del a x b + where del E _ b = b + del (T E _ b) y c = T b y c + del (T (T a x b) y c) z d = T (del a x b) y (T c z d) + +deleteMax E = E +deleteMax (T a x b) = del a x b + where del a _ E = a + del a x (T b _ E) = T a x b + del a x (T b y (T c z d)) = T (T a x b) y (del c z d) + +unsafeInsertMin x xs = T E x xs +unsafeInsertMax x xs = T xs x E + +unsafeAppend a b = case maxView a of + Nothing -> b + Just (x, a') -> T a' x b + +filterLT _ E = E +filterLT k t@(T a x b) = + if x >= k then filterLT k a + else case b of + E -> t + T ba y bb -> + if y >= k then T a x (filterLT k ba) + else T (T a x ba) y (filterLT k bb) + +filterLE _ E = E +filterLE k t@(T a x b) = + if x > k then filterLE k a + else case b of + E -> t + T ba y bb -> + if y > k then T a x (filterLE k ba) + else T (T a x ba) y (filterLE k bb) + +filterGT _ E = E +filterGT k t@(T a x b) = + if x <= k then filterGT k b + else case a of + E -> t + T aa y ab -> + if y <= k then T (filterGT k ab) x b + else T (filterGT k aa) y (T ab x b) + +filterGE _ E = E +filterGE k t@(T a x b) = + if x < k then filterGE k b + else case a of + E -> t + T aa y ab -> + if y < k then T (filterGE k ab) x b + else T (filterGE k aa) y (T ab x b) + +partitionLT_GE _ E = (E,E) +partitionLT_GE k t@(T a x b) = + if x >= k then + case a of + E -> (E,t) + T aa y ab -> + if y >= k then + let (small,big) = partitionLT_GE k aa + in (small, T big y (T ab x b)) + else + let (small,big) = partitionLT_GE k ab + in (T aa y small, T big x b) + else + case b of + E -> (t,E) + T ba y bb -> + if y >= k then + let (small,big) = partitionLT_GE k ba + in (T a x small, T big y bb) + else + let (small,big) = partitionLT_GE k bb + in (T (T a x ba) y small, big) + +partitionLE_GT _ E = (E,E) +partitionLE_GT k t@(T a x b) = + if x > k then + case a of + E -> (E,t) + T aa y ab -> + if y > k then + let (small,big) = partitionLE_GT k aa + in (small, T big y (T ab x b)) + else + let (small,big) = partitionLE_GT k ab + in (T aa y small, T big x b) + else + case b of + E -> (t,E) + T ba y bb -> + if y > k then + let (small,big) = partitionLE_GT k ba + in (T a x small, T big y bb) + else + let (small,big) = partitionLE_GT k bb + in (T (T a x ba) y small, big) + + +-- could specialize calls to filterLT/filterGT +partitionLT_GT _ E = (E,E) +partitionLT_GT k t@(T a x b) = + if x > k then + case a of + E -> (E,t) + T aa y ab -> + if y > k then + let (small,big) = partitionLT_GT k aa + in (small, T big y (T ab x b)) + else if y < k then + let (small,big) = partitionLT_GT k ab + in (T aa y small, T big x b) + else (filterLT k aa, T (filterGT k ab) x b) + else if x < k then + case b of + E -> (t,E) + T ba y bb -> + if y > k then + let (small,big) = partitionLT_GT k ba + in (T a x small, T big y bb) + else if y < k then + let (small,big) = partitionLT_GT k bb + in (T (T a x ba) y small, big) + else (T a x (filterLT k ba), filterGT k bb) + else (filterLT k a, filterGT k b) + +minView E = fail "SplayHeap.minView: empty heap" +minView (T a x b) = return (y, ys) + where (y,ys) = minv a x b + minv E x b = (x,b) + minv (T E x b) y c = (x,T b y c) + minv (T (T a x b) y c) z d = (w,T ab y (T c z d)) + where (w,ab) = minv a x b + +minElem E = error "SplayHeap.minElem: empty heap" +minElem (T a x _) = minel a x + where minel E x = x + minel (T a x _) _ = minel a x + + +maxView E = fail "SplayHeap.maxView: empty heap" +maxView (T a x b) = return (y,ys) + where (ys,y) = maxv a x b + maxv a x E = (a,x) + maxv a x (T b y E) = (T a x b,y) + maxv a x (T b y (T c z d)) = (T (T a x b) y cd,w) + where (cd,w) = maxv c z d + +maxElem E = error "SplayHeap.minElem: empty heap" +maxElem (T _ x b) = maxel x b + where maxel x E = x + maxel _ (T _ x b) = maxel x b + +foldr _ e E = e +foldr f e (T a x b) = foldr f (f x (foldr f e b)) a + +foldr' _ e E = e +foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a + +foldl _ e E = e +foldl f e (T a x b) = foldl f (f (foldl f e a) x) b + +foldl' _ e E = e +foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b + +foldr1 _ E = error "SplayHeap.foldr1: empty heap" +foldr1 f (T a x b) = foldr f (myfold f x b) a + where myfold _ x E = x + myfold f x (T a y b) = f x (foldr f (myfold f y b) a) + +foldr1' _ E = error "SplayHeap.foldr1': empty heap" +foldr1' f (T a x b) = foldr' f (myfold f x b) a + where myfold _ x E = x + myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a) + +foldl1 _ E = error "SplayHeap.foldl1: empty heap" +foldl1 f (T a x b) = foldl f (myfold f a x) b + where myfold _ E x = x + myfold f (T a x b) y = f (foldl f (myfold f a x) b) y + +foldl1' _ E = error "SplayHeap.foldl1': empty heap" +foldl1' f (T a x b) = foldl' f (myfold f a x) b + where myfold _ E x = x + myfold f (T a x b) y = (f $! (foldl f (myfold f a x) b)) y + +toOrdSeq xs = tos xs S.empty + where tos E rest = rest + tos (T a x b) rest = tos a (S.lcons x (tos b rest)) + +unsafeMapMonotonic _ E = E +unsafeMapMonotonic f (T a x b) = + T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b) + +strict h@E = h +strict h@(T l _ r) = strict l `seq` strict r `seq` h + +strictWith _ h@E = h +strictWith f h@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h + +-- the remaining functions all use defaults + +fromSeq = fromSeqUsingFoldr +insertSeq = insertSeqUsingFoldr +unionSeq = unionSeqUsingReduce +deleteSeq = deleteSeqUsingDelete +unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin + +-- instance declarations + +instance Ord a => C.CollX (Heap a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord a => C.OrdCollX (Heap a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Heap a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + strictWith = strictWith; + filter = filter; partition = partition} + +instance Ord a => C.OrdColl (Heap a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; + foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic} + + +instance Ord a => Eq (Heap a) where + xs == ys = C.toOrdList xs == C.toOrdList ys + +instance (Ord a, Show a) => Show (Heap a) where + showsPrec = showsPrecUsingToList + +instance (Ord a, Read a) => Read (Heap a) where + readsPrec = readsPrecUsingFromList + +instance (Ord a,Arbitrary a) => Arbitrary (Heap a) where + arbitrary = do xs <- arbitrary + return (C.fromList xs) + +instance (Ord a,CoArbitrary a) => CoArbitrary (Heap a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (T a x b) = + variant (1 :: Int) . coarbitrary a . coarbitrary x . coarbitrary b + +instance (Ord a) => Semigroup (Heap a) where + (<>) = union +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList
src/Data/Edison/Coll/StandardSet.hs view
@@ -1,272 +1,265 @@--- |--- Module : Data.Edison.Coll--- Copyright : Copyright (c) 2006, 2008 Robert Dockins--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ The standard library "Data.Set" repackaged as an Edison collection.--module Data.Edison.Coll.StandardSet (- -- * Set type- Set,-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,-- -- * Coll operations- toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',- fold1,fold1',filter,partition,strictWith,structuralInvariant,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,-- -- * SetX operations- intersection,difference,symmetricDifference,properSubset,subset,-- -- * Set operations- fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,- unionSeqWith,intersectionWith,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Prelude-import qualified Data.List--import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Coll.Defaults-import Test.QuickCheck--import qualified Data.Set as DS---- signatures for exported functions-moduleName :: String-empty :: Set a-singleton :: a -> Set a-fromSeq :: (Ord a,S.Sequence seq) => seq a -> Set a-insert :: Ord a => a -> Set a -> Set a-insertSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-union :: Ord a => Set a -> Set a -> Set a-unionSeq :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a-delete :: Ord a => a -> Set a -> Set a-deleteAll :: Ord a => a -> Set a -> Set a-deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-null :: Set a -> Bool-size :: Set a -> Int-member :: Ord a => a -> Set a -> Bool-count :: Ord a => a -> Set a -> Int-strict :: Ord a => Set a -> Set a--toSeq :: (Ord a,S.Sequence seq) => Set a -> seq a-lookup :: Ord a => a -> Set a -> a-lookupM :: (Ord a,Monad m) => a -> Set a -> m a-lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a-lookupWithDefault :: Ord a => a -> a -> Set a -> a-fold :: (a -> b -> b) -> b -> Set a -> b-fold1 :: (a -> a -> a) -> Set a -> a-fold' :: (a -> b -> b) -> b -> Set a -> b-fold1' :: (a -> a -> a) -> Set a -> a-filter :: Ord a => (a -> Bool) -> Set a -> Set a-partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)-strictWith :: Ord a => (a -> b) -> Set a -> Set a--deleteMin :: Ord a => Set a -> Set a-deleteMax :: Ord a => Set a -> Set a-unsafeInsertMin :: Ord a => a -> Set a -> Set a-unsafeInsertMax :: Ord a => a -> Set a -> Set a-unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a-unsafeAppend :: Ord a => Set a -> Set a -> Set a-filterLT :: Ord a => a -> Set a -> Set a-filterLE :: Ord a => a -> Set a -> Set a-filterGT :: Ord a => a -> Set a -> Set a-filterGE :: Ord a => a -> Set a -> Set a-partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a)-partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a)-partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a)--minView :: (Ord a,Monad m) => Set a -> m (a, Set a)-minElem :: Set a -> a-maxView :: (Ord a,Monad m) => Set a -> m (a, Set a)-maxElem :: Set a -> a-foldr :: (a -> b -> b) -> b -> Set a -> b-foldl :: (b -> a -> b) -> b -> Set a -> b-foldr1 :: (a -> a -> a) -> Set a -> a-foldl1 :: (a -> a -> a) -> Set a -> a-foldr' :: (a -> b -> b) -> b -> Set a -> b-foldl' :: (b -> a -> b) -> b -> Set a -> b-foldr1' :: (a -> a -> a) -> Set a -> a-foldl1' :: (a -> a -> a) -> Set a -> a-toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a--intersection :: Ord a => Set a -> Set a -> Set a-difference :: Ord a => Set a -> Set a -> Set a-symmetricDifference :: Ord a => Set a -> Set a -> Set a-properSubset :: Ord a => Set a -> Set a -> Bool-subset :: Ord a => Set a -> Set a -> Bool--fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a-insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a-insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a-unionl :: Ord a => Set a -> Set a -> Set a-unionr :: Ord a => Set a -> Set a -> Set a-unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a-intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a--moduleName = "Data.Edison.Coll.StandardSet"--type Set = DS.Set--structuralInvariant :: Ord a => Set a -> Bool-structuralInvariant = DS.valid--empty = DS.empty-singleton = DS.singleton-fromSeq = fromSeqUsingFoldr-insert = DS.insert-insertSeq = insertSeqUsingUnion-union = DS.union-unionSeq se = DS.unions $ S.toList se-delete = DS.delete-deleteAll = DS.delete -- by set property-deleteSeq = deleteSeqUsingDelete-null = DS.null-size = DS.size-member = DS.member-count = countUsingMember-strict xs = DS.fold (flip const) () xs `seq` xs--toSeq = toSeqUsingFold-lookup el set = DS.findMin (DS.intersection set (DS.singleton el))-lookupM = lookupMUsingLookupAll-lookupAll el set = toSeqUsingFold (DS.intersection set (DS.singleton el))-lookupWithDefault = lookupWithDefaultUsingLookupAll-fold = DS.fold-fold' f x xs = L.foldl' (flip f) x (DS.toList xs)-fold1 f set = let (x,s) = DS.deleteFindMin set in DS.fold f x s-fold1' f xs = L.foldl1' (flip f) (DS.toList xs)-filter = DS.filter-partition = DS.partition-strictWith f xs = DS.fold (\x z -> f x `seq` z) () xs `seq` xs--deleteMin = DS.deleteMin-deleteMax = DS.deleteMax-unsafeInsertMin = DS.insert-unsafeInsertMax = DS.insert-unsafeFromOrdSeq = DS.fromDistinctAscList . S.toList-unsafeAppend = DS.union-filterLT x = fst . DS.split x-filterLE x = DS.filter (<=x)-filterGT x = snd . DS.split x-filterGE x = DS.filter (>=x)-partitionLT_GE x = DS.partition (<x)-partitionLE_GT x = DS.partition (<=x)-partitionLT_GT = DS.split--minView set = if DS.null set- then fail (moduleName ++ ".minView: failed")- else return (DS.deleteFindMin set)-minElem = DS.findMin--maxView set = if DS.null set- then fail (moduleName ++ ".maxView: failed")- else return (DS.deleteFindMax set)-maxElem = DS.findMax--foldr f x set = L.foldr f x (DS.toAscList set)-foldr' f x set = L.foldr' f x (DS.toAscList set)-foldr1 f set = L.foldr1 f (DS.toAscList set)-foldr1' f set = L.foldr1' f (DS.toAscList set)-foldl f x set = L.foldl f x (DS.toAscList set)-foldl' f x set = L.foldl' f x (DS.toAscList set)-foldl1 f set = L.foldl1 f (DS.toAscList set)-foldl1' f set = L.foldl1' f (DS.toAscList set)--toOrdSeq = S.fromList . DS.toAscList--intersection = DS.intersection-difference = DS.difference-symmetricDifference = symmetricDifferenceUsingDifference-properSubset = DS.isProperSubsetOf-subset = DS.isSubsetOf--fromSeqWith = fromSeqWithUsingInsertWith-insertWith f x set = case lookupM x set of- Nothing -> DS.insert x set- Just x' -> DS.insert (f x x') set-insertSeqWith = insertSeqWithUsingInsertWith-unionl = DS.union-unionr = flip DS.union-unionWith = unionWithUsingOrdLists-unionSeqWith = unionSeqWithUsingReducer-intersectionWith = intersectionWithUsingOrdLists-unsafeMapMonotonic = DS.mapMonotonic----instance Ord a => C.CollX (Set a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Set a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Set a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Set a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl;- foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';- foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;- unsafeMapMonotonic = unsafeMapMonotonic }--instance Ord a => C.SetX (Set a) a where- {intersection = intersection; difference = difference;- symmetricDifference = symmetricDifference;- properSubset = properSubset; subset = subset}--instance Ord a => C.Set (Set a) a where- {fromSeqWith = fromSeqWith; insertWith = insertWith;- insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;- unionWith = unionWith; unionSeqWith = unionSeqWith;- intersectionWith = intersectionWith}--instance Ord a => C.OrdSetX (Set a) a--instance Ord a => C.OrdSet (Set a) a---instance (Ord a, Arbitrary a) => Arbitrary (Set a) where- arbitrary = do xs <- arbitrary- return (Prelude.foldr insert empty xs)--instance (Ord a, CoArbitrary a) => CoArbitrary (Set a) where- coarbitrary set = coarbitrary (C.toList set)+-- | +-- Module : Data.Edison.Coll +-- Copyright : Copyright (c) 2006, 2008 Robert Dockins +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- The standard library "Data.Set" repackaged as an Edison collection. + +module Data.Edison.Coll.StandardSet ( + -- * Set type + Set, + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict, + + -- * Coll operations + toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold', + fold1,fold1',filter,partition,strictWith,structuralInvariant, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic, + + -- * SetX operations + intersection,difference,symmetricDifference,properSubset,subset, + + -- * Set operations + fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith, + unionSeqWith,intersectionWith, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Prelude +import qualified Control.Monad.Fail as Fail +import qualified Data.List + +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Coll.Defaults +import Test.QuickCheck + +import qualified Data.Set as DS + +-- signatures for exported functions +moduleName :: String +empty :: Set a +singleton :: a -> Set a +fromSeq :: (Ord a,S.Sequence seq) => seq a -> Set a +insert :: Ord a => a -> Set a -> Set a +insertSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a +union :: Ord a => Set a -> Set a -> Set a +unionSeq :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a +delete :: Ord a => a -> Set a -> Set a +deleteAll :: Ord a => a -> Set a -> Set a +deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a +null :: Set a -> Bool +size :: Set a -> Int +member :: Ord a => a -> Set a -> Bool +count :: Ord a => a -> Set a -> Int +strict :: Ord a => Set a -> Set a + +toSeq :: (Ord a,S.Sequence seq) => Set a -> seq a +lookup :: Ord a => a -> Set a -> a +lookupM :: (Ord a, Monad m, Fail.MonadFail m) => a -> Set a -> m a +lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a +lookupWithDefault :: Ord a => a -> a -> Set a -> a +fold :: (a -> b -> b) -> b -> Set a -> b +fold1 :: (a -> a -> a) -> Set a -> a +fold' :: (a -> b -> b) -> b -> Set a -> b +fold1' :: (a -> a -> a) -> Set a -> a +filter :: Ord a => (a -> Bool) -> Set a -> Set a +partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a) +strictWith :: Ord a => (a -> b) -> Set a -> Set a + +deleteMin :: Ord a => Set a -> Set a +deleteMax :: Ord a => Set a -> Set a +unsafeInsertMin :: Ord a => a -> Set a -> Set a +unsafeInsertMax :: Ord a => a -> Set a -> Set a +unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a +unsafeAppend :: Ord a => Set a -> Set a -> Set a +filterLT :: Ord a => a -> Set a -> Set a +filterLE :: Ord a => a -> Set a -> Set a +filterGT :: Ord a => a -> Set a -> Set a +filterGE :: Ord a => a -> Set a -> Set a +partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a) +partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a) +partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a) + +minView :: (Ord a, Monad m, Fail.MonadFail m) => Set a -> m (a, Set a) +minElem :: Set a -> a +maxView :: (Ord a, Monad m, Fail.MonadFail m) => Set a -> m (a, Set a) +maxElem :: Set a -> a +foldr :: (a -> b -> b) -> b -> Set a -> b +foldl :: (b -> a -> b) -> b -> Set a -> b +foldr1 :: (a -> a -> a) -> Set a -> a +foldl1 :: (a -> a -> a) -> Set a -> a +foldr' :: (a -> b -> b) -> b -> Set a -> b +foldl' :: (b -> a -> b) -> b -> Set a -> b +foldr1' :: (a -> a -> a) -> Set a -> a +foldl1' :: (a -> a -> a) -> Set a -> a +toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a + +intersection :: Ord a => Set a -> Set a -> Set a +difference :: Ord a => Set a -> Set a -> Set a +symmetricDifference :: Ord a => Set a -> Set a -> Set a +properSubset :: Ord a => Set a -> Set a -> Bool +subset :: Ord a => Set a -> Set a -> Bool + +fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a +insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a +insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a +unionl :: Ord a => Set a -> Set a -> Set a +unionr :: Ord a => Set a -> Set a -> Set a +unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a +unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a +intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a +unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a + +moduleName = "Data.Edison.Coll.StandardSet" + +type Set = DS.Set + +structuralInvariant :: Ord a => Set a -> Bool +structuralInvariant = DS.valid + +empty = DS.empty +singleton = DS.singleton +fromSeq = fromSeqUsingFoldr +insert = DS.insert +insertSeq = insertSeqUsingUnion +union = DS.union +unionSeq se = DS.unions $ S.toList se +delete = DS.delete +deleteAll = DS.delete -- by set property +deleteSeq = deleteSeqUsingDelete +null = DS.null +size = DS.size +member = DS.member +count = countUsingMember +strict xs = DS.fold (flip const) () xs `seq` xs + +toSeq = toSeqUsingFold +lookup el set = DS.findMin (DS.intersection set (DS.singleton el)) +lookupM = lookupMUsingLookupAll +lookupAll el set = toSeqUsingFold (DS.intersection set (DS.singleton el)) +lookupWithDefault = lookupWithDefaultUsingLookupAll +fold = DS.fold +fold' f x xs = L.foldl' (flip f) x (DS.toList xs) +fold1 f set = let (x,s) = DS.deleteFindMin set in DS.fold f x s +fold1' f xs = L.foldl1' (flip f) (DS.toList xs) +filter = DS.filter +partition = DS.partition +strictWith f xs = DS.fold (\x z -> f x `seq` z) () xs `seq` xs + +deleteMin = DS.deleteMin +deleteMax = DS.deleteMax +unsafeInsertMin = DS.insert +unsafeInsertMax = DS.insert +unsafeFromOrdSeq = DS.fromDistinctAscList . S.toList +unsafeAppend = DS.union +filterLT x = fst . DS.split x +filterLE x = DS.filter (<=x) +filterGT x = snd . DS.split x +filterGE x = DS.filter (>=x) +partitionLT_GE x = DS.partition (<x) +partitionLE_GT x = DS.partition (<=x) +partitionLT_GT = DS.split + +minView set = if DS.null set + then fail (moduleName ++ ".minView: failed") + else return (DS.deleteFindMin set) +minElem = DS.findMin + +maxView set = if DS.null set + then fail (moduleName ++ ".maxView: failed") + else return (DS.deleteFindMax set) +maxElem = DS.findMax + +foldr f x set = L.foldr f x (DS.toAscList set) +foldr' f x set = L.foldr' f x (DS.toAscList set) +foldr1 f set = L.foldr1 f (DS.toAscList set) +foldr1' f set = L.foldr1' f (DS.toAscList set) +foldl f x set = L.foldl f x (DS.toAscList set) +foldl' f x set = L.foldl' f x (DS.toAscList set) +foldl1 f set = L.foldl1 f (DS.toAscList set) +foldl1' f set = L.foldl1' f (DS.toAscList set) + +toOrdSeq = S.fromList . DS.toAscList + +intersection = DS.intersection +difference = DS.difference +symmetricDifference = symmetricDifferenceUsingDifference +properSubset = DS.isProperSubsetOf +subset = DS.isSubsetOf + +fromSeqWith = fromSeqWithUsingInsertWith +insertWith f x set = case lookupM x set of + Nothing -> DS.insert x set + Just x' -> DS.insert (f x x') set +insertSeqWith = insertSeqWithUsingInsertWith +unionl = DS.union +unionr = flip DS.union +unionWith = unionWithUsingOrdLists +unionSeqWith = unionSeqWithUsingReducer +intersectionWith = intersectionWithUsingOrdLists +unsafeMapMonotonic = DS.mapMonotonic + + + +instance Ord a => C.CollX (Set a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord a => C.OrdCollX (Set a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Set a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Set a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; + foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic } + +instance Ord a => C.SetX (Set a) a where + {intersection = intersection; difference = difference; + symmetricDifference = symmetricDifference; + properSubset = properSubset; subset = subset} + +instance Ord a => C.Set (Set a) a where + {fromSeqWith = fromSeqWith; insertWith = insertWith; + insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; + unionWith = unionWith; unionSeqWith = unionSeqWith; + intersectionWith = intersectionWith} + +instance Ord a => C.OrdSetX (Set a) a + +instance Ord a => C.OrdSet (Set a) a
src/Data/Edison/Coll/UnbalancedSet.hs view
@@ -1,438 +1,444 @@--- |--- Module : Data.Edison.Coll.UnbalancedSet--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Sets implemented as unbalanced binary search trees.--module Data.Edison.Coll.UnbalancedSet (- -- * Set type- Set, -- instance of Coll/CollX, OrdColl/OrdCollX, Set/SetX, OrdSet/OrdSetX-- -- * CollX operations- empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll,- deleteSeq,null,size,member,count,strict,structuralInvariant,-- -- * Coll operations- toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold',- fold1,fold1',filter,partition,strictWith,-- -- * OrdCollX operations- deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq,- unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE,- partitionLE_GT,partitionLT_GT,-- -- * OrdColl operations- minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl',- foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic,-- -- * SetX operations- intersection,difference,symmetricDifference,properSubset,subset,-- -- * Set operations- fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith,- unionSeqWith,intersectionWith,-- -- * Documentation- moduleName-) where--import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter)-import qualified Prelude-import qualified Data.Edison.Coll as C-import qualified Data.Edison.Seq as S-import Data.Edison.Coll.Defaults-import Data.Monoid-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Set a-singleton :: a -> Set a-fromSeq :: (Ord a,S.Sequence seq) => seq a -> Set a-insert :: Ord a => a -> Set a -> Set a-insertSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-union :: Ord a => Set a -> Set a -> Set a-unionSeq :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a-delete :: Ord a => a -> Set a -> Set a-deleteAll :: Ord a => a -> Set a -> Set a-deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a-null :: Set a -> Bool-size :: Set a -> Int-member :: Ord a => a -> Set a -> Bool-count :: Ord a => a -> Set a -> Int-strict :: Set a -> Set a--toSeq :: (Ord a,S.Sequence seq) => Set a -> seq a-lookup :: Ord a => a -> Set a -> a-lookupM :: (Ord a,Monad m) => a -> Set a -> m a-lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a-lookupWithDefault :: Ord a => a -> a -> Set a -> a-fold :: (a -> b -> b) -> b -> Set a -> b-fold1 :: (a -> a -> a) -> Set a -> a-fold' :: (a -> b -> b) -> b -> Set a -> b-fold1' :: (a -> a -> a) -> Set a -> a-filter :: Ord a => (a -> Bool) -> Set a -> Set a-partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a)-strictWith :: (a -> b) -> Set a -> Set a--deleteMin :: Ord a => Set a -> Set a-deleteMax :: Ord a => Set a -> Set a-unsafeInsertMin :: Ord a => a -> Set a -> Set a-unsafeInsertMax :: Ord a => a -> Set a -> Set a-unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a-unsafeAppend :: Ord a => Set a -> Set a -> Set a-filterLT :: Ord a => a -> Set a -> Set a-filterLE :: Ord a => a -> Set a -> Set a-filterGT :: Ord a => a -> Set a -> Set a-filterGE :: Ord a => a -> Set a -> Set a-partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a)-partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a)-partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a)--minView :: (Monad m) => Set a -> m (a, Set a)-minElem :: Set a -> a-maxView :: (Monad m) => Set a -> m (a, Set a)-maxElem :: Set a -> a-foldr :: (a -> b -> b) -> b -> Set a -> b-foldl :: (b -> a -> b) -> b -> Set a -> b-foldr1 :: (a -> a -> a) -> Set a -> a-foldl1 :: (a -> a -> a) -> Set a -> a-foldr' :: (a -> b -> b) -> b -> Set a -> b-foldl' :: (b -> a -> b) -> b -> Set a -> b-foldr1' :: (a -> a -> a) -> Set a -> a-foldl1' :: (a -> a -> a) -> Set a -> a-toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a--intersection :: Ord a => Set a -> Set a -> Set a-difference :: Ord a => Set a -> Set a -> Set a-symmetricDifference :: Ord a => Set a -> Set a -> Set a-properSubset :: Ord a => Set a -> Set a -> Bool-subset :: Ord a => Set a -> Set a -> Bool--fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a-insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a-insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a-unionl :: Ord a => Set a -> Set a -> Set a-unionr :: Ord a => Set a -> Set a -> Set a-unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a-intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a-unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a--moduleName = "Data.Edison.Coll.UnbalancedSet"--data Set a = E | T (Set a) a (Set a)---- invariants:--- * Binary Search Tree order-structuralInvariant :: Ord a => Set a -> Bool-structuralInvariant t = bounded Nothing Nothing t- where bounded _ _ E = True- bounded lo hi (T l x r) = cmp_l lo x- && cmp_r x hi- && bounded lo (Just x) l- && bounded (Just x) hi r-- cmp_l Nothing _ = True- cmp_l (Just x) y = x < y-- cmp_r _ Nothing = True- cmp_r x (Just y) = x < y----empty = E-singleton x = T E x E--insertWith c x = ins- where ins E = T E x E- ins (T a y b) =- case compare x y of- LT -> T (ins a) y b- EQ -> T a (c x y) b- GT -> T a y (ins b)--delete _ E = E-delete x (T a y b) =- case compare x y of- LT -> T (delete x a) y b- EQ -> unsafeAppend a b- GT -> T a y (delete x b)--null E = True-null (T _ _ _) = False--size t = sz t 0- where sz E i = i- sz (T a _ b) i = sz a (sz b (i+1))--member _ E = False-member x (T a y b) =- case compare x y of- LT -> member x a- EQ -> True- GT -> member x b--lookupM _ E = fail "UnbalancedSet.lookupM: XXX"-lookupM x (T a y b) =- case compare x y of- LT -> lookupM x a- EQ -> return y- GT -> lookupM x b--fold _ e E = e-fold f e (T a x b) = f x (fold f (fold f e a) b)--fold' _ e E = e-fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b)--fold1 _ E = error "UnbalancedSet.fold1: empty collection"-fold1 f (T a x b) = fold f (fold f x a) b--fold1' _ E = error "UnbalancedSet.fold1': empty collection"-fold1' f (T a x b) = fold' f (fold' f x a) b--deleteMin E = E-deleteMin (T E _ b) = b-deleteMin (T a x b) = T (deleteMin a) x b--deleteMax E = E-deleteMax (T a _ E) = a-deleteMax (T a x b) = T a x (deleteMax b)--unsafeInsertMin x t = T E x t-unsafeInsertMax x t = T t x E--unsafeFromOrdSeq xs = fst (ins xs (S.size xs))- where ins ys 0 = (E,ys)- ins ys n = let m = n `div` 2- (a,ys') = ins ys m- Just (y,ys'') = S.lview ys'- (b,ys''') = ins ys'' (n - m - 1)- in (T a y b,ys''')--unsafeAppend a b = case minView b of- Nothing -> a- Just (x,b') -> T a x b'--filterLT _ E = E-filterLT y (T a x b) =- case compare x y of- LT -> T a x (filterLT y b)- EQ -> a- GT -> filterLT y a--filterLE _ E = E-filterLE y (T a x b) =- case compare x y of- LT -> T a x (filterLE y b)- EQ -> T a x E- GT -> filterLE y a--filterGT _ E = E-filterGT y (T a x b) =- case compare x y of- LT -> filterGT y b- EQ -> b- GT -> T (filterGT y a) x b--filterGE _ E = E-filterGE y (T a x b) =- case compare x y of- LT -> filterGE y b- EQ -> T E x b- GT -> T (filterGE y a) x b--partitionLT_GE _ E = (E,E)-partitionLT_GE y (T a x b) =- case compare x y of- LT -> (T a x b0,b1)- where (b0,b1) = partitionLT_GE y b- EQ -> (a,T E x b)- GT -> (a0,T a1 x b)- where (a0,a1) = partitionLT_GE y a--partitionLE_GT _ E = (E,E)-partitionLE_GT y (T a x b) =- case compare x y of- LT -> (T a x b0,b1)- where (b0,b1) = partitionLE_GT y b- EQ -> (T a x E,b)- GT -> (a0,T a1 x b)- where (a0,a1) = partitionLE_GT y a--partitionLT_GT _ E = (E,E)-partitionLT_GT y (T a x b) =- case compare x y of- LT -> (T a x b0,b1)- where (b0,b1) = partitionLT_GT y b- EQ -> (a,b)- GT -> (a0,T a1 x b)- where (a0,a1) = partitionLT_GT y a--minView E = fail "UnbalancedSet.minView: empty collection"-minView (T E x b) = return (x, b)-minView (T a x b) = return (y, T a' x b)- where Just (y,a') = minView a--minElem E = error "UnbalancedSet.minElem: empty collection"-minElem (T E x _) = x-minElem (T a _ _) = minElem a--maxView E = fail "UnbalancedSet.maxView: empty collection"-maxView (T a x E) = return (x, a)-maxView (T a x b) = return (y, T a x b')- where Just (y, b') = maxView b--maxElem E = error "UnbalancedSet.maxElem: empty collection"-maxElem (T _ x E) = x-maxElem (T _ _ b) = maxElem b--foldr _ e E = e-foldr f e (T a x b) = foldr f (f x (foldr f e b)) a--foldr' _ e E = e-foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a--foldl _ e E = e-foldl f e (T a x b) = foldl f (f (foldl f e a) x) b--foldl' _ e E = e-foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b--foldr1 _ E = error "UnbalancedSet.foldr1: empty collection"-foldr1 f (T a x E) = foldr f x a-foldr1 f (T a x b) = foldr f (f x (foldr1 f b)) a--foldr1' _ E = error "UnbalancedSet.foldr1': empty collection"-foldr1' f (T a x E) = foldr' f x a-foldr1' f (T a x b) = foldr' f (f x $! (foldr1' f b)) a--foldl1 _ E = error "UnbalancedSet.foldl1: empty collection"-foldl1 f (T E x b) = foldl f x b-foldl1 f (T a x b) = foldl f (f (foldl1 f a) x) b--foldl1' _ E = error "UnbalancedSet.foldl1': empty collection"-foldl1' f (T E x b) = foldl' f x b-foldl1' f (T a x b) = foldl' f ((f $! (foldl1' f a)) x) b--unsafeMapMonotonic _ E = E-unsafeMapMonotonic f (T a x b) =- T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b)--strict s@E = s-strict s@(T l _ r) = strict l `seq` strict r `seq` s--strictWith _ s@E = s-strictWith f s@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s---- the remaining functions all use default definitions--fromSeq = fromSeqUsingUnionSeq-insert = insertUsingInsertWith-insertSeq = insertSeqUsingUnion-union = unionUsingUnionWith-unionSeq = unionSeqUsingReduce-deleteAll = delete-deleteSeq = deleteSeqUsingDelete-count = countUsingMember--toSeq = toSeqUsingFold-lookup = lookupUsingLookupM-lookupAll = lookupAllUsingLookupM-lookupWithDefault = lookupWithDefaultUsingLookupM-filter = filterUsingOrdLists-partition = partitionUsingOrdLists-toOrdSeq = toOrdSeqUsingFoldr--intersection = intersectionUsingIntersectionWith-difference = differenceUsingOrdLists-symmetricDifference = symmetricDifferenceUsingDifference-properSubset = properSubsetUsingOrdLists-subset = subsetUsingOrdLists-fromSeqWith = fromSeqWithUsingInsertWith-insertSeqWith = insertSeqWithUsingInsertWith-unionl = unionlUsingUnionWith-unionr = unionrUsingUnionWith-unionWith = unionWithUsingOrdLists-unionSeqWith = unionSeqWithUsingReducer-intersectionWith = intersectionWithUsingOrdLists---- instance declarations--instance Ord a => C.CollX (Set a) a where- {singleton = singleton; fromSeq = fromSeq; insert = insert;- insertSeq = insertSeq; unionSeq = unionSeq;- delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq;- null = null; size = size; member = member; count = count;- strict = strict;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Ord a => C.OrdCollX (Set a) a where- {deleteMin = deleteMin; deleteMax = deleteMax;- unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax;- unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend;- filterLT = filterLT; filterLE = filterLE; filterGT = filterGT;- filterGE = filterGE; partitionLT_GE = partitionLT_GE;- partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT}--instance Ord a => C.Coll (Set a) a where- {toSeq = toSeq; lookup = lookup; lookupM = lookupM;- lookupAll = lookupAll; lookupWithDefault = lookupWithDefault;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- filter = filter; partition = partition; strictWith = strictWith}--instance Ord a => C.OrdColl (Set a) a where- {minView = minView; minElem = minElem; maxView = maxView;- maxElem = maxElem; foldr = foldr; foldr' = foldr';- foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1';- foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq;- unsafeMapMonotonic = unsafeMapMonotonic}--instance Ord a => C.SetX (Set a) a where- {intersection = intersection; difference = difference;- symmetricDifference = symmetricDifference;- properSubset = properSubset; subset = subset}--instance Ord a => C.Set (Set a) a where- {fromSeqWith = fromSeqWith; insertWith = insertWith;- insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr;- unionWith = unionWith; unionSeqWith = unionSeqWith;- intersectionWith = intersectionWith}--instance Ord a => C.OrdSetX (Set a) a--instance Ord a => C.OrdSet (Set a) a---instance Ord a => Eq (Set a) where- xs == ys = C.toOrdList xs == C.toOrdList ys--instance (Ord a, Show a) => Show (Set a) where- showsPrec = showsPrecUsingToList--instance (Ord a, Read a) => Read (Set a) where- readsPrec = readsPrecUsingFromList---instance (Ord a, Arbitrary a) => Arbitrary (Set a) where- arbitrary = do xs <- arbitrary- return (Prelude.foldr insert empty xs)--instance (Ord a, CoArbitrary a) => CoArbitrary (Set a) where- coarbitrary E = variant 0- coarbitrary (T a x b) =- variant 1 . coarbitrary a . coarbitrary x . coarbitrary b--instance (Ord a) => Monoid (Set a) where- mempty = empty- mappend = union- mconcat = unionSeq--instance (Ord a) => Ord (Set a) where- compare = compareUsingToOrdList+-- | +-- Module : Data.Edison.Coll.UnbalancedSet +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Sets implemented as unbalanced binary search trees. + +module Data.Edison.Coll.UnbalancedSet ( + -- * Set type + Set, -- instance of Coll/CollX, OrdColl/OrdCollX, Set/SetX, OrdSet/OrdSetX + + -- * CollX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,strict,structuralInvariant, + + -- * Coll operations + toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold', + fold1,fold1',filter,partition,strictWith, + + -- * OrdCollX operations + deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, + unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, + partitionLE_GT,partitionLT_GT, + + -- * OrdColl operations + minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', + foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic, + + -- * SetX operations + intersection,difference,symmetricDifference,properSubset,subset, + + -- * Set operations + fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith, + unionSeqWith,intersectionWith, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,foldr,foldl,foldr1,foldl1,foldl',lookup,filter) +import qualified Prelude +import qualified Control.Monad.Fail as Fail +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Maybe (fromJust) +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Set a +singleton :: a -> Set a +fromSeq :: (Ord a,S.Sequence seq) => seq a -> Set a +insert :: Ord a => a -> Set a -> Set a +insertSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a +union :: Ord a => Set a -> Set a -> Set a +unionSeq :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a +delete :: Ord a => a -> Set a -> Set a +deleteAll :: Ord a => a -> Set a -> Set a +deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a +null :: Set a -> Bool +size :: Set a -> Int +member :: Ord a => a -> Set a -> Bool +count :: Ord a => a -> Set a -> Int +strict :: Set a -> Set a + +toSeq :: (Ord a,S.Sequence seq) => Set a -> seq a +lookup :: Ord a => a -> Set a -> a +lookupM :: (Ord a, Fail.MonadFail m) => a -> Set a -> m a +lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a +lookupWithDefault :: Ord a => a -> a -> Set a -> a +fold :: (a -> b -> b) -> b -> Set a -> b +fold1 :: (a -> a -> a) -> Set a -> a +fold' :: (a -> b -> b) -> b -> Set a -> b +fold1' :: (a -> a -> a) -> Set a -> a +filter :: Ord a => (a -> Bool) -> Set a -> Set a +partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a) +strictWith :: (a -> b) -> Set a -> Set a + +deleteMin :: Ord a => Set a -> Set a +deleteMax :: Ord a => Set a -> Set a +unsafeInsertMin :: Ord a => a -> Set a -> Set a +unsafeInsertMax :: Ord a => a -> Set a -> Set a +unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a +unsafeAppend :: Ord a => Set a -> Set a -> Set a +filterLT :: Ord a => a -> Set a -> Set a +filterLE :: Ord a => a -> Set a -> Set a +filterGT :: Ord a => a -> Set a -> Set a +filterGE :: Ord a => a -> Set a -> Set a +partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a) +partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a) +partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a) + +minView :: (Fail.MonadFail m) => Set a -> m (a, Set a) +minElem :: Set a -> a +maxView :: (Fail.MonadFail m) => Set a -> m (a, Set a) +maxElem :: Set a -> a +foldr :: (a -> b -> b) -> b -> Set a -> b +foldl :: (b -> a -> b) -> b -> Set a -> b +foldr1 :: (a -> a -> a) -> Set a -> a +foldl1 :: (a -> a -> a) -> Set a -> a +foldr' :: (a -> b -> b) -> b -> Set a -> b +foldl' :: (b -> a -> b) -> b -> Set a -> b +foldr1' :: (a -> a -> a) -> Set a -> a +foldl1' :: (a -> a -> a) -> Set a -> a +toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a + +intersection :: Ord a => Set a -> Set a -> Set a +difference :: Ord a => Set a -> Set a -> Set a +symmetricDifference :: Ord a => Set a -> Set a -> Set a +properSubset :: Ord a => Set a -> Set a -> Bool +subset :: Ord a => Set a -> Set a -> Bool + +fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a +insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a +insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a +unionl :: Ord a => Set a -> Set a -> Set a +unionr :: Ord a => Set a -> Set a -> Set a +unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a +unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a +intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a +unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a + +moduleName = "Data.Edison.Coll.UnbalancedSet" + +data Set a = E | T (Set a) a (Set a) + +-- invariants: +-- * Binary Search Tree order +structuralInvariant :: Ord a => Set a -> Bool +structuralInvariant t = bounded Nothing Nothing t + where bounded _ _ E = True + bounded lo hi (T l x r) = cmp_l lo x + && cmp_r x hi + && bounded lo (Just x) l + && bounded (Just x) hi r + + cmp_l Nothing _ = True + cmp_l (Just x) y = x < y + + cmp_r _ Nothing = True + cmp_r x (Just y) = x < y + + + +empty = E +singleton x = T E x E + +insertWith c x = ins + where ins E = T E x E + ins (T a y b) = + case compare x y of + LT -> T (ins a) y b + EQ -> T a (c x y) b + GT -> T a y (ins b) + +delete _ E = E +delete x (T a y b) = + case compare x y of + LT -> T (delete x a) y b + EQ -> unsafeAppend a b + GT -> T a y (delete x b) + +null E = True +null (T _ _ _) = False + +size t = sz t 0 + where sz E i = i + sz (T a _ b) i = sz a (sz b (i+1)) + +member _ E = False +member x (T a y b) = + case compare x y of + LT -> member x a + EQ -> True + GT -> member x b + +lookupM _ E = fail "UnbalancedSet.lookupM: XXX" +lookupM x (T a y b) = + case compare x y of + LT -> lookupM x a + EQ -> return y + GT -> lookupM x b + +fold _ e E = e +fold f e (T a x b) = f x (fold f (fold f e a) b) + +fold' _ e E = e +fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b) + +fold1 _ E = error "UnbalancedSet.fold1: empty collection" +fold1 f (T a x b) = fold f (fold f x a) b + +fold1' _ E = error "UnbalancedSet.fold1': empty collection" +fold1' f (T a x b) = fold' f (fold' f x a) b + +deleteMin E = E +deleteMin (T E _ b) = b +deleteMin (T a x b) = T (deleteMin a) x b + +deleteMax E = E +deleteMax (T a _ E) = a +deleteMax (T a x b) = T a x (deleteMax b) + +unsafeInsertMin x t = T E x t +unsafeInsertMax x t = T t x E + +unsafeFromOrdSeq xs = fst (ins xs (S.size xs)) + where ins ys 0 = (E,ys) + ins ys n = let m = n `div` 2 + (a,ys') = ins ys m + (y,ys'') = fromJust (S.lview ys') + (b,ys''') = ins ys'' (n - m - 1) + in (T a y b,ys''') + +unsafeAppend a b = case minView b of + Nothing -> a + Just (x,b') -> T a x b' + +filterLT _ E = E +filterLT y (T a x b) = + case compare x y of + LT -> T a x (filterLT y b) + EQ -> a + GT -> filterLT y a + +filterLE _ E = E +filterLE y (T a x b) = + case compare x y of + LT -> T a x (filterLE y b) + EQ -> T a x E + GT -> filterLE y a + +filterGT _ E = E +filterGT y (T a x b) = + case compare x y of + LT -> filterGT y b + EQ -> b + GT -> T (filterGT y a) x b + +filterGE _ E = E +filterGE y (T a x b) = + case compare x y of + LT -> filterGE y b + EQ -> T E x b + GT -> T (filterGE y a) x b + +partitionLT_GE _ E = (E,E) +partitionLT_GE y (T a x b) = + case compare x y of + LT -> (T a x b0,b1) + where (b0,b1) = partitionLT_GE y b + EQ -> (a,T E x b) + GT -> (a0,T a1 x b) + where (a0,a1) = partitionLT_GE y a + +partitionLE_GT _ E = (E,E) +partitionLE_GT y (T a x b) = + case compare x y of + LT -> (T a x b0,b1) + where (b0,b1) = partitionLE_GT y b + EQ -> (T a x E,b) + GT -> (a0,T a1 x b) + where (a0,a1) = partitionLE_GT y a + +partitionLT_GT _ E = (E,E) +partitionLT_GT y (T a x b) = + case compare x y of + LT -> (T a x b0,b1) + where (b0,b1) = partitionLT_GT y b + EQ -> (a,b) + GT -> (a0,T a1 x b) + where (a0,a1) = partitionLT_GT y a + +minView E = fail "UnbalancedSet.minView: empty collection" +minView (T E x b) = return (x, b) +minView (T a x b) = return (y, T a' x b) + where (y,a') = fromJust (minView a) + +minElem E = error "UnbalancedSet.minElem: empty collection" +minElem (T E x _) = x +minElem (T a _ _) = minElem a + +maxView E = fail "UnbalancedSet.maxView: empty collection" +maxView (T a x E) = return (x, a) +maxView (T a x b) = return (y, T a x b') + where (y, b') = fromJust (maxView b) + +maxElem E = error "UnbalancedSet.maxElem: empty collection" +maxElem (T _ x E) = x +maxElem (T _ _ b) = maxElem b + +foldr _ e E = e +foldr f e (T a x b) = foldr f (f x (foldr f e b)) a + +foldr' _ e E = e +foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a + +foldl _ e E = e +foldl f e (T a x b) = foldl f (f (foldl f e a) x) b + +foldl' _ e E = e +foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b + +foldr1 _ E = error "UnbalancedSet.foldr1: empty collection" +foldr1 f (T a x E) = foldr f x a +foldr1 f (T a x b) = foldr f (f x (foldr1 f b)) a + +foldr1' _ E = error "UnbalancedSet.foldr1': empty collection" +foldr1' f (T a x E) = foldr' f x a +foldr1' f (T a x b) = foldr' f (f x $! (foldr1' f b)) a + +foldl1 _ E = error "UnbalancedSet.foldl1: empty collection" +foldl1 f (T E x b) = foldl f x b +foldl1 f (T a x b) = foldl f (f (foldl1 f a) x) b + +foldl1' _ E = error "UnbalancedSet.foldl1': empty collection" +foldl1' f (T E x b) = foldl' f x b +foldl1' f (T a x b) = foldl' f ((f $! (foldl1' f a)) x) b + +unsafeMapMonotonic _ E = E +unsafeMapMonotonic f (T a x b) = + T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b) + +strict s@E = s +strict s@(T l _ r) = strict l `seq` strict r `seq` s + +strictWith _ s@E = s +strictWith f s@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s + +-- the remaining functions all use default definitions + +fromSeq = fromSeqUsingUnionSeq +insert = insertUsingInsertWith +insertSeq = insertSeqUsingUnion +union = unionUsingUnionWith +unionSeq = unionSeqUsingReduce +deleteAll = delete +deleteSeq = deleteSeqUsingDelete +count = countUsingMember + +toSeq = toSeqUsingFold +lookup = lookupUsingLookupM +lookupAll = lookupAllUsingLookupM +lookupWithDefault = lookupWithDefaultUsingLookupM +filter = filterUsingOrdLists +partition = partitionUsingOrdLists +toOrdSeq = toOrdSeqUsingFoldr + +intersection = intersectionUsingIntersectionWith +difference = differenceUsingOrdLists +symmetricDifference = symmetricDifferenceUsingDifference +properSubset = properSubsetUsingOrdLists +subset = subsetUsingOrdLists +fromSeqWith = fromSeqWithUsingInsertWith +insertSeqWith = insertSeqWithUsingInsertWith +unionl = unionlUsingUnionWith +unionr = unionrUsingUnionWith +unionWith = unionWithUsingOrdLists +unionSeqWith = unionSeqWithUsingReducer +intersectionWith = intersectionWithUsingOrdLists + +-- instance declarations + +instance Ord a => C.CollX (Set a) a where + {singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + strict = strict; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Ord a => C.OrdCollX (Set a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Set a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Set a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic} + +instance Ord a => C.SetX (Set a) a where + {intersection = intersection; difference = difference; + symmetricDifference = symmetricDifference; + properSubset = properSubset; subset = subset} + +instance Ord a => C.Set (Set a) a where + {fromSeqWith = fromSeqWith; insertWith = insertWith; + insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; + unionWith = unionWith; unionSeqWith = unionSeqWith; + intersectionWith = intersectionWith} + +instance Ord a => C.OrdSetX (Set a) a + +instance Ord a => C.OrdSet (Set a) a + + +instance Ord a => Eq (Set a) where + xs == ys = C.toOrdList xs == C.toOrdList ys + +instance (Ord a, Show a) => Show (Set a) where + showsPrec = showsPrecUsingToList + +instance (Ord a, Read a) => Read (Set a) where + readsPrec = readsPrecUsingFromList + + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = do (xs::[a]) <- arbitrary + return (Prelude.foldr insert empty xs) + +instance (Ord a, CoArbitrary a) => CoArbitrary (Set a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (T a x b) = + variant (1 :: Int) . coarbitrary a . coarbitrary x . coarbitrary b + +instance (Ord a) => Semigroup (Set a) where + (<>) = union + +instance (Ord a) => Monoid (Set a) where + mempty = empty + mappend = (SG.<>) + mconcat = unionSeq + +instance (Ord a) => Ord (Set a) where + compare = compareUsingToOrdList
src/Data/Edison/Concrete/FingerTree.hs view
@@ -1,787 +1,788 @@-{-# LANGUAGE UndecidableInstances #-}--------------------------------------------------------------------------------- |--- Module : Data.Edison.Concrete.FingerTree--- Copyright : (c) Ross Paterson, Ralf Hinze 2006--- License : BSD-style--- Maintainer : robdockins AT fastmail DOT fm--- Stability : internal (non-stable)--- Portability : non-portable (MPTCs and functional dependencies)------ A general sequence representation with arbitrary annotations, for--- use as a base for implementations of various collection types, as--- described in section 4 of------ * Ralf Hinze and Ross Paterson,--- \"Finger trees: a simple general-purpose data structure\",--- /Journal of Functional Programming/ 16:2 (2006) pp 197-217.--- <http://www.soi.city.ac.uk/~ross/papers/FingerTree.html>------ This data structure forms the basis of the "Data.Edison.Seq.FingerSeq"--- sequence data structure.------ An amortized running time is given for each operation, with /n/--- referring to the length of the sequence. These bounds hold even in--- a persistent (shared) setting.-----------------------------------------------------------------------------------{--------------------------------------------------------------------Copyright 2004, 2008, The University Court of the University of Glasgow.-All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--- Redistributions of source code must retain the above copyright notice,-this list of conditions and the following disclaimer.--- Redistributions in binary form must reproduce the above copyright notice,-this list of conditions and the following disclaimer in the documentation-and/or other materials provided with the distribution.--- Neither name of the University nor the names of its contributors may be-used to endorse or promote products derived from this software without-specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF-GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,-INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND-FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE-UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE-FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL-DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR-SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER-CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT-LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY-OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH-DAMAGE.-------------------------------------------------------------------------------}---module Data.Edison.Concrete.FingerTree (- FingerTree,- Split(..),-- empty, singleton, lcons, rcons, append,- fromList, toList, null, size, lview, rview,- split, takeUntil, dropUntil, splitTree,- reverse, mapTree, foldFT, reduce1, reduce1',- strict, strictWith, structuralInvariant-- -- traverse'- ) where--import Prelude hiding (null, reverse)-import Data.Monoid-import Test.QuickCheck--import Data.Edison.Prelude--import Control.Monad (liftM2, liftM3, liftM4)---infixr 5 `lcons`-infixl 5 `rcons0`--data Digit a- = One a- | Two a a- | Three a a a- | Four a a a a- deriving Show--foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b-foldDigit _ f (One a) = f a-foldDigit mapp f (Two a b) = f a `mapp` f b-foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c-foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d--reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b-reduceDigit _ f (One a) = f a-reduceDigit mapp f (Two a b) = f a `mapp` f b-reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c-reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d)--digitToList :: Digit a -> [a] -> [a]-digitToList (One a) xs = a : xs-digitToList (Two a b) xs = a : b : xs-digitToList (Three a b c) xs = a : b : c : xs-digitToList (Four a b c d) xs = a : b : c : d : xs--sizeDigit :: (a -> Int) -> Digit a -> Int-sizeDigit f (One x) = f x-sizeDigit f (Two x y) = f x + f y-sizeDigit f (Three x y z) = f x + f y + f z-sizeDigit f (Four x y z w) = f x + f y + f z + f w--instance (Measured v a) => Measured v (Digit a) where- measure = foldDigit mappend measure--data Node v a = Node2 !v a a | Node3 !v a a a- deriving Show--sizeNode :: (a -> Int) -> Node v a -> Int-sizeNode f (Node2 _ x y) = f x + f y-sizeNode f (Node3 _ x y z) = f x + f y + f z--foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b-foldNode mapp f (Node2 _ a b) = f a `mapp` f b-foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c--nodeToList :: Node v a -> [a] -> [a]-nodeToList (Node2 _ a b) xs = a : b : xs-nodeToList (Node3 _ a b c) xs = a : b : c : xs--node2 :: (Measured v a) => a -> a -> Node v a-node2 a b = Node2 (measure a `mappend` measure b) a b--node3 :: (Measured v a) => a -> a -> a -> Node v a-node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c--instance (Monoid v) => Measured v (Node v a) where- measure (Node2 v _ _) = v- measure (Node3 v _ _ _) = v--nodeToDigit :: Node v a -> Digit a-nodeToDigit (Node2 _ a b) = Two a b-nodeToDigit (Node3 _ a b c) = Three a b c----- | Finger trees with element type @a@, annotated with measures of type @v@.--- The operations enforce the constraint @'Measured' v a@.-data FingerTree v a- = Empty- | Single a- | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a)--deep :: (Measured v a) =>- Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a-deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf--structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool-structuralInvariant Empty = True-structuralInvariant (Single _) = True-structuralInvariant (Deep v pr m sf) =- v == foldDigit mappend measure pr `mappend`- foldFT mempty mappend (foldNode mappend measure) m `mappend`- foldDigit mappend measure sf--instance (Measured v a) => Measured v (FingerTree v a) where- measure Empty = mempty- measure (Single x) = measure x- measure (Deep v _ _ _) = v--sizeFT :: (a -> Int) -> FingerTree v a -> Int-sizeFT _ Empty = 0-sizeFT f (Single x) = f x-sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2--size :: FingerTree v a -> Int-size = sizeFT (const 1)--foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b-foldFT mz _ _ Empty = mz-foldFT _ _ f (Single x) = f x-foldFT mz mapp f (Deep _ pr m sf) =- foldDigit mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf--ftToList :: FingerTree v a -> [a] -> [a]-ftToList Empty xs = xs-ftToList (Single a) xs = a : xs-ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs)--toList :: FingerTree v a -> [a]-toList ft = ftToList ft []--reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b-reduce1_aux mapp f pr Empty sf =- (reduceDigit mapp f pr) `mapp`- (reduceDigit mapp f sf)--reduce1_aux mapp f pr (Single x) sf =- (reduceDigit mapp f pr) `mapp`- (foldNode mapp f x) `mapp`- (reduceDigit mapp f sf)--reduce1_aux mapp f pr (Deep _ pr' m sf') sf =- (reduceDigit mapp f pr) `mapp`- (reduce1_aux mapp- (foldNode mapp f)- pr' m sf') `mapp`- (reduceDigit mapp f sf)--reduce1 :: (a -> a -> a) -> FingerTree v a -> a-reduce1 _ Empty = error "FingerTree.reduce1: empty tree"-reduce1 _ (Single x) = x-reduce1 mapp (Deep _ pr m sf) = reduce1_aux mapp id pr m sf--reduce1' :: (a -> a -> a) -> FingerTree v a -> a-reduce1' _ Empty = error "FingerTree.reduce1': empty tree"-reduce1' _ (Single x) = x-reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf- where mapp' x y = x `seq` y `seq` mapp x y---strict :: FingerTree v a -> FingerTree v a-strict xs = foldFT () seq (const ()) xs `seq` xs--strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a-strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs--instance (Measured v a, Eq a) => Eq (FingerTree v a) where- xs == ys = toList xs == toList ys--instance (Measured v a, Ord a) => Ord (FingerTree v a) where- compare xs ys = compare (toList xs) (toList ys)--instance (Measured v a, Show a) => Show (FingerTree v a) where- showsPrec p xs = showParen (p > 10) $- showString "fromList " . shows (toList xs)--mapTree :: (Measured v2 a2) =>- (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2-mapTree _ Empty = Empty-mapTree f (Single x) = Single (f x)-mapTree f (Deep _ pr m sf) =- deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf)--mapNode :: (Measured v2 a2) =>- (a1 -> a2) -> Node v1 a1 -> Node v2 a2-mapNode f (Node2 _ a b) = node2 (f a) (f b)-mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c)--mapDigit :: (a -> b) -> Digit a -> Digit b-mapDigit f (One a) = One (f a)-mapDigit f (Two a b) = Two (f a) (f b)-mapDigit f (Three a b c) = Three (f a) (f b) (f c)-mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d)---{---- | Like 'traverse', but with a more constrained type.-traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) =>- (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)-traverse' = traverseTree--traverseTree :: (Measured v2 a2, Applicative f) =>- (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2)-traverseTree _ Empty = pure Empty-traverseTree f (Single x) = Single <$> f x-traverseTree f (Deep _ pr m sf) =- deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf--traverseNode :: (Measured v2 a2, Applicative f) =>- (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2)-traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b-traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c--traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b)-traverseDigit f (One a) = One <$> f a-traverseDigit f (Two a b) = Two <$> f a <*> f b-traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c-traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d--}---- | /O(1)/. The empty sequence.-empty :: Measured v a => FingerTree v a-empty = Empty---- | /O(1)/. A singleton sequence.-singleton :: Measured v a => a -> FingerTree v a-singleton = Single---- | /O(n)/. Create a sequence from a finite list of elements.-fromList :: (Measured v a) => [a] -> FingerTree v a-fromList = foldr lcons Empty---- | /O(1)/. Add an element to the left end of a sequence.-lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a-a `lcons` Empty = Single a-a `lcons` Single b = deep (One a) Empty (One b)-a `lcons` Deep _ (Four b c d e) m sf = m `seq`- deep (Two a b) (node3 c d e `lcons` m) sf-a `lcons` Deep _ pr m sf = deep (consDigit a pr) m sf--consDigit :: a -> Digit a -> Digit a-consDigit a (One b) = Two a b-consDigit a (Two b c) = Three a b c-consDigit a (Three b c d) = Four a b c d-consDigit _ _ = error "FingerTree.consDigit: bug!"---- | /O(1)/. Add an element to the right end of a sequence.-rcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a-rcons = flip rcons0--rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a-Empty `rcons0` a = Single a-Single a `rcons0` b = deep (One a) Empty (One b)-Deep _ pr m (Four a b c d) `rcons0` e = m `seq`- deep pr (m `rcons0` node3 a b c) (Two d e)-Deep _ pr m sf `rcons0` x = deep pr m (snocDigit sf x)--snocDigit :: Digit a -> a -> Digit a-snocDigit (One a) b = Two a b-snocDigit (Two a b) c = Three a b c-snocDigit (Three a b c) d = Four a b c d-snocDigit _ _ = error "FingerTree.snocDigit: bug!"---- | /O(1)/. Is this the empty sequence?-null :: (Measured v a) => FingerTree v a -> Bool-null Empty = True-null _ = False---- | /O(1)/. Analyse the left end of a sequence.-lview :: (Measured v a, Monad m) => FingerTree v a -> m (a,FingerTree v a)-lview Empty = fail "FingerTree.lview: empty tree"-lview (Single x) = return (x, Empty)-lview (Deep _ (One x) m sf) = return . (,) x $- case lview m of- Nothing -> digitToTree sf- Just (a,m') -> deep (nodeToDigit a) m' sf--lview (Deep _ pr m sf) = return (lheadDigit pr, deep (ltailDigit pr) m sf)--lheadDigit :: Digit a -> a-lheadDigit (One a) = a-lheadDigit (Two a _) = a-lheadDigit (Three a _ _) = a-lheadDigit (Four a _ _ _) = a--ltailDigit :: Digit a -> Digit a-ltailDigit (Two _ b) = One b-ltailDigit (Three _ b c) = Two b c-ltailDigit (Four _ b c d) = Three b c d-ltailDigit _ = error "FingerTree.ltailDigit: bug!"---- | /O(1)/. Analyse the right end of a sequence.-rview :: (Measured v a, Monad m) => FingerTree v a -> m (a, FingerTree v a)-rview Empty = fail "FingerTree.rview: empty tree"-rview (Single x) = return (x, Empty)-rview (Deep _ pr m (One x)) = return . (,) x $- case rview m of- Nothing -> digitToTree pr- Just (a,m') -> deep pr m' (nodeToDigit a)--rview (Deep _ pr m sf) = return (rheadDigit sf, deep pr m (rtailDigit sf))---rheadDigit :: Digit a -> a-rheadDigit (One a) = a-rheadDigit (Two _ b) = b-rheadDigit (Three _ _ c) = c-rheadDigit (Four _ _ _ d) = d--rtailDigit :: Digit a -> Digit a-rtailDigit (Two a _) = One a-rtailDigit (Three a b _) = Two a b-rtailDigit (Four a b c _) = Three a b c-rtailDigit _ = error "FingerTree.rtailDigit: bug!"--digitToTree :: (Measured v a) => Digit a -> FingerTree v a-digitToTree (One a) = Single a-digitToTree (Two a b) = deep (One a) Empty (One b)-digitToTree (Three a b c) = deep (Two a b) Empty (One c)-digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d)----- | /O(log(min(n1,n2)))/. Concatenate two sequences.-append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a-append = appendTree0--appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a-appendTree0 Empty xs =- xs-appendTree0 xs Empty =- xs-appendTree0 (Single x) xs =- x `lcons` xs-appendTree0 xs (Single x) =- xs `rcons0` x-appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) =- deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2--addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits0 m1 (One a) (One b) m2 =- appendTree1 m1 (node2 a b) m2-addDigits0 m1 (One a) (Two b c) m2 =- appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (One a) (Three b c d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (One a) (Four b c d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (One c) m2 =- appendTree1 m1 (node3 a b c) m2-addDigits0 m1 (Two a b) (Two c d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Two a b) (Three c d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Two a b) (Four c d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (One d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits0 m1 (Three a b c) (Two d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Three a b c) (Three d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Three a b c) (Four d e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits0 m1 (Four a b c d) (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits0 m1 (Four a b c d) (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits0 m1 (Four a b c d) (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2--appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a-appendTree1 Empty a xs =- a `lcons` xs-appendTree1 xs a Empty =- xs `rcons0` a-appendTree1 (Single x) a xs =- x `lcons` (a `lcons` xs)-appendTree1 xs a (Single x) =- xs `rcons0` a `rcons0` x-appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) =- deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2--addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits1 m1 (One a) b (One c) m2 =- appendTree1 m1 (node3 a b c) m2-addDigits1 m1 (One a) b (Two c d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (One a) b (Three c d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (One a) b (Four c d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (One d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits1 m1 (Two a b) c (Two d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Two a b) c (Three d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Two a b) c (Four d e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits1 m1 (Three a b c) d (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Three a b c) d (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Three a b c) d (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits1 m1 (Four a b c d) e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits1 m1 (Four a b c d) e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits1 m1 (Four a b c d) e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2--appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a-appendTree2 Empty a b xs =- a `lcons` (b `lcons` xs)-appendTree2 xs a b Empty =- xs `rcons0` a `rcons0` b-appendTree2 (Single x) a b xs =- x `lcons` (a `lcons` (b `lcons` xs))-appendTree2 xs a b (Single x) =- xs `rcons0` a `rcons0` b `rcons0` x-appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) =- deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2--addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits2 m1 (One a) b c (One d) m2 =- appendTree2 m1 (node2 a b) (node2 c d) m2-addDigits2 m1 (One a) b c (Two d e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (One a) b c (Three d e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (One a) b c (Four d e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits2 m1 (Two a b) c d (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Two a b) c d (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Two a b) c d (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits2 m1 (Three a b c) d e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Three a b c) d e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Three a b c) d e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (One g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits2 m1 (Four a b c d) e f (Two g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits2 m1 (Four a b c d) e f (Three g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2--appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a-appendTree3 Empty a b c xs =- a `lcons` (b `lcons` (c `lcons` xs))-appendTree3 xs a b c Empty =- xs `rcons0` a `rcons0` b `rcons0` c-appendTree3 (Single x) a b c xs =- x `lcons` (a `lcons` (b `lcons` (c `lcons` xs)))-appendTree3 xs a b c (Single x) =- xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x-appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) =- deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2--addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits3 m1 (One a) b c d (One e) m2 =- appendTree2 m1 (node3 a b c) (node2 d e) m2-addDigits3 m1 (One a) b c d (Two e f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (One a) b c d (Three e f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (One a) b c d (Four e f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits3 m1 (Two a b) c d e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Two a b) c d e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Two a b) c d e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (One g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits3 m1 (Three a b c) d e f (Two g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Three a b c) d e f (Three g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (One h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits3 m1 (Four a b c d) e f g (Two h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2--appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a-appendTree4 Empty a b c d xs =- a `lcons` b `lcons` c `lcons` d `lcons` xs-appendTree4 xs a b c d Empty =- xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d-appendTree4 (Single x) a b c d xs =- x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs-appendTree4 xs a b c d (Single x) =- xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x-appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) =- deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2--addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a)-addDigits4 m1 (One a) b c d e (One f) m2 =- appendTree2 m1 (node3 a b c) (node3 d e f) m2-addDigits4 m1 (One a) b c d e (Two f g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (One a) b c d e (Three f g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (One a) b c d e (Four f g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (One g) m2 =- appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2-addDigits4 m1 (Two a b) c d e f (Two g h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Two a b) c d e f (Three g h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (One h) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2-addDigits4 m1 (Three a b c) d e f g (Two h i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) e f g h (One i) m2 =- appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2-addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2-addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2-addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 =- appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2----- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate--- on the accumulated measure changes from 'False' to 'True'.-split :: (Measured v a) =>- (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a)-split _p Empty = (Empty, Empty)-split p xs- | p (measure xs) = (l, x `lcons` r)- | otherwise = (xs, Empty)- where Split l x r = splitTree p mempty xs--takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a-takeUntil p = fst . split p--dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a-dropUntil p = snd . split p--data Split t a = Split t a t--splitTree :: (Measured v a) =>- (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a-splitTree _ _ Empty = error "FingerTree.splitTree: bug!"-splitTree _p _i (Single x) = Split Empty x Empty-splitTree p i (Deep _ pr m sf)- | p vpr = let Split l x r = splitDigit p i pr- in Split (maybe Empty digitToTree l) x (deepL r m sf)- | p vm = let Split ml xs mr = splitTree p vpr m- Split l x r = splitNode p (vpr `mappendVal` ml) xs- in Split (deepR pr ml l) x (deepL r mr sf)- | otherwise = let Split l x r = splitDigit p vm sf- in Split (deepR pr m l) x (maybe Empty digitToTree r)- where vpr = i `mappend` measure pr- vm = vpr `mappendVal` m--mappendVal :: (Measured v a) => v -> FingerTree v a -> v-mappendVal v Empty = v-mappendVal v t = v `mappend` measure t--deepL :: (Measured v a) =>- Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a-deepL Nothing m sf = case lview m of- Nothing -> digitToTree sf- Just (a,m') -> deep (nodeToDigit a) m' sf-deepL (Just pr) m sf = deep pr m sf--deepR :: (Measured v a) =>- Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a-deepR pr m Nothing = case rview m of- Nothing -> digitToTree pr- Just (a,m') -> deep pr m' (nodeToDigit a)-deepR pr m (Just sf) = deep pr m sf--splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a ->- Split (Maybe (Digit a)) a-splitNode p i (Node2 _ a b)- | p va = Split Nothing a (Just (One b))- | otherwise = Split (Just (One a)) b Nothing- where va = i `mappend` measure a-splitNode p i (Node3 _ a b c)- | p va = Split Nothing a (Just (Two b c))- | p vab = Split (Just (One a)) b (Just (One c))- | otherwise = Split (Just (Two a b)) c Nothing- where va = i `mappend` measure a- vab = va `mappend` measure b--splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a ->- Split (Maybe (Digit a)) a-splitDigit _ i (One a) = i `seq` Split Nothing a Nothing-splitDigit p i (Two a b)- | p va = Split Nothing a (Just (One b))- | otherwise = Split (Just (One a)) b Nothing- where va = i `mappend` measure a-splitDigit p i (Three a b c)- | p va = Split Nothing a (Just (Two b c))- | p vab = Split (Just (One a)) b (Just (One c))- | otherwise = Split (Just (Two a b)) c Nothing- where va = i `mappend` measure a- vab = va `mappend` measure b-splitDigit p i (Four a b c d)- | p va = Split Nothing a (Just (Three b c d))- | p vab = Split (Just (One a)) b (Just (Two c d))- | p vabc = Split (Just (Two a b)) c (Just (One d))- | otherwise = Split (Just (Three a b c)) d Nothing- where va = i `mappend` measure a- vab = va `mappend` measure b- vabc = vab `mappend` measure c----- | /O(n)/. The reverse of a sequence.-reverse :: (Measured v a) => FingerTree v a -> FingerTree v a-reverse = reverseTree id--reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2-reverseTree _ Empty = Empty-reverseTree f (Single x) = Single (f x)-reverseTree f (Deep _ pr m sf) =- deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr)--reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2-reverseNode f (Node2 _ a b) = node2 (f b) (f a)-reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a)--reverseDigit :: (a -> b) -> Digit a -> Digit b-reverseDigit f (One a) = One (f a)-reverseDigit f (Two a b) = Two (f b) (f a)-reverseDigit f (Three a b c) = Three (f c) (f b) (f a)-reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a)--two :: Monad m => m a -> m (a, a)-two m = liftM2 (,) m m--three :: Monad m => m a -> m (a, a, a)-three m = liftM3 (,,) m m m--four :: Monad m => m a -> m (a, a, a, a)-four m = liftM4 (,,,) m m m m--instance (Arbitrary a) => Arbitrary (Digit a) where- arbitrary = oneof- [ arbitrary >>= \x -> return (One x)- , two arbitrary >>= \(x,y) -> return (Two x y)- , three arbitrary >>= \(x,y,z) -> return (Three x y z)- , four arbitrary >>= \(x,y,z,w) -> return (Four x y z w)- ]---instance (CoArbitrary a) => CoArbitrary (Digit a) where- coarbitrary p = case p of- One x -> variant 0 . coarbitrary x- Two x y -> variant 1 . coarbitrary x . coarbitrary y- Three x y z -> variant 2 . coarbitrary x . coarbitrary y- . coarbitrary z- Four x y z w -> variant 3 . coarbitrary x . coarbitrary y- . coarbitrary z . coarbitrary w---instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where- arbitrary = oneof- [ two arbitrary >>= \(x,y) -> return (node2 x y)- , three arbitrary >>= \(x,y,z) -> return (node3 x y z)- ]--instance (Measured v a, CoArbitrary a) => CoArbitrary (Node v a) where- coarbitrary p = case p of- Node2 _ x y -> variant 0 . coarbitrary x . coarbitrary y- Node3 _ x y z -> variant 1 . coarbitrary x . coarbitrary y . coarbitrary z---instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where- arbitrary = oneof- [ return Empty- , arbitrary >>= return . Single- , do- pf <- arbitrary- m <- arbitrary- sf <- arbitrary- return (deep pf m sf)- ]--instance (Measured v a, CoArbitrary a) => CoArbitrary (FingerTree v a) where- coarbitrary p = case p of- Empty -> variant 0- Single x -> variant 1 . coarbitrary x- Deep _ sf m pf -> variant 2 . coarbitrary sf . coarbitrary m . coarbitrary pf+{-# LANGUAGE UndecidableInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Edison.Concrete.FingerTree +-- Copyright : (c) Ross Paterson, Ralf Hinze 2006 +-- License : BSD-style +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : internal (non-stable) +-- Portability : non-portable (MPTCs and functional dependencies) +-- +-- A general sequence representation with arbitrary annotations, for +-- use as a base for implementations of various collection types, as +-- described in section 4 of +-- +-- * Ralf Hinze and Ross Paterson, +-- \"Finger trees: a simple general-purpose data structure\", +-- /Journal of Functional Programming/ 16:2 (2006) pp 197-217. +-- <https://www.cs.tufts.edu/~nr/cs257/archive/ralf-hinze/finger-trees.pdf> +-- +-- This data structure forms the basis of the "Data.Edison.Seq.FingerSeq" +-- sequence data structure. +-- +-- An amortized running time is given for each operation, with /n/ +-- referring to the length of the sequence. These bounds hold even in +-- a persistent (shared) setting. +-- +----------------------------------------------------------------------------- + +{------------------------------------------------------------------ + +Copyright 2004, 2008, The University Court of the University of Glasgow. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +- Neither name of the University nor the names of its contributors may be +used to endorse or promote products derived from this software without +specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF +GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH +DAMAGE. + +-----------------------------------------------------------------------------} + + +module Data.Edison.Concrete.FingerTree ( + FingerTree, + Split(..), + + empty, singleton, lcons, rcons, append, + fromList, toList, null, size, lview, rview, + split, takeUntil, dropUntil, splitTree, + reverse, mapTree, foldFT, reduce1, reduce1', + strict, strictWith, structuralInvariant + + -- traverse' + ) where + +import Prelude hiding (null, reverse) +import Data.Monoid +import Test.QuickCheck + +import Data.Edison.Prelude + +import Control.Monad (liftM2, liftM3, liftM4) +import qualified Control.Monad.Fail as Fail + + +infixr 5 `lcons` +infixl 5 `rcons0` + +data Digit a + = One a + | Two a a + | Three a a a + | Four a a a a + deriving Show + +foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b +foldDigit _ f (One a) = f a +foldDigit mapp f (Two a b) = f a `mapp` f b +foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c +foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d + +reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b +reduceDigit _ f (One a) = f a +reduceDigit mapp f (Two a b) = f a `mapp` f b +reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c +reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d) + +digitToList :: Digit a -> [a] -> [a] +digitToList (One a) xs = a : xs +digitToList (Two a b) xs = a : b : xs +digitToList (Three a b c) xs = a : b : c : xs +digitToList (Four a b c d) xs = a : b : c : d : xs + +sizeDigit :: (a -> Int) -> Digit a -> Int +sizeDigit f (One x) = f x +sizeDigit f (Two x y) = f x + f y +sizeDigit f (Three x y z) = f x + f y + f z +sizeDigit f (Four x y z w) = f x + f y + f z + f w + +instance (Measured v a) => Measured v (Digit a) where + measure = foldDigit mappend measure + +data Node v a = Node2 !v a a | Node3 !v a a a + deriving Show + +sizeNode :: (a -> Int) -> Node v a -> Int +sizeNode f (Node2 _ x y) = f x + f y +sizeNode f (Node3 _ x y z) = f x + f y + f z + +foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b +foldNode mapp f (Node2 _ a b) = f a `mapp` f b +foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c + +nodeToList :: Node v a -> [a] -> [a] +nodeToList (Node2 _ a b) xs = a : b : xs +nodeToList (Node3 _ a b c) xs = a : b : c : xs + +node2 :: (Measured v a) => a -> a -> Node v a +node2 a b = Node2 (measure a `mappend` measure b) a b + +node3 :: (Measured v a) => a -> a -> a -> Node v a +node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c + +instance (Monoid v) => Measured v (Node v a) where + measure (Node2 v _ _) = v + measure (Node3 v _ _ _) = v + +nodeToDigit :: Node v a -> Digit a +nodeToDigit (Node2 _ a b) = Two a b +nodeToDigit (Node3 _ a b c) = Three a b c + + +-- | Finger trees with element type @a@, annotated with measures of type @v@. +-- The operations enforce the constraint @'Measured' v a@. +data FingerTree v a + = Empty + | Single a + | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a) + +deep :: (Measured v a) => + Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a +deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf + +structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool +structuralInvariant Empty = True +structuralInvariant (Single _) = True +structuralInvariant (Deep v pr m sf) = + v == foldDigit mappend measure pr `mappend` + foldFT mempty mappend (foldNode mappend measure) m `mappend` + foldDigit mappend measure sf + +instance (Measured v a) => Measured v (FingerTree v a) where + measure Empty = mempty + measure (Single x) = measure x + measure (Deep v _ _ _) = v + +sizeFT :: (a -> Int) -> FingerTree v a -> Int +sizeFT _ Empty = 0 +sizeFT f (Single x) = f x +sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2 + +size :: FingerTree v a -> Int +size = sizeFT (const 1) + +foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b +foldFT mz _ _ Empty = mz +foldFT _ _ f (Single x) = f x +foldFT mz mapp f (Deep _ pr m sf) = + foldDigit mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf + +ftToList :: FingerTree v a -> [a] -> [a] +ftToList Empty xs = xs +ftToList (Single a) xs = a : xs +ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs) + +toList :: FingerTree v a -> [a] +toList ft = ftToList ft [] + +reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b +reduce1_aux mapp f pr Empty sf = + (reduceDigit mapp f pr) `mapp` + (reduceDigit mapp f sf) + +reduce1_aux mapp f pr (Single x) sf = + (reduceDigit mapp f pr) `mapp` + (foldNode mapp f x) `mapp` + (reduceDigit mapp f sf) + +reduce1_aux mapp f pr (Deep _ pr' m sf') sf = + (reduceDigit mapp f pr) `mapp` + (reduce1_aux mapp + (foldNode mapp f) + pr' m sf') `mapp` + (reduceDigit mapp f sf) + +reduce1 :: (a -> a -> a) -> FingerTree v a -> a +reduce1 _ Empty = error "FingerTree.reduce1: empty tree" +reduce1 _ (Single x) = x +reduce1 mapp (Deep _ pr m sf) = reduce1_aux mapp id pr m sf + +reduce1' :: (a -> a -> a) -> FingerTree v a -> a +reduce1' _ Empty = error "FingerTree.reduce1': empty tree" +reduce1' _ (Single x) = x +reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf + where mapp' x y = x `seq` y `seq` mapp x y + + +strict :: FingerTree v a -> FingerTree v a +strict xs = foldFT () seq (const ()) xs `seq` xs + +strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a +strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs + +instance (Measured v a, Eq a) => Eq (FingerTree v a) where + xs == ys = toList xs == toList ys + +instance (Measured v a, Ord a) => Ord (FingerTree v a) where + compare xs ys = compare (toList xs) (toList ys) + +instance (Measured v a, Show a) => Show (FingerTree v a) where + showsPrec p xs = showParen (p > 10) $ + showString "fromList " . shows (toList xs) + +mapTree :: (Measured v2 a2) => + (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 +mapTree _ Empty = Empty +mapTree f (Single x) = Single (f x) +mapTree f (Deep _ pr m sf) = + deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf) + +mapNode :: (Measured v2 a2) => + (a1 -> a2) -> Node v1 a1 -> Node v2 a2 +mapNode f (Node2 _ a b) = node2 (f a) (f b) +mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c) + +mapDigit :: (a -> b) -> Digit a -> Digit b +mapDigit f (One a) = One (f a) +mapDigit f (Two a b) = Two (f a) (f b) +mapDigit f (Three a b c) = Three (f a) (f b) (f c) +mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d) + + +{- +-- | Like 'traverse', but with a more constrained type. +traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) => + (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) +traverse' = traverseTree + +traverseTree :: (Measured v2 a2, Applicative f) => + (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) +traverseTree _ Empty = pure Empty +traverseTree f (Single x) = Single <$> f x +traverseTree f (Deep _ pr m sf) = + deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf + +traverseNode :: (Measured v2 a2, Applicative f) => + (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2) +traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b +traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c + +traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b) +traverseDigit f (One a) = One <$> f a +traverseDigit f (Two a b) = Two <$> f a <*> f b +traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c +traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d +-} + +-- | /O(1)/. The empty sequence. +empty :: Measured v a => FingerTree v a +empty = Empty + +-- | /O(1)/. A singleton sequence. +singleton :: Measured v a => a -> FingerTree v a +singleton = Single + +-- | /O(n)/. Create a sequence from a finite list of elements. +fromList :: (Measured v a) => [a] -> FingerTree v a +fromList = foldr lcons Empty + +-- | /O(1)/. Add an element to the left end of a sequence. +lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a +a `lcons` Empty = Single a +a `lcons` Single b = deep (One a) Empty (One b) +a `lcons` Deep _ (Four b c d e) m sf = m `seq` + deep (Two a b) (node3 c d e `lcons` m) sf +a `lcons` Deep _ pr m sf = deep (consDigit a pr) m sf + +consDigit :: a -> Digit a -> Digit a +consDigit a (One b) = Two a b +consDigit a (Two b c) = Three a b c +consDigit a (Three b c d) = Four a b c d +consDigit _ _ = error "FingerTree.consDigit: bug!" + +-- | /O(1)/. Add an element to the right end of a sequence. +rcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a +rcons = flip rcons0 + +rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a +Empty `rcons0` a = Single a +Single a `rcons0` b = deep (One a) Empty (One b) +Deep _ pr m (Four a b c d) `rcons0` e = m `seq` + deep pr (m `rcons0` node3 a b c) (Two d e) +Deep _ pr m sf `rcons0` x = deep pr m (snocDigit sf x) + +snocDigit :: Digit a -> a -> Digit a +snocDigit (One a) b = Two a b +snocDigit (Two a b) c = Three a b c +snocDigit (Three a b c) d = Four a b c d +snocDigit _ _ = error "FingerTree.snocDigit: bug!" + +-- | /O(1)/. Is this the empty sequence? +null :: (Measured v a) => FingerTree v a -> Bool +null Empty = True +null _ = False + +-- | /O(1)/. Analyse the left end of a sequence. +lview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a,FingerTree v a) +lview Empty = fail "FingerTree.lview: empty tree" +lview (Single x) = return (x, Empty) +lview (Deep _ (One x) m sf) = return . (,) x $ + case lview m of + Nothing -> digitToTree sf + Just (a,m') -> deep (nodeToDigit a) m' sf + +lview (Deep _ pr m sf) = return (lheadDigit pr, deep (ltailDigit pr) m sf) + +lheadDigit :: Digit a -> a +lheadDigit (One a) = a +lheadDigit (Two a _) = a +lheadDigit (Three a _ _) = a +lheadDigit (Four a _ _ _) = a + +ltailDigit :: Digit a -> Digit a +ltailDigit (Two _ b) = One b +ltailDigit (Three _ b c) = Two b c +ltailDigit (Four _ b c d) = Three b c d +ltailDigit _ = error "FingerTree.ltailDigit: bug!" + +-- | /O(1)/. Analyse the right end of a sequence. +rview :: (Measured v a, Fail.MonadFail m) => FingerTree v a -> m (a, FingerTree v a) +rview Empty = fail "FingerTree.rview: empty tree" +rview (Single x) = return (x, Empty) +rview (Deep _ pr m (One x)) = return . (,) x $ + case rview m of + Nothing -> digitToTree pr + Just (a,m') -> deep pr m' (nodeToDigit a) + +rview (Deep _ pr m sf) = return (rheadDigit sf, deep pr m (rtailDigit sf)) + + +rheadDigit :: Digit a -> a +rheadDigit (One a) = a +rheadDigit (Two _ b) = b +rheadDigit (Three _ _ c) = c +rheadDigit (Four _ _ _ d) = d + +rtailDigit :: Digit a -> Digit a +rtailDigit (Two a _) = One a +rtailDigit (Three a b _) = Two a b +rtailDigit (Four a b c _) = Three a b c +rtailDigit _ = error "FingerTree.rtailDigit: bug!" + +digitToTree :: (Measured v a) => Digit a -> FingerTree v a +digitToTree (One a) = Single a +digitToTree (Two a b) = deep (One a) Empty (One b) +digitToTree (Three a b c) = deep (Two a b) Empty (One c) +digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d) + + +-- | /O(log(min(n1,n2)))/. Concatenate two sequences. +append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a +append = appendTree0 + +appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a +appendTree0 Empty xs = + xs +appendTree0 xs Empty = + xs +appendTree0 (Single x) xs = + x `lcons` xs +appendTree0 xs (Single x) = + xs `rcons0` x +appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2 + +addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits0 m1 (One a) (One b) m2 = + appendTree1 m1 (node2 a b) m2 +addDigits0 m1 (One a) (Two b c) m2 = + appendTree1 m1 (node3 a b c) m2 +addDigits0 m1 (One a) (Three b c d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits0 m1 (One a) (Four b c d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Two a b) (One c) m2 = + appendTree1 m1 (node3 a b c) m2 +addDigits0 m1 (Two a b) (Two c d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits0 m1 (Two a b) (Three c d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Two a b) (Four c d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits0 m1 (Three a b c) (One d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits0 m1 (Three a b c) (Two d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Three a b c) (Three d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits0 m1 (Three a b c) (Four d e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits0 m1 (Four a b c d) (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits0 m1 (Four a b c d) (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits0 m1 (Four a b c d) (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits0 m1 (Four a b c d) (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 + +appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a +appendTree1 Empty a xs = + a `lcons` xs +appendTree1 xs a Empty = + xs `rcons0` a +appendTree1 (Single x) a xs = + x `lcons` (a `lcons` xs) +appendTree1 xs a (Single x) = + xs `rcons0` a `rcons0` x +appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 + +addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits1 m1 (One a) b (One c) m2 = + appendTree1 m1 (node3 a b c) m2 +addDigits1 m1 (One a) b (Two c d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits1 m1 (One a) b (Three c d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits1 m1 (One a) b (Four c d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Two a b) c (One d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits1 m1 (Two a b) c (Two d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits1 m1 (Two a b) c (Three d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Two a b) c (Four d e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits1 m1 (Three a b c) d (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits1 m1 (Three a b c) d (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Three a b c) d (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits1 m1 (Three a b c) d (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits1 m1 (Four a b c d) e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits1 m1 (Four a b c d) e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits1 m1 (Four a b c d) e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits1 m1 (Four a b c d) e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 + +appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree2 Empty a b xs = + a `lcons` (b `lcons` xs) +appendTree2 xs a b Empty = + xs `rcons0` a `rcons0` b +appendTree2 (Single x) a b xs = + x `lcons` (a `lcons` (b `lcons` xs)) +appendTree2 xs a b (Single x) = + xs `rcons0` a `rcons0` b `rcons0` x +appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 + +addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits2 m1 (One a) b c (One d) m2 = + appendTree2 m1 (node2 a b) (node2 c d) m2 +addDigits2 m1 (One a) b c (Two d e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits2 m1 (One a) b c (Three d e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits2 m1 (One a) b c (Four d e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Two a b) c d (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits2 m1 (Two a b) c d (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits2 m1 (Two a b) c d (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Two a b) c d (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits2 m1 (Three a b c) d e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits2 m1 (Three a b c) d e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Three a b c) d e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits2 m1 (Three a b c) d e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits2 m1 (Four a b c d) e f (One g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits2 m1 (Four a b c d) e f (Two g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits2 m1 (Four a b c d) e f (Three g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 + +appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree3 Empty a b c xs = + a `lcons` (b `lcons` (c `lcons` xs)) +appendTree3 xs a b c Empty = + xs `rcons0` a `rcons0` b `rcons0` c +appendTree3 (Single x) a b c xs = + x `lcons` (a `lcons` (b `lcons` (c `lcons` xs))) +appendTree3 xs a b c (Single x) = + xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x +appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 + +addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits3 m1 (One a) b c d (One e) m2 = + appendTree2 m1 (node3 a b c) (node2 d e) m2 +addDigits3 m1 (One a) b c d (Two e f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits3 m1 (One a) b c d (Three e f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits3 m1 (One a) b c d (Four e f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Two a b) c d e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits3 m1 (Two a b) c d e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits3 m1 (Two a b) c d e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Two a b) c d e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits3 m1 (Three a b c) d e f (One g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits3 m1 (Three a b c) d e f (Two g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Three a b c) d e f (Three g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits3 m1 (Four a b c d) e f g (One h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits3 m1 (Four a b c d) e f g (Two h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 + +appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a +appendTree4 Empty a b c d xs = + a `lcons` b `lcons` c `lcons` d `lcons` xs +appendTree4 xs a b c d Empty = + xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d +appendTree4 (Single x) a b c d xs = + x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs +appendTree4 xs a b c d (Single x) = + xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x +appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) = + deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 + +addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) +addDigits4 m1 (One a) b c d e (One f) m2 = + appendTree2 m1 (node3 a b c) (node3 d e f) m2 +addDigits4 m1 (One a) b c d e (Two f g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits4 m1 (One a) b c d e (Three f g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits4 m1 (One a) b c d e (Four f g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Two a b) c d e f (One g) m2 = + appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 +addDigits4 m1 (Two a b) c d e f (Two g h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits4 m1 (Two a b) c d e f (Three g h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits4 m1 (Three a b c) d e f g (One h) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 +addDigits4 m1 (Three a b c) d e f g (Two h i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 +addDigits4 m1 (Four a b c d) e f g h (One i) m2 = + appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 +addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 +addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 +addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = + appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 + + +-- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate +-- on the accumulated measure changes from 'False' to 'True'. +split :: (Measured v a) => + (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a) +split _p Empty = (Empty, Empty) +split p xs + | p (measure xs) = (l, x `lcons` r) + | otherwise = (xs, Empty) + where Split l x r = splitTree p mempty xs + +takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a +takeUntil p = fst . split p + +dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a +dropUntil p = snd . split p + +data Split t a = Split t a t + +splitTree :: (Measured v a) => + (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a +splitTree _ _ Empty = error "FingerTree.splitTree: bug!" +splitTree _p _i (Single x) = Split Empty x Empty +splitTree p i (Deep _ pr m sf) + | p vpr = let Split l x r = splitDigit p i pr + in Split (maybe Empty digitToTree l) x (deepL r m sf) + | p vm = let Split ml xs mr = splitTree p vpr m + Split l x r = splitNode p (vpr `mappendVal` ml) xs + in Split (deepR pr ml l) x (deepL r mr sf) + | otherwise = let Split l x r = splitDigit p vm sf + in Split (deepR pr m l) x (maybe Empty digitToTree r) + where vpr = i `mappend` measure pr + vm = vpr `mappendVal` m + +mappendVal :: (Measured v a) => v -> FingerTree v a -> v +mappendVal v Empty = v +mappendVal v t = v `mappend` measure t + +deepL :: (Measured v a) => + Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a +deepL Nothing m sf = case lview m of + Nothing -> digitToTree sf + Just (a,m') -> deep (nodeToDigit a) m' sf +deepL (Just pr) m sf = deep pr m sf + +deepR :: (Measured v a) => + Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a +deepR pr m Nothing = case rview m of + Nothing -> digitToTree pr + Just (a,m') -> deep pr m' (nodeToDigit a) +deepR pr m (Just sf) = deep pr m sf + +splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a -> + Split (Maybe (Digit a)) a +splitNode p i (Node2 _ a b) + | p va = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where va = i `mappend` measure a +splitNode p i (Node3 _ a b c) + | p va = Split Nothing a (Just (Two b c)) + | p vab = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where va = i `mappend` measure a + vab = va `mappend` measure b + +splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a -> + Split (Maybe (Digit a)) a +splitDigit _ i (One a) = i `seq` Split Nothing a Nothing +splitDigit p i (Two a b) + | p va = Split Nothing a (Just (One b)) + | otherwise = Split (Just (One a)) b Nothing + where va = i `mappend` measure a +splitDigit p i (Three a b c) + | p va = Split Nothing a (Just (Two b c)) + | p vab = Split (Just (One a)) b (Just (One c)) + | otherwise = Split (Just (Two a b)) c Nothing + where va = i `mappend` measure a + vab = va `mappend` measure b +splitDigit p i (Four a b c d) + | p va = Split Nothing a (Just (Three b c d)) + | p vab = Split (Just (One a)) b (Just (Two c d)) + | p vabc = Split (Just (Two a b)) c (Just (One d)) + | otherwise = Split (Just (Three a b c)) d Nothing + where va = i `mappend` measure a + vab = va `mappend` measure b + vabc = vab `mappend` measure c + + +-- | /O(n)/. The reverse of a sequence. +reverse :: (Measured v a) => FingerTree v a -> FingerTree v a +reverse = reverseTree id + +reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 +reverseTree _ Empty = Empty +reverseTree f (Single x) = Single (f x) +reverseTree f (Deep _ pr m sf) = + deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr) + +reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2 +reverseNode f (Node2 _ a b) = node2 (f b) (f a) +reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a) + +reverseDigit :: (a -> b) -> Digit a -> Digit b +reverseDigit f (One a) = One (f a) +reverseDigit f (Two a b) = Two (f b) (f a) +reverseDigit f (Three a b c) = Three (f c) (f b) (f a) +reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a) + +two :: Monad m => m a -> m (a, a) +two m = liftM2 (,) m m + +three :: Monad m => m a -> m (a, a, a) +three m = liftM3 (,,) m m m + +four :: Monad m => m a -> m (a, a, a, a) +four m = liftM4 (,,,) m m m m + +instance (Arbitrary a) => Arbitrary (Digit a) where + arbitrary = oneof + [ arbitrary >>= \x -> return (One x) + , two arbitrary >>= \(x,y) -> return (Two x y) + , three arbitrary >>= \(x,y,z) -> return (Three x y z) + , four arbitrary >>= \(x,y,z,w) -> return (Four x y z w) + ] + + +instance (CoArbitrary a) => CoArbitrary (Digit a) where + coarbitrary p = case p of + One x -> variant (0 :: Int) . coarbitrary x + Two x y -> variant (1 :: Int) . coarbitrary x . coarbitrary y + Three x y z -> variant (2 :: Int) . coarbitrary x . coarbitrary y + . coarbitrary z + Four x y z w -> variant (3 :: Int) . coarbitrary x . coarbitrary y + . coarbitrary z . coarbitrary w + + +instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where + arbitrary = oneof + [ two arbitrary >>= \(x,y) -> return (node2 x y) + , three arbitrary >>= \(x,y,z) -> return (node3 x y z) + ] + +instance (Measured v a, CoArbitrary a) => CoArbitrary (Node v a) where + coarbitrary p = case p of + Node2 _ x y -> variant (0 :: Int) . coarbitrary x . coarbitrary y + Node3 _ x y z -> variant (1 :: Int) . coarbitrary x . coarbitrary y . coarbitrary z + + +instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where + arbitrary = oneof + [ return Empty + , arbitrary >>= return . Single + , do + pf <- arbitrary + m <- arbitrary + sf <- arbitrary + return (deep pf m sf) + ] + +instance (Measured v a, CoArbitrary a) => CoArbitrary (FingerTree v a) where + coarbitrary p = case p of + Empty -> variant (0 :: Int) + Single x -> variant (1 :: Int) . coarbitrary x + Deep _ sf m pf -> variant (2 :: Int) . coarbitrary sf . coarbitrary m . coarbitrary pf
src/Data/Edison/Seq/BankersQueue.hs view
@@ -1,422 +1,440 @@--- |--- Module : Data.Edison.Seq.BankersQueue--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ This module implements Banker's Queues. It has the standard running--- times from "Data.Edison.Seq" except for the following:------ * rcons, size, inBounds @O( 1 )@------ /References:/------ * Chris Okasaki, /Purely Functional Data Structures/,--- 1998, sections 6.3.2 and 8.4.1.------ * Chris Okasaki, \"Simple and efficient purely functional--- queues and deques\", /Journal of Function Programming/--- 5(4):583-592, October 1995.--module Data.Edison.Seq.BankersQueue (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName--) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Data.Edison.Seq.ListSeq as L-import Data.Monoid-import Control.Monad.Identity-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a--structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.BankersQueue"---data Seq a = Q !Int [a] [a] !Int---- invariant: front at least as long as rear-structuralInvariant (Q x f r y) =- length f == x && length r == y && x >= y----- not exported-makeQ :: Int -> [a] -> [a] -> Int -> Seq a-makeQ i xs ys j- | j > i = Q (i + j) (xs ++ L.reverse ys) [] 0- | otherwise = Q i xs ys j--empty = Q 0 [] [] 0-singleton x = Q 1 [x] [] 0-lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j-rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1)--append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =- Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2--lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence"-lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j)--lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence"-lhead (Q _ (x:_) _ _) = x--lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence"-lheadM (Q _ (x:_) _ _) = return x--ltail (Q i (_:xs) ys j) = makeQ (i-1) xs ys j-ltail _ = error "BankersQueue.ltail: empty sequence"--ltailM (Q i (_:xs) ys j) = return (makeQ (i-1) xs ys j)-ltailM _ = fail "BankersQueue.ltail: empty sequence"--rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1))-rview (Q i xs [] _) =- case L.rview xs of- Nothing -> fail "BankersQueue.rview: empty sequence"- Just (x,xs') -> return (x, Q (i-1) xs' [] 0)--rhead (Q _ _ (y:_) _) = y-rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence"-rhead (Q _ xs [] _) = L.rhead xs--rheadM (Q _ _ (y:_) _) = return y-rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence"-rheadM (Q _ xs [] _) = return (L.rhead xs)--rtail (Q i xs (_:ys) j) = Q i xs ys (j-1)-rtail (Q _ [] [] _) = error "BankersQueue.rtail: empty sequence"-rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0--rtailM (Q i xs (_:ys) j) = return (Q i xs ys (j-1))-rtailM (Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence"-rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0)--null (Q i _ _ _) = (i == 0)-size (Q i _ _ j) = i + j-reverse (Q i xs ys j) = makeQ j ys xs i--reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) =- Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2--fromList xs = Q (length xs) xs [] 0--toList (Q _ xs ys j)- | j == 0 = xs- | otherwise = xs ++ L.reverse ys--map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j---- local fn on lists-revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1-revfoldr _ e [] = e-revfoldr f e (x:xs) = revfoldr f (f x e) xs--revfoldr' :: (t -> a -> a) -> a -> [t] -> a-revfoldr' _ e [] = e-revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs---- local fn on lists-revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t-revfoldl _ e [] = e-revfoldl f e (x:xs) = f (revfoldl f e xs) x--revfoldl' :: (b -> t -> b) -> b -> [t] -> b-revfoldl' _ e [] = e-revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs)--fold f e (Q _ xs ys _) = L.foldr f (L.foldr f e ys) xs-fold' f e (Q _ xs ys _) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'--foldr f e (Q _ xs ys _) = L.foldr f (revfoldr f e ys) xs-foldr' f e (Q _ xs ys _) = L.foldr' f (revfoldr' f e ys) xs-foldl f e (Q _ xs ys _) = revfoldl f (L.foldl f e xs) ys-foldl' f e (Q _ xs ys _) = revfoldl' f (L.foldl' f e xs) ys--foldr1 f (Q _ xs (y:ys) _) = L.foldr f (revfoldr f y ys) xs-foldr1 f (Q i xs [] _)- | i == 0 = error "BankersQueue.foldr1: empty sequence"- | otherwise = L.foldr1 f xs--foldr1' f (Q _ xs (y:ys) _) = L.foldr' f (revfoldr' f y ys) xs-foldr1' f (Q i xs [] _)- | i == 0 = error "BankersQueue.foldr1': empty sequence"- | otherwise = L.foldr1' f xs--foldl1 f (Q _ (x:xs) ys _) = revfoldl f (L.foldl f x xs) ys-foldl1 _ _ = error "BankersQueue.foldl1: empty sequence"--foldl1' f (Q _ (x:xs) ys _) = revfoldl' f (L.foldl' f x xs) ys-foldl1' _ _ = error "BankersQueue.foldl1': empty sequence"--copy n x- | n < 0 = empty- | otherwise = Q n (L.copy n x) [] 0---- reduce1: given sizes could do more effective job of dividing evenly!--lookup idx q = runIdentity (lookupM idx q)--lookupM idx (Q i xs ys j)- | idx < i = L.lookupM idx xs- | otherwise = L.lookupM (j - (idx - i) - 1) ys--lookupWithDefault d idx (Q i xs ys j)- | idx < i = L.lookupWithDefault d idx xs- | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys--update idx e q@(Q i xs ys j)- | idx < i = if idx < 0 then q- else Q i (L.update idx e xs) ys j- | otherwise = let k' = j - (idx - i) - 1- in if k' < 0 then q- else Q i xs (L.update k' e ys) j--adjust f idx q@(Q i xs ys j)- | idx < i = if idx < 0 then q- else Q i (L.adjust f idx xs) ys j- | otherwise = let k' = j - (idx - i) - 1- in if k' < 0 then q- else Q i xs (L.adjust f k' ys) j--{--could do- mapWithIndex :: (Int -> a -> b) -> s a -> s b- foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b- foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b-but don't bother for now--}--take len q@(Q i xs ys j) =- if len <= i then- if len <= 0 then empty- else Q len (L.take len xs) [] 0- else let len' = len - i in- if len' >= j then q- else Q i xs (L.drop (j - len') ys) len'--drop len q@(Q i xs ys j) =- if len <= i then- if len <= 0 then q- else makeQ (i - len) (L.drop len xs) ys j- else let len' = len - i in- if len' >= j then empty- else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0- -- could write more efficient version of reverse (take ...)--splitAt idx q@(Q i xs ys j) =- if idx <= i then- if idx <= 0 then (empty, q)- else let (xs',xs'') = L.splitAt idx xs- in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j)- else let idx' = idx - i in- if idx' >= j then (q, empty)- else let (ys', ys'') = L.splitAt (j - idx') ys- in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0)- -- could do splitAt followed by reverse more efficiently...---strict l@(Q _ xs ys _) = L.strict xs `seq` L.strict ys `seq` l-strictWith f l@(Q _ xs ys _) = L.strictWith f xs `seq` L.strictWith f ys `seq` l---- the remaining functions all use defaults--concat = concatUsingFoldr-concatMap = concatMapUsingFoldr-reducer = reducerUsingReduce1-reducel = reducelUsingReduce1-reduce1 = reduce1UsingLists-reducer' = reducer'UsingReduce1'-reducel' = reducel'UsingReduce1'-reduce1' = reduce1'UsingLists-inBounds = inBoundsUsingSize-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-subseq = subseqDefault-filter = filterUsingLists-partition = partitionUsingLists-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview-zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer';- reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;- foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty--instance Eq a => Eq (Seq a) where- q1 == q2 =- (size q1 == size q2) && (toList q1 == toList q2)--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary =- do xs <- arbitrary- ys <- arbitrary- return (let i = L.size xs- j = L.size ys- in if i >= j then Q i xs ys j else Q j ys xs i)--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary (Q _ xs ys _) = coarbitrary xs . coarbitrary ys--instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.BankersQueue +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module implements Banker's Queues. It has the standard running +-- times from "Data.Edison.Seq" except for the following: +-- +-- * rcons, size, inBounds @O( 1 )@ +-- +-- /References:/ +-- +-- * Chris Okasaki, /Purely Functional Data Structures/, +-- 1998, sections 6.3.2 and 8.4.1. +-- +-- * Chris Okasaki, \"Simple and efficient purely functional +-- queues and deques\", /Journal of Function Programming/ +-- 5(4):583-592, October 1995. + +module Data.Edison.Seq.BankersQueue ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName + +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App + +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Data.Edison.Seq.ListSeq as L +import Data.Monoid +import Data.Semigroup as SG +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a + +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.BankersQueue" + + +data Seq a = Q !Int [a] [a] !Int + +-- invariant: front at least as long as rear +structuralInvariant (Q x f r y) = + length f == x && length r == y && x >= y + + +-- not exported +makeQ :: Int -> [a] -> [a] -> Int -> Seq a +makeQ i xs ys j + | j > i = Q (i + j) (xs ++ L.reverse ys) [] 0 + | otherwise = Q i xs ys j + +empty = Q 0 [] [] 0 +singleton x = Q 1 [x] [] 0 +lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j +rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1) + +append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) = + Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2 + +lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence" +lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j) + +lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence" +lhead (Q _ (x:_) _ _) = x + +lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence" +lheadM (Q _ (x:_) _ _) = return x + +ltail (Q i (_:xs) ys j) = makeQ (i-1) xs ys j +ltail _ = error "BankersQueue.ltail: empty sequence" + +ltailM (Q i (_:xs) ys j) = return (makeQ (i-1) xs ys j) +ltailM _ = fail "BankersQueue.ltail: empty sequence" + +rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1)) +rview (Q i xs [] _) = + case L.rview xs of + Nothing -> fail "BankersQueue.rview: empty sequence" + Just (x,xs') -> return (x, Q (i-1) xs' [] 0) + +rhead (Q _ _ (y:_) _) = y +rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence" +rhead (Q _ xs [] _) = L.rhead xs + +rheadM (Q _ _ (y:_) _) = return y +rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence" +rheadM (Q _ xs [] _) = return (L.rhead xs) + +rtail (Q i xs (_:ys) j) = Q i xs ys (j-1) +rtail (Q _ [] [] _) = error "BankersQueue.rtail: empty sequence" +rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0 + +rtailM (Q i xs (_:ys) j) = return (Q i xs ys (j-1)) +rtailM (Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence" +rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0) + +null (Q i _ _ _) = (i == 0) +size (Q i _ _ j) = i + j +reverse (Q i xs ys j) = makeQ j ys xs i + +reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) = + Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2 + +fromList xs = Q (length xs) xs [] 0 + +toList (Q _ xs ys j) + | j == 0 = xs + | otherwise = xs ++ L.reverse ys + +map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j + +-- local fn on lists +revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1 +revfoldr _ e [] = e +revfoldr f e (x:xs) = revfoldr f (f x e) xs + +revfoldr' :: (t -> a -> a) -> a -> [t] -> a +revfoldr' _ e [] = e +revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs + +-- local fn on lists +revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t +revfoldl _ e [] = e +revfoldl f e (x:xs) = f (revfoldl f e xs) x + +revfoldl' :: (b -> t -> b) -> b -> [t] -> b +revfoldl' _ e [] = e +revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs) + +fold f e (Q _ xs ys _) = L.foldr f (L.foldr f e ys) xs +fold' f e (Q _ xs ys _) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr f e (Q _ xs ys _) = L.foldr f (revfoldr f e ys) xs +foldr' f e (Q _ xs ys _) = L.foldr' f (revfoldr' f e ys) xs +foldl f e (Q _ xs ys _) = revfoldl f (L.foldl f e xs) ys +foldl' f e (Q _ xs ys _) = revfoldl' f (L.foldl' f e xs) ys + +foldr1 f (Q _ xs (y:ys) _) = L.foldr f (revfoldr f y ys) xs +foldr1 f (Q i xs [] _) + | i == 0 = error "BankersQueue.foldr1: empty sequence" + | otherwise = L.foldr1 f xs + +foldr1' f (Q _ xs (y:ys) _) = L.foldr' f (revfoldr' f y ys) xs +foldr1' f (Q i xs [] _) + | i == 0 = error "BankersQueue.foldr1': empty sequence" + | otherwise = L.foldr1' f xs + +foldl1 f (Q _ (x:xs) ys _) = revfoldl f (L.foldl f x xs) ys +foldl1 _ _ = error "BankersQueue.foldl1: empty sequence" + +foldl1' f (Q _ (x:xs) ys _) = revfoldl' f (L.foldl' f x xs) ys +foldl1' _ _ = error "BankersQueue.foldl1': empty sequence" + +copy n x + | n < 0 = empty + | otherwise = Q n (L.copy n x) [] 0 + +-- reduce1: given sizes could do more effective job of dividing evenly! + +lookup idx q = runFail_ (lookupM idx q) + +lookupM idx (Q i xs ys j) + | idx < i = L.lookupM idx xs + | otherwise = L.lookupM (j - (idx - i) - 1) ys + +lookupWithDefault d idx (Q i xs ys j) + | idx < i = L.lookupWithDefault d idx xs + | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys + +update idx e q@(Q i xs ys j) + | idx < i = if idx < 0 then q + else Q i (L.update idx e xs) ys j + | otherwise = let k' = j - (idx - i) - 1 + in if k' < 0 then q + else Q i xs (L.update k' e ys) j + +adjust f idx q@(Q i xs ys j) + | idx < i = if idx < 0 then q + else Q i (L.adjust f idx xs) ys j + | otherwise = let k' = j - (idx - i) - 1 + in if k' < 0 then q + else Q i xs (L.adjust f k' ys) j + +{- +could do + mapWithIndex :: (Int -> a -> b) -> s a -> s b + foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b + foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b +but don't bother for now +-} + +take len q@(Q i xs ys j) = + if len <= i then + if len <= 0 then empty + else Q len (L.take len xs) [] 0 + else let len' = len - i in + if len' >= j then q + else Q i xs (L.drop (j - len') ys) len' + +drop len q@(Q i xs ys j) = + if len <= i then + if len <= 0 then q + else makeQ (i - len) (L.drop len xs) ys j + else let len' = len - i in + if len' >= j then empty + else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0 + -- could write more efficient version of reverse (take ...) + +splitAt idx q@(Q i xs ys j) = + if idx <= i then + if idx <= 0 then (empty, q) + else let (xs',xs'') = L.splitAt idx xs + in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j) + else let idx' = idx - i in + if idx' >= j then (q, empty) + else let (ys', ys'') = L.splitAt (j - idx') ys + in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0) + -- could do splitAt followed by reverse more efficiently... + + +strict l@(Q _ xs ys _) = L.strict xs `seq` L.strict ys `seq` l +strictWith f l@(Q _ xs ys _) = L.strictWith f xs `seq` L.strictWith f ys `seq` l + +-- the remaining functions all use defaults + +concat = concatUsingFoldr +concatMap = concatMapUsingFoldr +reducer = reducerUsingReduce1 +reducel = reducelUsingReduce1 +reduce1 = reduce1UsingLists +reducer' = reducer'UsingReduce1' +reducel' = reducel'UsingReduce1' +reduce1' = reduce1'UsingLists +inBounds = inBoundsUsingSize +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists +subseq = subseqDefault +filter = filterUsingLists +partition = partitionUsingLists +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview +zip = zipUsingLists +zip3 = zip3UsingLists +zipWith = zipWithUsingLists +zipWith3 = zipWith3UsingLists +unzip = unzipUsingLists +unzip3 = unzip3UsingLists +unzipWith = unzipWithUsingLists +unzipWith3 = unzipWith3UsingLists + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; + reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; + foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + q1 == q2 = + (size q1 == size q2) && (toList q1 == toList q2) + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = + do xs <- arbitrary + ys <- arbitrary + return (let i = L.size xs + j = L.size ys + in if i >= j then Q i xs ys j else Q j ys xs i) + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary (Q _ xs ys _) = coarbitrary xs . coarbitrary ys + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/BinaryRandList.hs view
@@ -1,452 +1,468 @@--- |--- Module : Data.Edison.Seq.BinaryRandList--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Binary Random-Access lists. All functions have the standard running--- times from "Data.Edison.Seq" except the following:------ * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop @O( log n )@------ * copy, inBounds @O( i )@------ * append, reverseOnto @O( n1 + log n2 )@------ * take, splitAt @O( i + log n )@------ * subseq @O( log n + len )@------ * zip @O( min( n1, n2 ) + log max( n1, n2 ) )@------ /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.--- Section 10.1.2.--module Data.Edison.Seq.BinaryRandList (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import Control.Monad.Identity-import Data.Maybe--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import Data.Monoid-import Control.Monad-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.BinaryRandList"---data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a)) deriving (Eq)---- not exported, rewrite as bit ops?---even n = (n `mod` 2) == 0---odd n = (n `mod` 2) <> 0-half :: (Integral a) => a -> a-half n = n `div` 2--mkEven :: Seq (a, a) -> Seq a-mkEven E = E-mkEven ps = Even ps--empty = E-singleton x = Odd x E--lcons x E = Odd x E-lcons x (Even ps) = Odd x ps-lcons x (Odd y ps) = Even (lcons (x,y) ps)--append xs E = xs-append xs ys@(Even pys) =- case xs of- E -> ys- Even pxs -> Even (append pxs pys)- Odd x pxs -> Odd x (append pxs pys)-append xs ys@(Odd _ _) = foldr lcons ys xs--copy n x- | n <= 0 = E- | otherwise = cp n x- where cp :: Int -> a -> Seq a- cp n x- | odd n = Odd x (cp (half n) (x,x))- | n == 0 = E- | otherwise = Even (cp (half n) (x,x))--lview E = fail "BinaryRandList.lview: empty sequence"-lview (Even ps) = case lview ps of- Just ((x,y), ps') -> return (x, Odd y ps')- Nothing -> error "BinaryRandList.lview: bug!"-lview (Odd x ps) = return (x, mkEven ps)--lhead E = error "BinaryRandList.lhead: empty sequence"-lhead (Even ps) = fst (lhead ps)-lhead (Odd x _) = x--lheadM E = fail "BinaryRandList.lheadM: empty sequence"-lheadM (Even ps) = return (fst (lhead ps))-lheadM (Odd x _) = return (x)--ltail E = error "BinaryRandList.ltail: empty sequence"-ltail (Even ps) = case lview ps of- Just ((_,y), ps') -> Odd y ps'- Nothing -> error "BinaryRandList.ltail: bug!"-ltail (Odd _ ps) = mkEven ps--ltailM E = fail "BinaryRandList.ltailM: empty sequence"-ltailM (Even ps) = case lview ps of- Just ((_,y), ps') -> return (Odd y ps')- Nothing -> error "BinaryRandList.ltailM: bug!"-ltailM (Odd _ ps) = return (mkEven ps)--rhead E = error "BinaryRandList.rhead: empty sequence"-rhead (Even ps) = snd (rhead ps)-rhead (Odd x E) = x-rhead (Odd _ ps) = snd (rhead ps)--rheadM E = fail "BinaryRandList.rheadM: empty sequence"-rheadM (Even ps) = return (snd (rhead ps))-rheadM (Odd x E) = return x-rheadM (Odd _ ps) = return (snd (rhead ps))---null E = True-null _ = False--size E = 0-size (Even ps) = 2 * size ps-size (Odd _ ps) = 1 + 2 * size ps--map _ E = E-map f (Even ps) = Even (map (\(x,y) -> (f x,f y)) ps)-map f (Odd x ps) = Odd (f x) (map (\(y,z) -> (f y,f z)) ps)--fold = foldr-fold' = foldr'-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (Even ps) = foldr (\(x,y) e -> f x (f y e)) e ps-foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps)--foldr' _ e E = e-foldr' f e (Even ps) = foldr' (\(x,y) e -> f x $! f y $! e) e ps-foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps)--foldl _ e E = e-foldl f e (Even ps) = foldl (\e (x,y) -> f (f e x) y) e ps-foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps--foldl' _ e E = e-foldl' f e (Even ps) = foldl' (\e (x,y) -> f (f e x) y) e ps-foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps--reduce1 _ E = error "BinaryRandList.reduce1: empty seq"-reduce1 f (Even ps) = reduce1 f (map (uncurry f) ps)-reduce1 _ (Odd x E) = x-reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps))--reduce1' _ E = error "BinaryRandList.reduce1': empty seq"-reduce1' f (Even ps) = reduce1' f (map (uncurry f) ps)-reduce1' _ (Odd x E) = x-reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps))---inBounds i xs = (i >= 0) && inb xs i- where inb :: Seq a -> Int -> Bool- inb E _ = False- inb (Even ps) i = inb ps (half i)- inb (Odd _ ps) i = (i == 0) || inb ps (half (i-1))--lookup i xs = runIdentity (lookupM i xs)--lookupM i xs- | i < 0 = fail "BinaryRandList.lookup: bad subscript"- | otherwise = lookFun nothing xs i return- where- nothing = fail "BinaryRandList.lookup: not found"--lookupWithDefault d i xs- | i < 0 = d- | otherwise = lookFun d xs i id---- not exported-lookFun :: b -> Seq a -> Int -> (a -> b) -> b-lookFun d E _ _ = d-lookFun d (Even ps) i f- | even i = lookFun d ps (half i) (f . fst)- | otherwise = lookFun d ps (half i) (f . snd)-lookFun d (Odd x ps) i f- | odd i = lookFun d ps (half (i-1)) (f . fst)- | i == 0 = f x- | otherwise = lookFun d ps (half (i-1)) (f . snd)--adjust f i xs- | i < 0 = xs- | otherwise = adj f i xs- where adj :: (a -> a) -> Int -> Seq a -> Seq a- adj _ _ E = E- adj f i (Even ps)- | even i = Even (adj (mapFst f) (half i) ps)- | otherwise = Even (adj (mapSnd f) (half i) ps)- adj f i (Odd x ps)- | odd i = Odd x (adj (mapFst f) (half (i-1)) ps)- | i == 0 = Odd (f x) ps- | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps)---- not exported-mapFst :: (t -> t2) -> (t, t1) -> (t2, t1)-mapFst f (x,y) = (f x,y)-mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2)-mapSnd f (x,y) = (x,f y)--take n xs = if n <= 0 then E else tak n xs- where tak :: Int -> Seq a -> Seq a- tak 0 _ = E- tak _ E = E- tak i (Even ps)- | even i = Even (tak (half i) ps)- tak i (Odd x ps)- | odd i = Odd x (tak (half (i-1)) ps)- tak i xs = takeUsingLists i xs---- drop is O(log^2 n) instead of O(log n)??-drop n xs = if n <= 0 then xs else drp n xs- where drp :: Int -> Seq a -> Seq a- drp 0 xs = xs- drp _ E = E- drp i (Even ps)- | even i = mkEven (drp (half i) ps)- | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps)))- drp i (Odd _ ps)- | odd i = mkEven (drp (half (i-1)) ps)- | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps)))---strict l@E = l-strict l@(Even l') = strict l' `seq` l-strict l@(Odd _ l') = strict l' `seq` l--strictWith _ l@E = l-strictWith f l@(Even l') = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l-strictWith f l@(Odd x _') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l----- structural invariants are enforced by the type system-structuralInvariant = const True---- the remaining functions all use defaults--rcons = rconsUsingFoldr-rview = rviewDefault-rtail = rtailUsingLview-rtailM = rtailMUsingLview-concat = concatUsingFoldr-reverse = reverseUsingReverseOnto-reverseOnto = reverseOntoUsingFoldl-fromList = fromListUsingCons-toList = toListUsingFoldr-concatMap = concatMapUsingFoldr-foldr1 = foldr1UsingLview-foldr1' = foldr1'UsingLview-foldl1 = foldl1UsingFoldl-foldl1' = foldl1'UsingFoldl'-reducer = reducerUsingReduce1-reducel = reducelUsingReduce1-reducer' = reducer'UsingReduce1'-reducel' = reducel'UsingReduce1'-update = updateUsingAdjust-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-splitAt = splitAtDefault-filter = filterUsingFoldr-partition = partitionUsingFoldr-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview---- for zips, could optimize by calculating which one is shorter and--- retaining its shape--zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty---- instance Eq (Seq a) is derived--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = do xs <- arbitrary- return (fromList xs)--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary E = variant 0- coarbitrary (Even ps) = variant 1 . coarbitrary ps- coarbitrary (Odd x ps) = variant 2 . coarbitrary x . coarbitrary ps---instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.BinaryRandList +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Binary Random-Access lists. All functions have the standard running +-- times from "Data.Edison.Seq" except the following: +-- +-- * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop @O( log n )@ +-- +-- * copy, inBounds @O( i )@ +-- +-- * append, reverseOnto @O( n1 + log n2 )@ +-- +-- * take, splitAt @O( i + log n )@ +-- +-- * subseq @O( log n + len )@ +-- +-- * zip @O( min( n1, n2 ) + log max( n1, n2 ) )@ +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. +-- Section 10.1.2. + +module Data.Edison.Seq.BinaryRandList ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App +import Data.Maybe + +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.BinaryRandList" + + +data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a)) deriving (Eq) + +-- not exported, rewrite as bit ops? +--even n = (n `mod` 2) == 0 +--odd n = (n `mod` 2) <> 0 +half :: (Integral a) => a -> a +half n = n `div` 2 + +mkEven :: Seq (a, a) -> Seq a +mkEven E = E +mkEven ps = Even ps + +empty = E +singleton x = Odd x E + +lcons x E = Odd x E +lcons x (Even ps) = Odd x ps +lcons x (Odd y ps) = Even (lcons (x,y) ps) + +append xs E = xs +append xs ys@(Even pys) = + case xs of + E -> ys + Even pxs -> Even (append pxs pys) + Odd x pxs -> Odd x (append pxs pys) +append xs ys@(Odd _ _) = foldr lcons ys xs + +copy n x + | n <= 0 = E + | otherwise = cp n x + where cp :: Int -> a -> Seq a + cp n x + | odd n = Odd x (cp (half n) (x,x)) + | n == 0 = E + | otherwise = Even (cp (half n) (x,x)) + +lview E = fail "BinaryRandList.lview: empty sequence" +lview (Even ps) = case lview ps of + Just ((x,y), ps') -> return (x, Odd y ps') + Nothing -> error "BinaryRandList.lview: bug!" +lview (Odd x ps) = return (x, mkEven ps) + +lhead E = error "BinaryRandList.lhead: empty sequence" +lhead (Even ps) = fst (lhead ps) +lhead (Odd x _) = x + +lheadM E = fail "BinaryRandList.lheadM: empty sequence" +lheadM (Even ps) = return (fst (lhead ps)) +lheadM (Odd x _) = return (x) + +ltail E = error "BinaryRandList.ltail: empty sequence" +ltail (Even ps) = case lview ps of + Just ((_,y), ps') -> Odd y ps' + Nothing -> error "BinaryRandList.ltail: bug!" +ltail (Odd _ ps) = mkEven ps + +ltailM E = fail "BinaryRandList.ltailM: empty sequence" +ltailM (Even ps) = case lview ps of + Just ((_,y), ps') -> return (Odd y ps') + Nothing -> error "BinaryRandList.ltailM: bug!" +ltailM (Odd _ ps) = return (mkEven ps) + +rhead E = error "BinaryRandList.rhead: empty sequence" +rhead (Even ps) = snd (rhead ps) +rhead (Odd x E) = x +rhead (Odd _ ps) = snd (rhead ps) + +rheadM E = fail "BinaryRandList.rheadM: empty sequence" +rheadM (Even ps) = return (snd (rhead ps)) +rheadM (Odd x E) = return x +rheadM (Odd _ ps) = return (snd (rhead ps)) + + +null E = True +null _ = False + +size E = 0 +size (Even ps) = 2 * size ps +size (Odd _ ps) = 1 + 2 * size ps + +map _ E = E +map f (Even ps) = Even (map (\(x,y) -> (f x,f y)) ps) +map f (Odd x ps) = Odd (f x) (map (\(y,z) -> (f y,f z)) ps) + +fold = foldr +fold' = foldr' +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr _ e E = e +foldr f e (Even ps) = foldr (\(x,y) e -> f x (f y e)) e ps +foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps) + +foldr' _ e E = e +foldr' f e (Even ps) = foldr' (\(x,y) e -> f x $! f y $! e) e ps +foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps) + +foldl _ e E = e +foldl f e (Even ps) = foldl (\e (x,y) -> f (f e x) y) e ps +foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps + +foldl' _ e E = e +foldl' f e (Even ps) = foldl' (\e (x,y) -> f (f e x) y) e ps +foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps + +reduce1 _ E = error "BinaryRandList.reduce1: empty seq" +reduce1 f (Even ps) = reduce1 f (map (uncurry f) ps) +reduce1 _ (Odd x E) = x +reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps)) + +reduce1' _ E = error "BinaryRandList.reduce1': empty seq" +reduce1' f (Even ps) = reduce1' f (map (uncurry f) ps) +reduce1' _ (Odd x E) = x +reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps)) + + +inBounds i xs = (i >= 0) && inb xs i + where inb :: Seq a -> Int -> Bool + inb E _ = False + inb (Even ps) i = inb ps (half i) + inb (Odd _ ps) i = (i == 0) || inb ps (half (i-1)) + +lookup i xs = runFail_ (lookupM i xs) + +lookupM i xs + | i < 0 = fail "BinaryRandList.lookup: bad subscript" + | otherwise = lookFun nothing xs i return + where + nothing = fail "BinaryRandList.lookup: not found" + +lookupWithDefault d i xs + | i < 0 = d + | otherwise = lookFun d xs i id + +-- not exported +lookFun :: b -> Seq a -> Int -> (a -> b) -> b +lookFun d E _ _ = d +lookFun d (Even ps) i f + | even i = lookFun d ps (half i) (f . fst) + | otherwise = lookFun d ps (half i) (f . snd) +lookFun d (Odd x ps) i f + | odd i = lookFun d ps (half (i-1)) (f . fst) + | i == 0 = f x + | otherwise = lookFun d ps (half (i-1)) (f . snd) + +adjust f i xs + | i < 0 = xs + | otherwise = adj f i xs + where adj :: (a -> a) -> Int -> Seq a -> Seq a + adj _ _ E = E + adj f i (Even ps) + | even i = Even (adj (mapFst f) (half i) ps) + | otherwise = Even (adj (mapSnd f) (half i) ps) + adj f i (Odd x ps) + | odd i = Odd x (adj (mapFst f) (half (i-1)) ps) + | i == 0 = Odd (f x) ps + | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps) + +-- not exported +mapFst :: (t -> t2) -> (t, t1) -> (t2, t1) +mapFst f (x,y) = (f x,y) +mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2) +mapSnd f (x,y) = (x,f y) + +take n xs = if n <= 0 then E else tak n xs + where tak :: Int -> Seq a -> Seq a + tak 0 _ = E + tak _ E = E + tak i (Even ps) + | even i = Even (tak (half i) ps) + tak i (Odd x ps) + | odd i = Odd x (tak (half (i-1)) ps) + tak i xs = takeUsingLists i xs + +-- drop is O(log^2 n) instead of O(log n)?? +drop n xs = if n <= 0 then xs else drp n xs + where drp :: Int -> Seq a -> Seq a + drp 0 xs = xs + drp _ E = E + drp i (Even ps) + | even i = mkEven (drp (half i) ps) + | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps))) + drp i (Odd _ ps) + | odd i = mkEven (drp (half (i-1)) ps) + | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps))) + + +strict l@E = l +strict l@(Even l') = strict l' `seq` l +strict l@(Odd _ l') = strict l' `seq` l + +strictWith _ l@E = l +strictWith f l@(Even l') = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l +strictWith f l@(Odd x _') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l + + +-- structural invariants are enforced by the type system +structuralInvariant = const True + +-- the remaining functions all use defaults + +rcons = rconsUsingFoldr +rview = rviewDefault +rtail = rtailUsingLview +rtailM = rtailMUsingLview +concat = concatUsingFoldr +reverse = reverseUsingReverseOnto +reverseOnto = reverseOntoUsingFoldl +fromList = fromListUsingCons +toList = toListUsingFoldr +concatMap = concatMapUsingFoldr +foldr1 = foldr1UsingLview +foldr1' = foldr1'UsingLview +foldl1 = foldl1UsingFoldl +foldl1' = foldl1'UsingFoldl' +reducer = reducerUsingReduce1 +reducel = reducelUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel' = reducel'UsingReduce1' +update = updateUsingAdjust +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex' = foldlWithIndex'UsingLists +splitAt = splitAtDefault +filter = filterUsingFoldr +partition = partitionUsingFoldr +subseq = subseqDefault +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview + +-- for zips, could optimize by calculating which one is shorter and +-- retaining its shape + +zip = zipUsingLists +zip3 = zip3UsingLists +zipWith = zipWithUsingLists +zipWith3 = zipWith3UsingLists +unzip = unzipUsingLists +unzip3 = unzip3UsingLists +unzipWith = unzipWithUsingLists +unzipWith3 = unzipWith3UsingLists + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +-- instance Eq (Seq a) is derived + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + return (fromList xs) + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (Even ps) = variant (1 :: Int) . coarbitrary ps + coarbitrary (Odd x ps) = variant (2 :: Int) . coarbitrary x . coarbitrary ps + + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/BraunSeq.hs view
@@ -1,552 +1,567 @@--- |--- Module : Data.Edison.Seq.BraunSeq--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ One-sided Braun sequences. All running times are as listed in--- "Data.Edison.Seq" except the following:------ * lview, lcons, ltail* @O( log n )@------ * rcons, rview, rhead*, rtail*, size @O( log^2 n )@------ * copy, inBounds, lookup*, update, adjust @O( log i )@------ * append @O( n1 log n2 )@------ * concat @O( n + m log m )@------ * drop, splitAt @O( i log n )@------ * subseq @O( i log n + len )@------ * reverseOnto @O( n1 log n2 )@------ * concatMap, (>>=) @O( n * t + m log m )@, where @n@ is the length of the input sequence--- @m@ is the length of the output sequence and @t@--- is the running time of @f@------ By keeping track of the size, we could get rcons, rview, rhead*, and rtail*--- down to @O(log n)@ as well; furthermore, size would be @O( 1 )@.------ /References:/------ * Rob Hoogerwoord. \"A symmetric set of efficient list operations\".--- /Journal of Functional Programming/, 2(4):505--513, 1992.------ * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\".--- /Mathematics of Program Construction/ (MPC'92), pages 191-207.------ * Chris Okasaki. \"Three algorithms on Braun Trees\".--- /Journal of Function Programming/ 7(6):661-666. Novemebr 1997.--module Data.Edison.Seq.BraunSeq (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import Control.Monad.Identity-import Data.Maybe-import Data.Monoid-import Test.QuickCheck--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Data.Edison.Seq.ListSeq as L----- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.BraunSeq"---data Seq a = E | B a (Seq a) (Seq a) deriving (Eq)--half :: Int -> Int-half n = n `quot` 2 -- use a shift?--empty = E-singleton x = B x E E--lcons x E = singleton x-lcons x (B y a b) = B x (lcons y b) a--rcons y ys = insAt (size ys) ys- where insAt 0 _ = singleton y- insAt i (B x a b)- | odd i = B x (insAt (half i) a) b- | otherwise = B x a (insAt (half i - 1) b)- insAt _ _ = error "BraunSeq.rcons: bug. Impossible case!"--append xs E = xs-append xs ys = app (size xs) xs ys- where app 0 _ ys = ys- app _ xs E = xs- app n (B x a b) (B y c d)- | odd n = B x (app m a (lcons y d)) (app m b c)- | otherwise = B x (app m a c) (app (m-1) b (lcons y d))- where m = half n- app _ _ _ = error "BraunSeq.append: bug!"- -- how does it compare to converting to/from lists?--lview E = fail "BraunSeq.lview: empty sequence"-lview (B x a b) = return (x, combine a b)---- not exported-combine :: Seq a -> Seq a -> Seq a-combine E _ = E-combine (B x a b) c = B x c (combine a b)--lhead E = error "BraunSeq.lhead: empty sequence"-lhead (B x _ _) = x--lheadM E = fail "BraunSeq.lheadM: empty sequence"-lheadM (B x _ _) = return x--ltail E = error "BraunSeq.ltail: empty sequence"-ltail (B _ a b) = combine a b--ltailM E = fail "BraunSeq.ltailM: empty sequence"-ltailM (B _ a b) = return (combine a b)---- not exported--- precondition: i >= 0-delAt :: Int -> Seq a -> Seq a-delAt 0 _ = E-delAt i (B x a b)- | odd i = B x (delAt (half i) a) b- | otherwise = B x a (delAt (half i - 1) b)-delAt _ _ = error "BraunSeq.delAt: bug. Impossible case!"--rview E = fail "BraunSeq.rview: empty sequence"-rview xs = return (lookup m xs, delAt m xs)- where m = size xs - 1--rhead E = error "BraunSeq.rhead: empty sequence"-rhead xs = lookup (size xs - 1) xs--rheadM E = fail "BraunSeq.rheadM: empty sequence"-rheadM xs = return (lookup (size xs - 1) xs)--rtail E = error "BraunSeq.rtail: empty sequence"-rtail xs = delAt (size xs - 1) xs--rtailM E = fail "BraunSeq.rtailM: empty sequence"-rtailM xs = return (delAt (size xs - 1) xs)--null E = True-null _ = False--size E = 0-size (B _ a b) = 1 + n + n + diff n a- where n = size b-- diff 0 E = 0- diff 0 (B _ _ _) = 1- diff i (B _ a b)- | odd i = diff (half i) a- | otherwise = diff (half i - 1) b- diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!"--reverse xs = rev00 (size xs) xs- where- rev00 n xs- | n <= 1 = xs- rev00 n (B x a b)- | odd n = let a' = rev00 m a- (x',b') = rev11 m x b in B x' a' b'- | otherwise = let (x',a') = rev01 m a- b' = rev10 (m-1) x b in B x' b' a'- where m = half n- rev00 _ _ = error "BraunSeq.reverse: bug!"-- rev11 _ x E = (x,E)- rev11 n x (B y a b)- | odd n = let (x',a') = rev11 m x a- (y',b') = rev11 m y b in (y', B x' b' a')- | otherwise = let (x',a') = rev11 m x a- (y',b') = rev11 (m-1) y b in (x', B y' a' b')- where m = half n-- rev01 _ E = error "BraunSeq.reverse: bug!"- rev01 n (B x a b)- | n == 1 = (x, E)- | odd n = let (y',a') = rev01 m a- (x',b') = rev11 m x b in (x', B y' b' a')- | otherwise = let (y',a') = rev01 m a- (x',b') = rev11 (m-1) x b in (y', B x' a' b')- where m = half n-- rev10 _ x E = B x E E- rev10 n x (B y a b)- | odd n = let a' = rev10 m x a- (y',b') = rev11 m y b in B y' a' b'- | otherwise = let (x',a') = rev11 m x a- b' = rev10 (m-1) y b in B x' b' a'- where m = half n--fromList = L.lhead . L.foldr build [E] . rows 1- where rows _ [] = []- rows k xs = (k, ys) : rows (k+k) zs- where (ys,zs) = L.splitAt k xs-- build (k,xs) ts = zipWithB xs ts1 ts2- where (ts1, ts2) = L.splitAt k ts-- zipWithB [] _ _ = []- zipWithB (x:xs) [] _ = singleton x : L.map singleton xs- zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts []- zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2--toList E = []-toList t = tol [t]- where tol [] = []- tol ts = xs ++ tol (ts1 ++ ts2)- where xs = L.map root ts- (ts1,ts2) = children ts-- children [] = ([],[])- children (B _ E _ : _) = ([],[])- children (B _ a E : ts) = (a : leftChildren ts, [])- children (B _ a b : ts) = (a : ts1, b : ts2)- where (ts1, ts2) = children ts- children _ = error "BraunSeq.toList: bug!"-- leftChildren [] = []- leftChildren (B _ E _ : _) = []- leftChildren (B _ a _ : ts) = a : leftChildren ts- leftChildren _ = error "BraunSeq.toList: bug!"-- root (B x _ _) = x- root _ = error "BraunSeq.toList: bug!"-- (B _ a _) = a--- (left _) = error "BraunSeq.toList: bug!"--map _ E = E-map f (B x a b) = B (f x) (map f a) (map f b)--copy n x = if n <= 0 then empty else fst (copy2 n)- where copy2 n- | odd n = (B x a a, B x b a)- | n == 0 = (E, singleton x)- | otherwise = (B x b a, B x b b)- where (a, b) = copy2 (half (n-1))--inBounds i xs = (i >= 0) && inb xs i- where inb E _ = False- inb (B _ a b) i- | odd i = inb a (half i)- | i == 0 = True- | otherwise = inb b (half i - 1)--lookup i xs = runIdentity (lookupM i xs)--lookupM i xs- | i < 0 = fail "BraunSeq.lookupM: bad subscript"- | otherwise = look xs i- where look E _ = nothing- look (B x a b) i- | odd i = look a (half i)- | i == 0 = return x- | otherwise = look b (half i - 1)- nothing = fail "BraunSeq.lookupM: not found"--lookupWithDefault d i xs = if i < 0 then d- else look xs i- where look E _ = d- look (B x a b) i- | odd i = look a (half i)- | i == 0 = x- | otherwise = look b (half i - 1)--update i y xs = if i < 0 then xs else upd i xs- where upd _ E = E- upd i (B x a b)- | odd i = B x (upd (half i) a) b- | i == 0 = B y a b- | otherwise = B x a (upd (half i - 1) b)--adjust f i xs = if i < 0 then xs else adj i xs- where adj _ E = E- adj i (B x a b)- | odd i = B x (adj (half i) a) b- | i == 0 = B (f x) a b- | otherwise = B x a (adj (half i - 1) b)--mapWithIndex f xs = mwi 0 1 xs- where mwi _ _ E = E- mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b)- where dd = d+d--take n xs = if n <= 0 then E else ta n xs- where ta _ E = E- ta n (B x a b)- | odd n = B x (ta m a) (ta m b)- | n == 0 = E- | otherwise = B x (ta m a) (ta (m-1) b)- where m = half n--drop n xs = if n <= 0 then xs else dr n xs- where dr _ E = E- dr n t@(B _ a b)- | odd n = combine (dr m a) (dr m b)- | n == 0 = t- | otherwise = combine (dr (m-1) b) (dr m a)- where m = half n--zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d)-zip _ _ = E--zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f)-zip3 _ _ _ = E--zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d)-zipWith _ _ _ = E--zipWith3 fn (B x a b) (B y c d) (B z e f) =- B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f)-zipWith3 _ _ _ _ = E--unzip E = (E, E)-unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2)- where (a1,a2) = unzip a- (b1,b2) = unzip b--unzip3 E = (E, E, E)-unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3)- where (a1,a2,a3) = unzip3 a- (b1,b2,b3) = unzip3 b--unzipWith _ _ E = (E, E)-unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2)- where (a1,a2) = unzipWith f g a- (b1,b2) = unzipWith f g b--unzipWith3 _ _ _ E = (E, E, E)-unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3)- where (a1,a2,a3) = unzipWith3 f g h a- (b1,b2,b3) = unzipWith3 f g h b---strict s@E = s-strict s@(B _ l r) = strict l `seq` strict r `seq` s--strictWith _ s@E = s-strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s---- invariants:--- * Left subtree is exactily the same size as the right--- subtree, or one element larger---- structuralInvariant :: Seq a -> Bool-structuralInvariant E = True-structuralInvariant (B _ l r) = isJust (check l r)-- where check :: Seq a -> Seq a -> Maybe Int- check E E = Just 1- check (B _ E E) E = Just 2- check (B _ l1 l2) (B _ r1 r2) = do- x <- check l1 l2- y <- check r1 r2- if (x == y) || (x == y + 1)- then return (x+y+1)- else fail "unbalanced tree"- check _ _ = fail "unbalanced tree"----- the remaining functions all use defaults--concat = concatUsingFoldr-reverseOnto = reverseOntoUsingReverse-concatMap = concatMapUsingFoldr-fold = foldrUsingLists-fold' f = foldl'UsingLists (flip f)-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'-foldr = foldrUsingLists-foldr' = foldr'UsingLists-foldl = foldlUsingLists-foldl' = foldl'UsingLists-foldr1 = foldr1UsingLists-foldr1' = foldr1'UsingLists-foldl1 = foldl1UsingLists-foldl1' = foldl1UsingLists-reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1 = reduce1UsingLists-reduce1' = reduce1'UsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-splitAt = splitAtDefault-subseq = subseqDefault-filter = filterUsingLists-partition = partitionUsingLists-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview----- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty---- instance Eq (Seq a) is derived--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = arbitrary >>= (return . fromList)--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary xs = coarbitrary (toList xs)--instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.BraunSeq +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- One-sided Braun sequences. All running times are as listed in +-- "Data.Edison.Seq" except the following: +-- +-- * lview, lcons, ltail* @O( log n )@ +-- +-- * rcons, rview, rhead*, rtail*, size @O( log^2 n )@ +-- +-- * copy, inBounds, lookup*, update, adjust @O( log i )@ +-- +-- * append @O( n1 log n2 )@ +-- +-- * concat @O( n + m log m )@ +-- +-- * drop, splitAt @O( i log n )@ +-- +-- * subseq @O( i log n + len )@ +-- +-- * reverseOnto @O( n1 log n2 )@ +-- +-- * concatMap, (>>=) @O( n * t + m log m )@, where @n@ is the length of the input sequence +-- @m@ is the length of the output sequence and @t@ +-- is the running time of @f@ +-- +-- By keeping track of the size, we could get rcons, rview, rhead*, and rtail* +-- down to @O(log n)@ as well; furthermore, size would be @O( 1 )@. +-- +-- /References:/ +-- +-- * Rob Hoogerwoord. \"A symmetric set of efficient list operations\". +-- /Journal of Functional Programming/, 2(4):505--513, 1992. +-- +-- * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\". +-- /Mathematics of Program Construction/ (MPC'92), pages 191-207. +-- +-- * Chris Okasaki. \"Three algorithms on Braun Trees\". +-- /Journal of Function Programming/ 7(6):661-666. Novemebr 1997. + +module Data.Edison.Seq.BraunSeq ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Data.Maybe +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + + +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Data.Edison.Seq.ListSeq as L + + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.BraunSeq" + + +data Seq a = E | B a (Seq a) (Seq a) deriving (Eq) + +half :: Int -> Int +half n = n `quot` 2 -- use a shift? + +empty = E +singleton x = B x E E + +lcons x E = singleton x +lcons x (B y a b) = B x (lcons y b) a + +rcons y ys = insAt (size ys) ys + where insAt 0 _ = singleton y + insAt i (B x a b) + | odd i = B x (insAt (half i) a) b + | otherwise = B x a (insAt (half i - 1) b) + insAt _ _ = error "BraunSeq.rcons: bug. Impossible case!" + +append xs E = xs +append xs ys = app (size xs) xs ys + where app 0 _ ys = ys + app _ xs E = xs + app n (B x a b) (B y c d) + | odd n = B x (app m a (lcons y d)) (app m b c) + | otherwise = B x (app m a c) (app (m-1) b (lcons y d)) + where m = half n + app _ _ _ = error "BraunSeq.append: bug!" + -- how does it compare to converting to/from lists? + +lview E = fail "BraunSeq.lview: empty sequence" +lview (B x a b) = return (x, combine a b) + +-- not exported +combine :: Seq a -> Seq a -> Seq a +combine E _ = E +combine (B x a b) c = B x c (combine a b) + +lhead E = error "BraunSeq.lhead: empty sequence" +lhead (B x _ _) = x + +lheadM E = fail "BraunSeq.lheadM: empty sequence" +lheadM (B x _ _) = return x + +ltail E = error "BraunSeq.ltail: empty sequence" +ltail (B _ a b) = combine a b + +ltailM E = fail "BraunSeq.ltailM: empty sequence" +ltailM (B _ a b) = return (combine a b) + +-- not exported +-- precondition: i >= 0 +delAt :: Int -> Seq a -> Seq a +delAt 0 _ = E +delAt i (B x a b) + | odd i = B x (delAt (half i) a) b + | otherwise = B x a (delAt (half i - 1) b) +delAt _ _ = error "BraunSeq.delAt: bug. Impossible case!" + +rview E = fail "BraunSeq.rview: empty sequence" +rview xs = return (lookup m xs, delAt m xs) + where m = size xs - 1 + +rhead E = error "BraunSeq.rhead: empty sequence" +rhead xs = lookup (size xs - 1) xs + +rheadM E = fail "BraunSeq.rheadM: empty sequence" +rheadM xs = return (lookup (size xs - 1) xs) + +rtail E = error "BraunSeq.rtail: empty sequence" +rtail xs = delAt (size xs - 1) xs + +rtailM E = fail "BraunSeq.rtailM: empty sequence" +rtailM xs = return (delAt (size xs - 1) xs) + +null E = True +null _ = False + +size E = 0 +size (B _ a b) = 1 + n + n + diff n a + where n = size b + + diff 0 E = 0 + diff 0 (B _ _ _) = 1 + diff i (B _ a b) + | odd i = diff (half i) a + | otherwise = diff (half i - 1) b + diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!" + +reverse xs = rev00 (size xs) xs + where + rev00 n xs + | n <= 1 = xs + rev00 n (B x a b) + | odd n = let a' = rev00 m a + (x',b') = rev11 m x b in B x' a' b' + | otherwise = let (x',a') = rev01 m a + b' = rev10 (m-1) x b in B x' b' a' + where m = half n + rev00 _ _ = error "BraunSeq.reverse: bug!" + + rev11 _ x E = (x,E) + rev11 n x (B y a b) + | odd n = let (x',a') = rev11 m x a + (y',b') = rev11 m y b in (y', B x' b' a') + | otherwise = let (x',a') = rev11 m x a + (y',b') = rev11 (m-1) y b in (x', B y' a' b') + where m = half n + + rev01 _ E = error "BraunSeq.reverse: bug!" + rev01 n (B x a b) + | n == 1 = (x, E) + | odd n = let (y',a') = rev01 m a + (x',b') = rev11 m x b in (x', B y' b' a') + | otherwise = let (y',a') = rev01 m a + (x',b') = rev11 (m-1) x b in (y', B x' a' b') + where m = half n + + rev10 _ x E = B x E E + rev10 n x (B y a b) + | odd n = let a' = rev10 m x a + (y',b') = rev11 m y b in B y' a' b' + | otherwise = let (x',a') = rev11 m x a + b' = rev10 (m-1) y b in B x' b' a' + where m = half n + +fromList = L.lhead . L.foldr build [E] . rows 1 + where rows _ [] = [] + rows k xs = (k, ys) : rows (k+k) zs + where (ys,zs) = L.splitAt k xs + + build (k,xs) ts = zipWithB xs ts1 ts2 + where (ts1, ts2) = L.splitAt k ts + + zipWithB [] _ _ = [] + zipWithB (x:xs) [] _ = singleton x : L.map singleton xs + zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts [] + zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2 + +toList E = [] +toList t = tol [t] + where tol [] = [] + tol ts = xs ++ tol (ts1 ++ ts2) + where xs = L.map root ts + (ts1,ts2) = children ts + + children [] = ([],[]) + children (B _ E _ : _) = ([],[]) + children (B _ a E : ts) = (a : leftChildren ts, []) + children (B _ a b : ts) = (a : ts1, b : ts2) + where (ts1, ts2) = children ts + children _ = error "BraunSeq.toList: bug!" + + leftChildren [] = [] + leftChildren (B _ E _ : _) = [] + leftChildren (B _ a _ : ts) = a : leftChildren ts + leftChildren _ = error "BraunSeq.toList: bug!" + + root (B x _ _) = x + root _ = error "BraunSeq.toList: bug!" + +map _ E = E +map f (B x a b) = B (f x) (map f a) (map f b) + +copy n x = if n <= 0 then empty else fst (copy2 n) + where copy2 n + | odd n = (B x a a, B x b a) + | n == 0 = (E, singleton x) + | otherwise = (B x b a, B x b b) + where (a, b) = copy2 (half (n-1)) + +inBounds i xs = (i >= 0) && inb xs i + where inb E _ = False + inb (B _ a b) i + | odd i = inb a (half i) + | i == 0 = True + | otherwise = inb b (half i - 1) + +lookup i xs = runFail_ (lookupM i xs) + +lookupM i xs + | i < 0 = fail "BraunSeq.lookupM: bad subscript" + | otherwise = look xs i + where look E _ = nothing + look (B x a b) i + | odd i = look a (half i) + | i == 0 = return x + | otherwise = look b (half i - 1) + nothing = fail "BraunSeq.lookupM: not found" + +lookupWithDefault d i xs = if i < 0 then d + else look xs i + where look E _ = d + look (B x a b) i + | odd i = look a (half i) + | i == 0 = x + | otherwise = look b (half i - 1) + +update i y xs = if i < 0 then xs else upd i xs + where upd _ E = E + upd i (B x a b) + | odd i = B x (upd (half i) a) b + | i == 0 = B y a b + | otherwise = B x a (upd (half i - 1) b) + +adjust f i xs = if i < 0 then xs else adj i xs + where adj _ E = E + adj i (B x a b) + | odd i = B x (adj (half i) a) b + | i == 0 = B (f x) a b + | otherwise = B x a (adj (half i - 1) b) + +mapWithIndex f xs = mwi 0 1 xs + where mwi _ _ E = E + mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b) + where dd = d+d + +take n xs = if n <= 0 then E else ta n xs + where ta _ E = E + ta n (B x a b) + | odd n = B x (ta m a) (ta m b) + | n == 0 = E + | otherwise = B x (ta m a) (ta (m-1) b) + where m = half n + +drop n xs = if n <= 0 then xs else dr n xs + where dr _ E = E + dr n t@(B _ a b) + | odd n = combine (dr m a) (dr m b) + | n == 0 = t + | otherwise = combine (dr (m-1) b) (dr m a) + where m = half n + +zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d) +zip _ _ = E + +zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f) +zip3 _ _ _ = E + +zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d) +zipWith _ _ _ = E + +zipWith3 fn (B x a b) (B y c d) (B z e f) = + B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f) +zipWith3 _ _ _ _ = E + +unzip E = (E, E) +unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2) + where (a1,a2) = unzip a + (b1,b2) = unzip b + +unzip3 E = (E, E, E) +unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3) + where (a1,a2,a3) = unzip3 a + (b1,b2,b3) = unzip3 b + +unzipWith _ _ E = (E, E) +unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2) + where (a1,a2) = unzipWith f g a + (b1,b2) = unzipWith f g b + +unzipWith3 _ _ _ E = (E, E, E) +unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3) + where (a1,a2,a3) = unzipWith3 f g h a + (b1,b2,b3) = unzipWith3 f g h b + + +strict s@E = s +strict s@(B _ l r) = strict l `seq` strict r `seq` s + +strictWith _ s@E = s +strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s + +-- invariants: +-- * Left subtree is exactily the same size as the right +-- subtree, or one element larger + +-- structuralInvariant :: Seq a -> Bool +structuralInvariant E = True +structuralInvariant (B _ l r) = isJust (check l r) + + where check :: Seq a -> Seq a -> Maybe Int + check E E = Just 1 + check (B _ E E) E = Just 2 + check (B _ l1 l2) (B _ r1 r2) = do + x <- check l1 l2 + y <- check r1 r2 + if (x == y) || (x == y + 1) + then return (x+y+1) + else fail "unbalanced tree" + check _ _ = fail "unbalanced tree" + + +-- the remaining functions all use defaults + +concat = concatUsingFoldr +reverseOnto = reverseOntoUsingReverse +concatMap = concatMapUsingFoldr +fold = foldrUsingLists +fold' f = foldl'UsingLists (flip f) +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' +foldr = foldrUsingLists +foldr' = foldr'UsingLists +foldl = foldlUsingLists +foldl' = foldl'UsingLists +foldr1 = foldr1UsingLists +foldr1' = foldr1'UsingLists +foldl1 = foldl1UsingLists +foldl1' = foldl1UsingLists +reducer = reducerUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel = reducelUsingReduce1 +reducel' = reducel'UsingReduce1' +reduce1 = reduce1UsingLists +reduce1' = reduce1'UsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists +splitAt = splitAtDefault +subseq = subseqDefault +filter = filterUsingLists +partition = partitionUsingLists +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview + + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +-- instance Eq (Seq a) is derived + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = arbitrary >>= (return . fromList) + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary xs = coarbitrary (toList xs) + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/Defaults.hs view
@@ -1,512 +1,516 @@--- |--- Module : Data.Edison.Seq.Defaults--- Copyright : Copyright (c) 1998, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : internal (unstable)--- Portability : GHC, Hugs (MPTC and FD)------ This module provides default implementations of many of--- the sequence operations. It is used to fill in implementations--- and is not intended for end users.--module Data.Edison.Seq.Defaults where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import Control.Monad.Identity-import Data.Char (isSpace)--import Data.Edison.Seq-import qualified Data.Edison.Seq.ListSeq as L--rconsUsingAppend :: Sequence s => a -> s a -> s a-rconsUsingAppend x s = append s (singleton x)--rconsUsingFoldr :: Sequence s => a -> s a -> s a-rconsUsingFoldr x s = foldr lcons (singleton x) s--appendUsingFoldr :: Sequence s => s a -> s a -> s a-appendUsingFoldr s t | null t = s- | otherwise = foldr lcons t s--rviewDefault :: (Monad m, Sequence s) => s a -> m (a, s a)-rviewDefault xs- | null xs = fail $ instanceName xs ++ ".rview: empty sequence"- | otherwise = return (rhead xs, rtail xs)---rtailUsingLview :: (Sequence s) => s a -> s a-rtailUsingLview xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".rtail: empty sequence"- Just (x, xs) -> rt x xs- where rt x xs =- case lview xs of- Nothing -> empty- Just (y, ys) -> lcons x (rt y ys)--rtailMUsingLview :: (Monad m,Sequence s) => s a -> m (s a)-rtailMUsingLview xs =- case lview xs of- Nothing -> fail $ instanceName xs ++ ".rtailM: empty sequence"- Just (x, xs) -> return (rt x xs)- where rt x xs =- case lview xs of- Nothing -> empty- Just (y, ys) -> lcons x (rt y ys)----concatUsingFoldr :: Sequence s => s (s a) -> s a-concatUsingFoldr = foldr append empty--reverseUsingReverseOnto :: Sequence s => s a -> s a-reverseUsingReverseOnto s = reverseOnto s empty--reverseUsingLists :: Sequence s => s a -> s a-reverseUsingLists = fromList . L.reverse . toList--reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a-reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs--reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a-reverseOntoUsingReverse = append . reverse--fromListUsingCons :: Sequence s => [a] -> s a-fromListUsingCons = L.foldr lcons empty--toListUsingFoldr :: Sequence s => s a -> [a]-toListUsingFoldr = foldr (:) []--mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b-mapUsingFoldr f = foldr (lcons . f) empty--concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b-concatMapUsingFoldr f = foldr (append . f) empty--foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b-foldrUsingLists f e xs = L.foldr f e (toList xs)--foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b-foldr'UsingLists f e xs = L.foldr' f e (toList xs)--foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b-foldlUsingLists f e xs = L.foldl f e (toList xs)--foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b-foldl'UsingLists f e xs = L.foldl' f e (toList xs)--foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldr1UsingLists f xs = L.foldr1 f (toList xs)--foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldr1'UsingLists f xs = L.foldr1' f (toList xs)--foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldl1UsingLists f xs = L.foldl1 f (toList xs)--foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-foldl1'UsingLists f xs = L.foldl1' f (toList xs)--fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a-fold1UsingFold f xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".fold1: empty sequence"- Just (x, xs) -> fold f x xs--fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a-fold1'UsingFold' f xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".fold1': empty sequence"- Just (x, xs) -> fold' f x xs--foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a-foldr1UsingLview f xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".foldr1: empty sequence"- Just (x, xs) -> fr1 x xs- where fr1 x xs =- case lview xs of- Nothing -> x- Just (y,ys) -> f x (fr1 y ys)--foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a-foldr1'UsingLview f xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".foldr1': empty sequence"- Just (x,xs) -> fr1 x xs- where fr1 x xs =- case lview xs of- Nothing -> x- Just (y,ys) -> f x $! (fr1 y ys)--foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a-foldl1UsingFoldl f xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".foldl1: empty sequence"- Just (x,xs) -> foldl f x xs--foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a-foldl1'UsingFoldl' f xs =- case lview xs of- Nothing -> error $ instanceName xs ++ ".foldl1': empty sequence"- Just (x,xs) -> foldl' f x xs--reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducerUsingReduce1 f e s- | null s = e- | otherwise = f (reduce1 f s) e--reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducer'UsingReduce1' f e s- | null s = e- | otherwise = f (reduce1' f s) e--reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducelUsingReduce1 f e s- | null s = e- | otherwise = f e (reduce1 f s)--reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a-reducel'UsingReduce1' f e s- | null s = e- | otherwise = f e (reduce1' f s)--reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-reduce1UsingLists f s = L.reduce1 f (toList s)--reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a-reduce1'UsingLists f s = L.reduce1' f (toList s)--copyUsingLists :: Sequence s => Int -> a -> s a-copyUsingLists n x = fromList (L.copy n x)---inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool-inBoundsUsingDrop i s =- i >= 0 && not (null (drop i s))--inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool-inBoundsUsingLookupM i s =- case lookupM i s of- Just _ -> True- Nothing -> False--inBoundsUsingSize :: Sequence s => Int -> s a -> Bool-inBoundsUsingSize i s = i >= 0 && i < size s--lookupUsingLookupM :: Sequence s => Int -> s a -> a-lookupUsingLookupM i s = runIdentity (lookupM i s)--lookupUsingDrop :: Sequence s => Int -> s a -> a-lookupUsingDrop i s- | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript"- | otherwise = lhead s'- where s' = drop i s--lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a-lookupWithDefaultUsingLookupM d i s =- case lookupM i s of- Nothing -> d- Just x -> x--lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a-lookupWithDefaultUsingDrop d i s- | i < 0 || null s' = d- | otherwise = lhead s'- where s' = drop i s--lookupMUsingDrop :: (Monad m, Sequence s) => Int -> s a -> m a-lookupMUsingDrop i s- -- XXX better error message!- | i < 0 || null s' = fail $ instanceName s- ++ ".lookupMUsingDrop: empty sequence"- | otherwise = return (lhead s')- where s' = drop i s--filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a-filterUsingLview p xs =- case lview xs of- Nothing -> empty- Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs--filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a-filterUsingLists p xs =- fromList (L.filter p (toList xs))--filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a-filterUsingFoldr p = foldr pcons empty- where pcons x xs = if p x then lcons x xs else xs--partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a)-partitionUsingLists p xs =- let (ys,zs) = L.partition p (toList xs)- in (fromList ys, fromList zs)--partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a)-partitionUsingFoldr p = foldr pcons (empty, empty)- where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs')--updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a-updateUsingAdjust i y = adjust (const y) i--updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a-updateUsingSplitAt i x xs- | i < 0 = xs- | otherwise = let (ys,zs) = splitAt i xs- in if null zs then xs else append ys (lcons x (ltail zs))--adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a-adjustUsingLists f i xs = fromList (L.adjust f i (toList xs))--adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a-adjustUsingSplitAt f i xs- | i < 0 = xs- | otherwise = let (ys,zs) = splitAt i xs- in case lview zs of- Nothing -> xs- Just (z,zs') -> append ys (lcons (f z) zs')--{--insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a-insertAtUsingLists i x xs =- fromList (L.insertAt i x (toList xs))--insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a-insertAtUsingSplitAt i x xs- | (xs_before, xs_after) <- splitAt i xs =- append xs_before (lcons x xs_after)--deleteAtUsingLists :: Sequence s => Int -> s a -> s a-deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs))--deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a-deleteAtUsingSplitAt i xs- | (xs_before, xs_after) <- splitAt i xs =- append xs_before (ltail xs_after)--}--mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b-mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs))--foldrWithIndexUsingLists ::- Sequence s => (Int -> a -> b -> b) -> b -> s a -> b-foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs)--foldrWithIndex'UsingLists ::- Sequence s => (Int -> a -> b -> b) -> b -> s a -> b-foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs)--foldlWithIndexUsingLists ::- Sequence s => (b -> Int -> a -> b) -> b -> s a -> b-foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs)--foldlWithIndex'UsingLists ::- Sequence s => (b -> Int -> a -> b) -> b -> s a -> b-foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs)--takeUsingLists :: Sequence s => Int -> s a -> s a-takeUsingLists i s = fromList (L.take i (toList s))--takeUsingLview :: Sequence s => Int -> s a -> s a-takeUsingLview i xs- | i <= 0 = empty- | otherwise = case lview xs of- Nothing -> empty- Just (x,xs') -> lcons x (take (i-1) xs')--dropUsingLists :: Sequence s => Int -> s a -> s a-dropUsingLists i s = fromList (L.drop i (toList s))--dropUsingLtail :: Sequence s => Int -> s a -> s a-dropUsingLtail i xs- | i <= 0 || null xs = xs- | otherwise = dropUsingLtail (i-1) (ltail xs)--splitAtDefault :: Sequence s => Int -> s a -> (s a, s a)-splitAtDefault i s = (take i s, drop i s)--splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a)-splitAtUsingLview i xs- | i <= 0 = (empty,xs)- | otherwise = case lview xs of- Nothing -> (empty,empty)- Just (x,xs') -> (lcons x ys,zs)- where (ys,zs) = splitAtUsingLview (i-1) xs'--subseqDefault :: Sequence s => Int -> Int -> s a -> s a-subseqDefault i len xs = take len (drop i xs)--takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a-takeWhileUsingLview p xs =- case lview xs of- Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs')- _ -> empty--dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a-dropWhileUsingLview p xs =- case lview xs of- Just (x,xs') | p x -> dropWhileUsingLview p xs'- _ -> xs--splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a)-splitWhileUsingLview p xs =- case lview xs of- Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs'- in (lcons x front, back)- _ -> (empty, xs)--zipUsingLview :: Sequence s => s a -> s b -> s (a,b)-zipUsingLview xs ys =- case lview xs of- Nothing -> empty- Just (x,xs') ->- case lview ys of- Nothing -> empty- Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys')--zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c)-zip3UsingLview xs ys zs =- case lview xs of- Nothing -> empty- Just (x,xs') ->- case lview ys of- Nothing -> empty- Just (y,ys') ->- case lview zs of- Nothing -> empty- Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs')--zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c-zipWithUsingLview f xs ys =- case lview xs of- Nothing -> empty- Just (x,xs') ->- case lview ys of- Nothing -> empty- Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys')--zipWith3UsingLview ::- Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d-zipWith3UsingLview f xs ys zs =- case lview xs of- Nothing -> empty- Just (x,xs') ->- case lview ys of- Nothing -> empty- Just (y,ys') ->- case lview zs of- Nothing -> empty- Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs')--zipUsingLists :: Sequence s => s a -> s b -> s (a,b)-zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys))--zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c)-zip3UsingLists xs ys zs =- fromList (L.zip3 (toList xs) (toList ys) (toList zs))--zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c-zipWithUsingLists f xs ys =- fromList (L.zipWith f (toList xs) (toList ys))--zipWith3UsingLists ::- Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d-zipWith3UsingLists f xs ys zs =- fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs))--unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b)-unzipUsingLists xys =- case L.unzip (toList xys) of- (xs, ys) -> (fromList xs, fromList ys)--unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b)-unzipUsingFoldr = foldr pcons (empty,empty)- where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys)--unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c)-unzip3UsingLists xyzs =- case L.unzip3 (toList xyzs) of- (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)--unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c)-unzip3UsingFoldr = foldr tcons (empty,empty,empty)- where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs)--unzipWithUsingLists ::- Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)-unzipWithUsingLists f g xys =- case L.unzipWith f g (toList xys) of- (xs, ys) -> (fromList xs, fromList ys)--unzipWithUsingFoldr ::- Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c)-unzipWithUsingFoldr f g = foldr pcons (empty,empty)- where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys)--unzipWith3UsingLists ::- Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)-unzipWith3UsingLists f g h xyzs =- case L.unzipWith3 f g h (toList xyzs) of- (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs)--unzipWith3UsingFoldr ::- Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d)-unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty)- where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs)--showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS-showsPrecUsingToList i xs rest- | i == 0 = concat [ instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest- | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest)--readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a)-readsPrecUsingFromList _ xs =- let result = maybeParens p xs- p xs = tokenMatch ((instanceName x)++".fromList") xs- >>= readsPrec 10- >>= \(l,rest) -> return (fromList l,rest)-- -- play games with the typechecker so we don't have to use- -- extensions for scoped type variables- ~[(x,_)] = result-- in result--defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering-defaultCompare a b =- case (lview a, lview b) of- (Nothing, Nothing) -> EQ- (Nothing, _ ) -> LT- (_ , Nothing) -> GT- (Just (x,xs), Just (y,ys)) ->- case compare x y of- EQ -> defaultCompare xs ys- c -> c---dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a]-dropMatch [] ys = return ys-dropMatch (x:xs) (y:ys)- | x == y = dropMatch xs ys- | otherwise = mzero-dropMatch _ _ = mzero--tokenMatch :: MonadPlus m => String -> String -> m String-tokenMatch token str = dropMatch token (munch str) >>= return . munch- where munch = dropWhile isSpace--readSParens :: ReadS a -> ReadS a-readSParens p xs = return xs- >>= tokenMatch "("- >>= p- >>= \(x,xs') -> return xs'- >>= tokenMatch ")"- >>= \rest -> return (x,rest)--maybeParens :: ReadS a -> ReadS a-maybeParens p xs = readSParens p xs `mplus` p xs+-- | +-- Module : Data.Edison.Seq.Defaults +-- Copyright : Copyright (c) 1998, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : internal (unstable) +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module provides default implementations of many of +-- the sequence operations. It is used to fill in implementations +-- and is not intended for end users. + +module Data.Edison.Seq.Defaults where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Data.Char (isSpace) + +import Data.Edison.Prelude ( runFail_ ) +import Data.Edison.Seq +import qualified Data.Edison.Seq.ListSeq as L + +rconsUsingAppend :: Sequence s => a -> s a -> s a +rconsUsingAppend x s = append s (singleton x) + +rconsUsingFoldr :: Sequence s => a -> s a -> s a +rconsUsingFoldr x s = foldr lcons (singleton x) s + +appendUsingFoldr :: Sequence s => s a -> s a -> s a +appendUsingFoldr s t | null t = s + | otherwise = foldr lcons t s + +rviewDefault :: (Fail.MonadFail m, Sequence s) => s a -> m (a, s a) +rviewDefault xs + | null xs = fail $ instanceName xs ++ ".rview: empty sequence" + | otherwise = return (rhead xs, rtail xs) + + +rtailUsingLview :: (Sequence s) => s a -> s a +rtailUsingLview xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".rtail: empty sequence" + Just (x, xs) -> rt x xs + where rt x xs = + case lview xs of + Nothing -> empty + Just (y, ys) -> lcons x (rt y ys) + +rtailMUsingLview :: (Fail.MonadFail m, Sequence s) => s a -> m (s a) +rtailMUsingLview xs = + case lview xs of + Nothing -> fail $ instanceName xs ++ ".rtailM: empty sequence" + Just (x, xs) -> return (rt x xs) + where rt x xs = + case lview xs of + Nothing -> empty + Just (y, ys) -> lcons x (rt y ys) + + + +concatUsingFoldr :: Sequence s => s (s a) -> s a +concatUsingFoldr = foldr append empty + +reverseUsingReverseOnto :: Sequence s => s a -> s a +reverseUsingReverseOnto s = reverseOnto s empty + +reverseUsingLists :: Sequence s => s a -> s a +reverseUsingLists = fromList . L.reverse . toList + +reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a +reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs + +reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a +reverseOntoUsingReverse = append . reverse + +fromListUsingCons :: Sequence s => [a] -> s a +fromListUsingCons = L.foldr lcons empty + +toListUsingFoldr :: Sequence s => s a -> [a] +toListUsingFoldr = foldr (:) [] + +mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b +mapUsingFoldr f = foldr (lcons . f) empty + +concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b +concatMapUsingFoldr f = foldr (append . f) empty + +foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b +foldrUsingLists f e xs = L.foldr f e (toList xs) + +foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b +foldr'UsingLists f e xs = L.foldr' f e (toList xs) + +foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b +foldlUsingLists f e xs = L.foldl f e (toList xs) + +foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b +foldl'UsingLists f e xs = L.foldl' f e (toList xs) + +foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a +foldr1UsingLists f xs = L.foldr1 f (toList xs) + +foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a +foldr1'UsingLists f xs = L.foldr1' f (toList xs) + +foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a +foldl1UsingLists f xs = L.foldl1 f (toList xs) + +foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a +foldl1'UsingLists f xs = L.foldl1' f (toList xs) + +fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a +fold1UsingFold f xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".fold1: empty sequence" + Just (x, xs) -> fold f x xs + +fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a +fold1'UsingFold' f xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".fold1': empty sequence" + Just (x, xs) -> fold' f x xs + +foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a +foldr1UsingLview f xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".foldr1: empty sequence" + Just (x, xs) -> fr1 x xs + where fr1 x xs = + case lview xs of + Nothing -> x + Just (y,ys) -> f x (fr1 y ys) + +foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a +foldr1'UsingLview f xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".foldr1': empty sequence" + Just (x,xs) -> fr1 x xs + where fr1 x xs = + case lview xs of + Nothing -> x + Just (y,ys) -> f x $! (fr1 y ys) + +foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a +foldl1UsingFoldl f xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".foldl1: empty sequence" + Just (x,xs) -> foldl f x xs + +foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a +foldl1'UsingFoldl' f xs = + case lview xs of + Nothing -> error $ instanceName xs ++ ".foldl1': empty sequence" + Just (x,xs) -> foldl' f x xs + +reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a +reducerUsingReduce1 f e s + | null s = e + | otherwise = f (reduce1 f s) e + +reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a +reducer'UsingReduce1' f e s + | null s = e + | otherwise = f (reduce1' f s) e + +reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a +reducelUsingReduce1 f e s + | null s = e + | otherwise = f e (reduce1 f s) + +reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a +reducel'UsingReduce1' f e s + | null s = e + | otherwise = f e (reduce1' f s) + +reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a +reduce1UsingLists f s = L.reduce1 f (toList s) + +reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a +reduce1'UsingLists f s = L.reduce1' f (toList s) + +copyUsingLists :: Sequence s => Int -> a -> s a +copyUsingLists n x = fromList (L.copy n x) + + +inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool +inBoundsUsingDrop i s = + i >= 0 && not (null (drop i s)) + +inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool +inBoundsUsingLookupM i s = + case lookupM i s of + Just _ -> True + Nothing -> False + +inBoundsUsingSize :: Sequence s => Int -> s a -> Bool +inBoundsUsingSize i s = i >= 0 && i < size s + +lookupUsingLookupM :: Sequence s => Int -> s a -> a +lookupUsingLookupM i s = runFail_ (lookupM i s) + +lookupUsingDrop :: Sequence s => Int -> s a -> a +lookupUsingDrop i s + | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript" + | otherwise = lhead s' + where s' = drop i s + +lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a +lookupWithDefaultUsingLookupM d i s = + case lookupM i s of + Nothing -> d + Just x -> x + +lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a +lookupWithDefaultUsingDrop d i s + | i < 0 || null s' = d + | otherwise = lhead s' + where s' = drop i s + +lookupMUsingDrop :: (Fail.MonadFail m, Sequence s) => Int -> s a -> m a +lookupMUsingDrop i s + -- XXX better error message! + | i < 0 || null s' = fail $ instanceName s + ++ ".lookupMUsingDrop: empty sequence" + | otherwise = return (lhead s') + where s' = drop i s + +filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a +filterUsingLview p xs = + case lview xs of + Nothing -> empty + Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs + +filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a +filterUsingLists p xs = + fromList (L.filter p (toList xs)) + +filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a +filterUsingFoldr p = foldr pcons empty + where pcons x xs = if p x then lcons x xs else xs + +partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a) +partitionUsingLists p xs = + let (ys,zs) = L.partition p (toList xs) + in (fromList ys, fromList zs) + +partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a) +partitionUsingFoldr p = foldr pcons (empty, empty) + where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs') + +updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a +updateUsingAdjust i y = adjust (const y) i + +updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a +updateUsingSplitAt i x xs + | i < 0 = xs + | otherwise = let (ys,zs) = splitAt i xs + in if null zs then xs else append ys (lcons x (ltail zs)) + +adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a +adjustUsingLists f i xs = fromList (L.adjust f i (toList xs)) + +adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a +adjustUsingSplitAt f i xs + | i < 0 = xs + | otherwise = let (ys,zs) = splitAt i xs + in case lview zs of + Nothing -> xs + Just (z,zs') -> append ys (lcons (f z) zs') + +{- +insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a +insertAtUsingLists i x xs = + fromList (L.insertAt i x (toList xs)) + +insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a +insertAtUsingSplitAt i x xs + | (xs_before, xs_after) <- splitAt i xs = + append xs_before (lcons x xs_after) + +deleteAtUsingLists :: Sequence s => Int -> s a -> s a +deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs)) + +deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a +deleteAtUsingSplitAt i xs + | (xs_before, xs_after) <- splitAt i xs = + append xs_before (ltail xs_after) +-} + +mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b +mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs)) + +foldrWithIndexUsingLists :: + Sequence s => (Int -> a -> b -> b) -> b -> s a -> b +foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs) + +foldrWithIndex'UsingLists :: + Sequence s => (Int -> a -> b -> b) -> b -> s a -> b +foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs) + +foldlWithIndexUsingLists :: + Sequence s => (b -> Int -> a -> b) -> b -> s a -> b +foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs) + +foldlWithIndex'UsingLists :: + Sequence s => (b -> Int -> a -> b) -> b -> s a -> b +foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs) + +takeUsingLists :: Sequence s => Int -> s a -> s a +takeUsingLists i s = fromList (L.take i (toList s)) + +takeUsingLview :: Sequence s => Int -> s a -> s a +takeUsingLview i xs + | i <= 0 = empty + | otherwise = case lview xs of + Nothing -> empty + Just (x,xs') -> lcons x (take (i-1) xs') + +dropUsingLists :: Sequence s => Int -> s a -> s a +dropUsingLists i s = fromList (L.drop i (toList s)) + +dropUsingLtail :: Sequence s => Int -> s a -> s a +dropUsingLtail i xs + | i <= 0 || null xs = xs + | otherwise = dropUsingLtail (i-1) (ltail xs) + +splitAtDefault :: Sequence s => Int -> s a -> (s a, s a) +splitAtDefault i s = (take i s, drop i s) + +splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a) +splitAtUsingLview i xs + | i <= 0 = (empty,xs) + | otherwise = case lview xs of + Nothing -> (empty,empty) + Just (x,xs') -> (lcons x ys,zs) + where (ys,zs) = splitAtUsingLview (i-1) xs' + +subseqDefault :: Sequence s => Int -> Int -> s a -> s a +subseqDefault i len xs = take len (drop i xs) + +takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a +takeWhileUsingLview p xs = + case lview xs of + Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs') + _ -> empty + +dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a +dropWhileUsingLview p xs = + case lview xs of + Just (x,xs') | p x -> dropWhileUsingLview p xs' + _ -> xs + +splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a) +splitWhileUsingLview p xs = + case lview xs of + Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs' + in (lcons x front, back) + _ -> (empty, xs) + +zipUsingLview :: Sequence s => s a -> s b -> s (a,b) +zipUsingLview xs ys = + case lview xs of + Nothing -> empty + Just (x,xs') -> + case lview ys of + Nothing -> empty + Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys') + +zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c) +zip3UsingLview xs ys zs = + case lview xs of + Nothing -> empty + Just (x,xs') -> + case lview ys of + Nothing -> empty + Just (y,ys') -> + case lview zs of + Nothing -> empty + Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs') + +zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c +zipWithUsingLview f xs ys = + case lview xs of + Nothing -> empty + Just (x,xs') -> + case lview ys of + Nothing -> empty + Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys') + +zipWith3UsingLview :: + Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d +zipWith3UsingLview f xs ys zs = + case lview xs of + Nothing -> empty + Just (x,xs') -> + case lview ys of + Nothing -> empty + Just (y,ys') -> + case lview zs of + Nothing -> empty + Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs') + +zipUsingLists :: Sequence s => s a -> s b -> s (a,b) +zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys)) + +zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c) +zip3UsingLists xs ys zs = + fromList (L.zip3 (toList xs) (toList ys) (toList zs)) + +zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c +zipWithUsingLists f xs ys = + fromList (L.zipWith f (toList xs) (toList ys)) + +zipWith3UsingLists :: + Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d +zipWith3UsingLists f xs ys zs = + fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs)) + +unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b) +unzipUsingLists xys = + case L.unzip (toList xys) of + (xs, ys) -> (fromList xs, fromList ys) + +unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b) +unzipUsingFoldr = foldr pcons (empty,empty) + where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys) + +unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c) +unzip3UsingLists xyzs = + case L.unzip3 (toList xyzs) of + (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs) + +unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c) +unzip3UsingFoldr = foldr tcons (empty,empty,empty) + where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs) + +unzipWithUsingLists :: + Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c) +unzipWithUsingLists f g xys = + case L.unzipWith f g (toList xys) of + (xs, ys) -> (fromList xs, fromList ys) + +unzipWithUsingFoldr :: + Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c) +unzipWithUsingFoldr f g = foldr pcons (empty,empty) + where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys) + +unzipWith3UsingLists :: + Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d) +unzipWith3UsingLists f g h xyzs = + case L.unzipWith3 f g h (toList xyzs) of + (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs) + +unzipWith3UsingFoldr :: + Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d) +unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty) + where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs) + +showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS +showsPrecUsingToList i xs rest + | i == 0 = concat [ instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest + | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest) + +readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a) +readsPrecUsingFromList _ xs = + let result = maybeParens p xs + p xs = tokenMatch ((instanceName x)++".fromList") xs + >>= readsPrec 10 + >>= \(l,rest) -> return (fromList l,rest) + + -- play games with the typechecker so we don't have to use + -- extensions for scoped type variables + x = case result of + [(x',_)] -> x' + _ -> undefined + + in result + +defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering +defaultCompare a b = + case (lview a, lview b) of + (Nothing, Nothing) -> EQ + (Nothing, _ ) -> LT + (_ , Nothing) -> GT + (Just (x,xs), Just (y,ys)) -> + case compare x y of + EQ -> defaultCompare xs ys + c -> c + + +dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a] +dropMatch [] ys = return ys +dropMatch (x:xs) (y:ys) + | x == y = dropMatch xs ys + | otherwise = mzero +dropMatch _ _ = mzero + +tokenMatch :: MonadPlus m => String -> String -> m String +tokenMatch token str = dropMatch token (munch str) >>= return . munch + where munch = dropWhile isSpace + +readSParens :: ReadS a -> ReadS a +readSParens p xs = return xs + >>= tokenMatch "(" + >>= p + >>= \(x,xs') -> return xs' + >>= tokenMatch ")" + >>= \rest -> return (x,rest) + +maybeParens :: ReadS a -> ReadS a +maybeParens p xs = readSParens p xs `mplus` p xs
src/Data/Edison/Seq/FingerSeq.hs view
@@ -1,385 +1,402 @@--- |--- Module : Data.Edison.Seq.FingerSeq--- Copyright : Copyright (c) 2006, 2008 Robert Dockins--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)---module Data.Edison.Seq.FingerSeq (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldlWithIndex,- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import qualified Prelude-import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import Data.Edison.Prelude (measure, Measured())-import qualified Data.Edison.Seq as S-import Data.Edison.Seq.Defaults-import Control.Monad.Identity-import Data.Monoid-import Test.QuickCheck--#ifdef __GLASGOW_HASKELL__-import GHC.Base (unsafeCoerce#)-#endif---import qualified Data.Edison.Concrete.FingerTree as FT--moduleName :: String-moduleName = "Data.Edison.Seq.FingerSeq"---newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show)--unSizeM :: SizeM -> Int-unSizeM (SizeM x) = x--instance Monoid SizeM where- mempty = 0- mappend = (+)---newtype Elem a = Elem a--unElem :: Elem t -> t-unElem (Elem x) = x--instance Measured SizeM (Elem a) where- measure _ = 1--newtype Seq a = Seq (FT.FingerTree SizeM (Elem a))--unSeq :: Seq t -> FT.FingerTree SizeM (Elem t)-unSeq (Seq ft) = ft----empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--#ifdef __GLASGOW_HASKELL__--mapElem, mapUnElem :: t -> b-mapElem = unsafeCoerce#-mapUnElem = unsafeCoerce#--#else--mapElem = Prelude.map Elem-mapUnElem = Prelude.map unElem--#endif--null = FT.null . unSeq-empty = Seq FT.empty-singleton = Seq . FT.singleton . Elem-lcons x = Seq . FT.lcons (Elem x) . unSeq-rcons x = Seq . FT.rcons (Elem x) . unSeq-append p q = Seq $ FT.append (unSeq p) (unSeq q)-fromList = Seq . FT.fromList . mapElem-toList = mapUnElem . FT.toList . unSeq-reverse = Seq . FT.reverse . unSeq-size = unSizeM . measure . unSeq-strict = Seq . FT.strict . unSeq-strictWith f = Seq . FT.strictWith (f . unElem) . unSeq-structuralInvariant = FT.structuralInvariant . unSeq--#ifdef __GLASGOW_HASKELL__--lview (Seq xs) =- let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)- in f (FT.lview xs)--rview (Seq xs) =- let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)- in f (FT.rview xs)--#else--lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs)-rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs)--#endif---lheadM xs = lview xs >>= return . fst-ltailM xs = lview xs >>= return . snd-rheadM xs = rview xs >>= return . fst-rtailM xs = rview xs >>= return . snd-lhead = runIdentity . lheadM-ltail = runIdentity . ltailM-rhead = runIdentity . rheadM-rtail = runIdentity . rtailM--fold = foldr-fold' = foldr'-fold1 = foldr1-fold1' = foldr1'--#ifdef __GLASGOW_HASKELL__--foldr f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)-foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)--reduce1 f (Seq xs) = unElem $ FT.reduce1 (unsafeCoerce# f) xs-reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs--map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs--#else--foldr f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)-foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)--reduce1 f (Seq xs) = unElem $ FT.reduce1 ( \(Elem x) (Elem y) -> Elem $ f x y) xs-reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs--map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs--#endif--lookupM i (Seq xs)- | inBounds i (Seq xs) =- case FT.splitTree (> (SizeM i)) (SizeM 0) xs of- FT.Split _ (Elem x) _ -> return x-- | otherwise = fail "FingerSeq.lookupM: index out of bounds"--lookupWithDefault d i (Seq xs)- | inBounds i (Seq xs) =- case FT.splitTree (> (SizeM i)) (SizeM 0) xs of- FT.Split _ (Elem x) _ -> x-- | otherwise = d--update i x (Seq xs)- | inBounds i (Seq xs) =- case FT.splitTree (> (SizeM i)) (SizeM 0) xs of- FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r-- | otherwise = Seq xs--adjust f i (Seq xs)- | inBounds i (Seq xs) =- case FT.splitTree (> (SizeM i)) (SizeM 0) xs of- FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r-- | otherwise = Seq xs--take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs-drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs-splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b)---inBounds = inBoundsUsingSize-lookup = lookupUsingLookupM--foldr1 f xs =- case rview xs of- Nothing -> error "FingerSeq.foldr1: empty sequence"- Just (x,xs') -> foldr f x xs'--foldr1' f xs =- case rview xs of- Nothing -> error "FingerSeq.foldr1': empty sequence"- Just (x,xs') -> foldr' f x xs'--foldl = foldlUsingLists-foldl' = foldl'UsingLists-foldl1 = foldl1UsingLists-foldl1' = foldl1'UsingLists--reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'--copy = copyUsingLists-concat = concatUsingFoldr-reverseOnto = reverseOntoUsingReverse-concatMap = concatMapUsingFoldr-subseq = subseqDefault-filter = filterUsingLview-partition = partitionUsingFoldr-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview--mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists--zip = zipUsingLview-zip3 = zip3UsingLview-zipWith = zipWithUsingLview-zipWith3 = zipWith3UsingLview--unzip = unzipUsingFoldr-unzip3 = unzip3UsingFoldr-unzipWith = unzipWithUsingFoldr-unzipWith3 = unzipWith3UsingFoldr---- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;- foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty--instance Eq a => Eq (Seq a) where- xs == ys = toList xs == toList ys--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Elem a) where- arbitrary = arbitrary >>= return . Elem--instance CoArbitrary a => CoArbitrary (Elem a) where- coarbitrary = coarbitrary . unElem--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = arbitrary >>= return . Seq--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary = coarbitrary . unSeq--instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.FingerSeq +-- Copyright : Copyright (c) 2006, 2008 Robert Dockins +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) + + +module Data.Edison.Seq.FingerSeq ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldlWithIndex, + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import qualified Prelude +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App +import Data.Edison.Prelude (measure, Measured(), runFail_) +import qualified Data.Edison.Seq as S +import Data.Edison.Seq.Defaults +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts (unsafeCoerce#) +#endif + + +import qualified Data.Edison.Concrete.FingerTree as FT + +moduleName :: String +moduleName = "Data.Edison.Seq.FingerSeq" + + +newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show) + +unSizeM :: SizeM -> Int +unSizeM (SizeM x) = x + +instance Semigroup SizeM where + (<>) = (+) +instance Monoid SizeM where + mempty = 0 + mappend = (SG.<>) + +newtype Elem a = Elem a + +unElem :: Elem t -> t +unElem (Elem x) = x + +instance Measured SizeM (Elem a) where + measure _ = 1 + +newtype Seq a = Seq (FT.FingerTree SizeM (Elem a)) + +unSeq :: Seq t -> FT.FingerTree SizeM (Elem t) +unSeq (Seq ft) = ft + + + +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +#ifdef __GLASGOW_HASKELL__ + +mapElem, mapUnElem :: t -> b +mapElem = unsafeCoerce# +mapUnElem = unsafeCoerce# + +#else + +mapElem = Prelude.map Elem +mapUnElem = Prelude.map unElem + +#endif + +null = FT.null . unSeq +empty = Seq FT.empty +singleton = Seq . FT.singleton . Elem +lcons x = Seq . FT.lcons (Elem x) . unSeq +rcons x = Seq . FT.rcons (Elem x) . unSeq +append p q = Seq $ FT.append (unSeq p) (unSeq q) +fromList = Seq . FT.fromList . mapElem +toList = mapUnElem . FT.toList . unSeq +reverse = Seq . FT.reverse . unSeq +size = unSizeM . measure . unSeq +strict = Seq . FT.strict . unSeq +strictWith f = Seq . FT.strictWith (f . unElem) . unSeq +structuralInvariant = FT.structuralInvariant . unSeq + +#ifdef __GLASGOW_HASKELL__ + +lview (Seq xs) = + let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a) + in f (FT.lview xs) + +rview (Seq xs) = + let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a) + in f (FT.rview xs) + +#else + +lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs) +rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs) + +#endif + + +lheadM xs = lview xs >>= return . fst +ltailM xs = lview xs >>= return . snd +rheadM xs = rview xs >>= return . fst +rtailM xs = rview xs >>= return . snd +lhead = runFail_ . lheadM +ltail = runFail_ . ltailM +rhead = runFail_ . rheadM +rtail = runFail_ . rtailM + +fold = foldr +fold' = foldr' +fold1 = foldr1 +fold1' = foldr1' + +#ifdef __GLASGOW_HASKELL__ + +foldr f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z) +foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z) + +reduce1 f (Seq xs) = unElem $ FT.reduce1 (unsafeCoerce# f) xs +reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs + +map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs + +#else + +foldr f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z) +foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z) + +reduce1 f (Seq xs) = unElem $ FT.reduce1 ( \(Elem x) (Elem y) -> Elem $ f x y) xs +reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs + +map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs + +#endif + +lookupM i (Seq xs) + | inBounds i (Seq xs) = + case FT.splitTree (> (SizeM i)) (SizeM 0) xs of + FT.Split _ (Elem x) _ -> return x + + | otherwise = fail "FingerSeq.lookupM: index out of bounds" + +lookupWithDefault d i (Seq xs) + | inBounds i (Seq xs) = + case FT.splitTree (> (SizeM i)) (SizeM 0) xs of + FT.Split _ (Elem x) _ -> x + + | otherwise = d + +update i x (Seq xs) + | inBounds i (Seq xs) = + case FT.splitTree (> (SizeM i)) (SizeM 0) xs of + FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r + + | otherwise = Seq xs + +adjust f i (Seq xs) + | inBounds i (Seq xs) = + case FT.splitTree (> (SizeM i)) (SizeM 0) xs of + FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r + + | otherwise = Seq xs + +take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs +drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs +splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b) + + +inBounds = inBoundsUsingSize +lookup = lookupUsingLookupM + +foldr1 f xs = + case rview xs of + Nothing -> error "FingerSeq.foldr1: empty sequence" + Just (x,xs') -> foldr f x xs' + +foldr1' f xs = + case rview xs of + Nothing -> error "FingerSeq.foldr1': empty sequence" + Just (x,xs') -> foldr' f x xs' + +foldl = foldlUsingLists +foldl' = foldl'UsingLists +foldl1 = foldl1UsingLists +foldl1' = foldl1'UsingLists + +reducer = reducerUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel = reducelUsingReduce1 +reducel' = reducel'UsingReduce1' + +copy = copyUsingLists +concat = concatUsingFoldr +reverseOnto = reverseOntoUsingReverse +concatMap = concatMapUsingFoldr +subseq = subseqDefault +filter = filterUsingLview +partition = partitionUsingFoldr +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview + +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists + +zip = zipUsingLview +zip3 = zip3UsingLview +zipWith = zipWithUsingLview +zipWith3 = zipWith3UsingLview + +unzip = unzipUsingFoldr +unzip3 = unzip3UsingFoldr +unzipWith = unzipWithUsingFoldr +unzipWith3 = unzipWith3UsingFoldr + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; + foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + xs == ys = toList xs == toList ys + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Elem a) where + arbitrary = arbitrary >>= return . Elem + +instance CoArbitrary a => CoArbitrary (Elem a) where + coarbitrary = coarbitrary . unElem + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = arbitrary >>= return . Seq + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary = coarbitrary . unSeq + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/JoinList.hs view
@@ -1,426 +1,443 @@--- |--- Module : Data.Edison.Seq.JoinList--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Join lists. All running times are as listed in "Data.Edison.Seq" except--- for the following:------ * rcons, append @O( 1 )@------ * ltail*, lview @O( 1 )@ when used single-threaded, @O( n )@ otherwise------ * lhead* @O( n )@------ * inBounds, lookup @O( n )@------ * copy @O( log i )@------ * concat @O( n1 )@------ * concatMap, (>>=) @O( n * t )@, where @n@ is the length of the input sequence and--- @t@ is the running time of @f@--module Data.Edison.Seq.JoinList (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldlWithIndex,- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import Control.Monad-import Data.Monoid-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.JoinList"--data Seq a = E | L a | A (Seq a) (Seq a)- -- invariant: E never a child of A--half :: Int -> Int-half n = n `div` 2--empty = E-singleton = L--lcons x E = L x-lcons x xs = A (L x) xs--rcons x E = L x-rcons x xs = A xs (L x)--append E ys = ys-append xs E = xs-append xs ys = A xs ys----- path reversal on lview/ltail--lview E = fail "JoinList.lview: empty sequence"-lview (L x) = return (x, E)-lview (A xs ys) = lvw xs ys- where lvw E _ = error "JoinList.lvw: bug"- lvw (L x) zs = return (x, zs)- lvw (A xs ys) zs = lvw xs (A ys zs)--lhead E = error "JoinList.lhead: empty sequence"-lhead (L x) = x-lhead (A xs _) = lhead xs--lheadM E = fail "JoinList.lheadM: empty sequence"-lheadM (L x) = return x-lheadM (A xs _) = lheadM xs--ltail E = error "JoinList.ltail: empty sequence"-ltail (L _) = E-ltail (A xs ys) = ltl xs ys- where ltl E _ = error "JoinList.ltl: bug"- ltl (L _) zs = zs- ltl (A xs ys) zs = ltl xs (A ys zs)--ltailM E = fail "JoinList.ltailM: empty sequence"-ltailM (L _) = return E-ltailM (A xs ys) = return (ltl xs ys)- where ltl E _ = error "JoinList.ltl: bug"- ltl (L _) zs = zs- ltl (A xs ys) zs = ltl xs (A ys zs)----- Don't want to do plain path reversal on rview/rtail because of expectation--- that left accesses are more common, so we would prefer to keep the left--- spine short.--rview E = fail "JoinLis.rview: empty sequence"-rview (L x) = return (x, E)-rview (A xs ys) = rvw xs ys- where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s- rvw xs (A ys (L x)) = return (x, A xs ys)- rvw xs (L x) = return (x, xs)- rvw _ _ = error "JoinList.rvw: bug"--rhead E = error "JoinList.rhead: empty sequence"-rhead (L x) = x-rhead (A _ ys) = rhead ys--rheadM E = fail "JoinList.rheadM: empty sequence"-rheadM (L x) = return x-rheadM (A _ ys) = rheadM ys--rtail E = error "JoinList.rtail: empty sequence"-rtail (L _) = E-rtail (A xs ys) = rtl xs ys- where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)- rtl xs (A ys (L _)) = A xs ys- rtl xs (L _) = xs- rtl _ _ = error "JoinList.rtl: bug"--rtailM E = fail "JoinList.rtailM: empty sequence"-rtailM (L _) = return E-rtailM (A xs ys) = return (rtl xs ys)- where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s)- rtl xs (A ys (L _)) = A xs ys- rtl xs (L _) = xs- rtl _ _ = error "JoinList.rtl: bug"--null E = True-null _ = False--size xs = sz xs (0::Int)- where sz E n = n- sz (L _) n = n + (1::Int)- sz (A xs ys) n = sz xs (sz ys n)--reverse (A xs ys) = A (reverse ys) (reverse xs)-reverse xs = xs -- L x or E--toList xs = tol xs []- where tol E rest = rest- tol (L x) rest = x:rest- tol (A xs ys) rest = tol xs (tol ys rest)--map _ E = E-map f (L x) = L (f x)-map f (A xs ys) = A (map f xs) (map f ys)--fold = foldr-fold' = foldr'-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (L x) = f x e-foldr f e (A xs ys) = foldr f (foldr f e ys) xs-foldr' _ e E = e-foldr' f e (L x) = f x $! e-foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs--foldl _ e E = e-foldl f e (L x) = f e x-foldl f e (A xs ys) = foldl f (foldl f e xs) ys--foldl' _ e E = e-foldl' f e (L x) = e `seq` f e x-foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys--foldr1 _ E = error "JoinList.foldr1: empty sequence"-foldr1 _ (L x) = x-foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs--foldr1' _ E = error "JoinLis.foldr1': empty sequence"-foldr1' _ (L x) = x-foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs--foldl1 _ E = error "JoinList.foldl1: empty sequence"-foldl1 _ (L x) = x-foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys--foldl1' _ E = error "JoinList.foldl1': empty sequence"-foldl1' _ (L x) = x-foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys--copy n x- | n <= 0 = E- | otherwise = cpy n x- where cpy n x -- n > 0- | even n = let xs = cpy (half n) x- in A xs xs- | n == 1 = L x- | otherwise = let xs = cpy (half n) x- in A (L x) (A xs xs)---strict s@E = s-strict s@(L _) = s-strict s@(A l r) = strict l `seq` strict r `seq` s--strictWith _ s@E = s-strictWith f s@(L x) = f x `seq` s-strictWith f s@(A l _) = strictWith f l `seq` strictWith f l `seq` s---- invariants:--- * 'E' is never a child of 'A'--structuralInvariant E = True-structuralInvariant s = check s- where check E = False- check (L _) = True- check (A s1 s2) = check s1 && check s2---concat = concatUsingFoldr-reverseOnto = reverseOntoUsingReverse-fromList = fromListUsingCons-concatMap = concatMapUsingFoldr--reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1 = reduce1UsingLists-reduce1' = reduce1'UsingLists--inBounds = inBoundsUsingDrop-lookup = lookupUsingDrop-lookupM = lookupMUsingDrop-lookupWithDefault = lookupWithDefaultUsingDrop--update = updateUsingSplitAt-adjust = adjustUsingSplitAt--mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists--take = takeUsingLview-drop = dropUsingLtail-splitAt = splitAtUsingLview-subseq = subseqDefault--filter = filterUsingLview-partition = partitionUsingFoldr-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview--zip = zipUsingLview-zip3 = zip3UsingLview-zipWith = zipWithUsingLview-zipWith3 = zipWith3UsingLview--unzip = unzipUsingFoldr-unzip3 = unzip3UsingFoldr-unzipWith = unzipWithUsingFoldr-unzipWith3 = unzipWith3UsingFoldr---- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;- foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty--instance Eq a => Eq (Seq a) where- xs == ys = toList xs == toList ys--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = sized arbTree- where arbTree 0 = return E- arbTree 1 = liftM L arbitrary- arbTree n =- frequency [(1, liftM L arbitrary),- (4, liftM2 A (arbTree (n `div` 2))- (arbTree (n `div` 2)))]--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary E = variant 0- coarbitrary (L x) = variant 1 . coarbitrary x- coarbitrary (A xs ys) = variant 2 . coarbitrary xs . coarbitrary ys--instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.JoinList +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Join lists. All running times are as listed in "Data.Edison.Seq" except +-- for the following: +-- +-- * rcons, append @O( 1 )@ +-- +-- * ltail*, lview @O( 1 )@ when used single-threaded, @O( n )@ otherwise +-- +-- * lhead* @O( n )@ +-- +-- * inBounds, lookup @O( n )@ +-- +-- * copy @O( log i )@ +-- +-- * concat @O( n1 )@ +-- +-- * concatMap, (>>=) @O( n * t )@, where @n@ is the length of the input sequence and +-- @t@ is the running time of @f@ + +module Data.Edison.Seq.JoinList ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldlWithIndex, + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import qualified Control.Applicative as App + +import Data.Edison.Seq.Defaults +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.JoinList" + +data Seq a = E | L a | A (Seq a) (Seq a) + -- invariant: E never a child of A + +half :: Int -> Int +half n = n `div` 2 + +empty = E +singleton = L + +lcons x E = L x +lcons x xs = A (L x) xs + +rcons x E = L x +rcons x xs = A xs (L x) + +append E ys = ys +append xs E = xs +append xs ys = A xs ys + + +-- path reversal on lview/ltail + +lview E = fail "JoinList.lview: empty sequence" +lview (L x) = return (x, E) +lview (A xs ys) = lvw xs ys + where lvw E _ = error "JoinList.lvw: bug" + lvw (L x) zs = return (x, zs) + lvw (A xs ys) zs = lvw xs (A ys zs) + +lhead E = error "JoinList.lhead: empty sequence" +lhead (L x) = x +lhead (A xs _) = lhead xs + +lheadM E = fail "JoinList.lheadM: empty sequence" +lheadM (L x) = return x +lheadM (A xs _) = lheadM xs + +ltail E = error "JoinList.ltail: empty sequence" +ltail (L _) = E +ltail (A xs ys) = ltl xs ys + where ltl E _ = error "JoinList.ltl: bug" + ltl (L _) zs = zs + ltl (A xs ys) zs = ltl xs (A ys zs) + +ltailM E = fail "JoinList.ltailM: empty sequence" +ltailM (L _) = return E +ltailM (A xs ys) = return (ltl xs ys) + where ltl E _ = error "JoinList.ltl: bug" + ltl (L _) zs = zs + ltl (A xs ys) zs = ltl xs (A ys zs) + + +-- Don't want to do plain path reversal on rview/rtail because of expectation +-- that left accesses are more common, so we would prefer to keep the left +-- spine short. + +rview E = fail "JoinLis.rview: empty sequence" +rview (L x) = return (x, E) +rview (A xs ys) = rvw xs ys + where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s + rvw xs (A ys (L x)) = return (x, A xs ys) + rvw xs (L x) = return (x, xs) + rvw _ _ = error "JoinList.rvw: bug" + +rhead E = error "JoinList.rhead: empty sequence" +rhead (L x) = x +rhead (A _ ys) = rhead ys + +rheadM E = fail "JoinList.rheadM: empty sequence" +rheadM (L x) = return x +rheadM (A _ ys) = rheadM ys + +rtail E = error "JoinList.rtail: empty sequence" +rtail (L _) = E +rtail (A xs ys) = rtl xs ys + where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s) + rtl xs (A ys (L _)) = A xs ys + rtl xs (L _) = xs + rtl _ _ = error "JoinList.rtl: bug" + +rtailM E = fail "JoinList.rtailM: empty sequence" +rtailM (L _) = return E +rtailM (A xs ys) = return (rtl xs ys) + where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s) + rtl xs (A ys (L _)) = A xs ys + rtl xs (L _) = xs + rtl _ _ = error "JoinList.rtl: bug" + +null E = True +null _ = False + +size xs = sz xs (0::Int) + where sz E n = n + sz (L _) n = n + (1::Int) + sz (A xs ys) n = sz xs (sz ys n) + +reverse (A xs ys) = A (reverse ys) (reverse xs) +reverse xs = xs -- L x or E + +toList xs = tol xs [] + where tol E rest = rest + tol (L x) rest = x:rest + tol (A xs ys) rest = tol xs (tol ys rest) + +map _ E = E +map f (L x) = L (f x) +map f (A xs ys) = A (map f xs) (map f ys) + +fold = foldr +fold' = foldr' +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr _ e E = e +foldr f e (L x) = f x e +foldr f e (A xs ys) = foldr f (foldr f e ys) xs +foldr' _ e E = e +foldr' f e (L x) = f x $! e +foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs + +foldl _ e E = e +foldl f e (L x) = f e x +foldl f e (A xs ys) = foldl f (foldl f e xs) ys + +foldl' _ e E = e +foldl' f e (L x) = e `seq` f e x +foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys + +foldr1 _ E = error "JoinList.foldr1: empty sequence" +foldr1 _ (L x) = x +foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs + +foldr1' _ E = error "JoinLis.foldr1': empty sequence" +foldr1' _ (L x) = x +foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs + +foldl1 _ E = error "JoinList.foldl1: empty sequence" +foldl1 _ (L x) = x +foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys + +foldl1' _ E = error "JoinList.foldl1': empty sequence" +foldl1' _ (L x) = x +foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys + +copy n x + | n <= 0 = E + | otherwise = cpy n x + where cpy n x -- n > 0 + | even n = let xs = cpy (half n) x + in A xs xs + | n == 1 = L x + | otherwise = let xs = cpy (half n) x + in A (L x) (A xs xs) + + +strict s@E = s +strict s@(L _) = s +strict s@(A l r) = strict l `seq` strict r `seq` s + +strictWith _ s@E = s +strictWith f s@(L x) = f x `seq` s +strictWith f s@(A l _) = strictWith f l `seq` strictWith f l `seq` s + +-- invariants: +-- * 'E' is never a child of 'A' + +structuralInvariant E = True +structuralInvariant s = check s + where check E = False + check (L _) = True + check (A s1 s2) = check s1 && check s2 + + +concat = concatUsingFoldr +reverseOnto = reverseOntoUsingReverse +fromList = fromListUsingCons +concatMap = concatMapUsingFoldr + +reducer = reducerUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel = reducelUsingReduce1 +reducel' = reducel'UsingReduce1' +reduce1 = reduce1UsingLists +reduce1' = reduce1'UsingLists + +inBounds = inBoundsUsingDrop +lookup = lookupUsingDrop +lookupM = lookupMUsingDrop +lookupWithDefault = lookupWithDefaultUsingDrop + +update = updateUsingSplitAt +adjust = adjustUsingSplitAt + +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists + +take = takeUsingLview +drop = dropUsingLtail +splitAt = splitAtUsingLview +subseq = subseqDefault + +filter = filterUsingLview +partition = partitionUsingFoldr +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview + +zip = zipUsingLview +zip3 = zip3UsingLview +zipWith = zipWithUsingLview +zipWith3 = zipWith3UsingLview + +unzip = unzipUsingFoldr +unzip3 = unzip3UsingFoldr +unzipWith = unzipWithUsingFoldr +unzipWith3 = unzipWith3UsingFoldr + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; + foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + xs == ys = toList xs == toList ys + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = sized arbTree + where arbTree 0 = return E + arbTree 1 = liftM L arbitrary + arbTree n = + frequency [(1, liftM L arbitrary), + (4, liftM2 A (arbTree (n `div` 2)) + (arbTree (n `div` 2)))] + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary E = variant (0 :: Int) + coarbitrary (L x) = variant (1 :: Int) . coarbitrary x + coarbitrary (A xs ys) = variant (2 :: Int) . coarbitrary xs . coarbitrary ys + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/MyersStack.hs view
@@ -1,438 +1,453 @@--- |--- Module : Data.Edison.Seq.MyersStack--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Meyers Stacks. All operations are as listed in "Data.Edison.Seq" except--- the following:------ * lookup, inBounds, drop @O( min(i, log n) )@------ * rhead*, size @O( log n )@------ * subseq @O( min (i, log n) + len )@------ /References:/------ * Eugene Myers. \"An applicative random-access stack\". /Information--- Processing Letters/, 17(5):241-248, December 1983.--module Data.Edison.Seq.MyersStack (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import Control.Monad.Identity-import Data.Monoid-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.MyersStack"---data Seq a = E | C !Int a (Seq a) (Seq a)- -- what about strictness flags on tail and jump-tail?---- auxiliary function-jump :: Seq t -> Seq t-jump (C _ _ _ (C _ _ _ xs')) = xs'-jump _ = error "MyersStack.jump: bug!"--empty = E-singleton x = C 1 x E E--lcons x xs@(C i _ _ (C j _ _ xs'))- | i == j = C (1 + i + j) x xs xs'-lcons x xs = C 1 x xs xs--lview E = fail "MyersStack.lview: empty sequence"-lview (C _ x xs _) = return (x, xs)--lhead E = error "MyersStack.lhead: empty sequence"-lhead (C _ x _ _) = x--lheadM E = fail "MyersStack.lheadM: empty sequence"-lheadM (C _ x _ _) = return x--ltail E = error "MyersStack.ltail: empty sequence"-ltail (C _ _ xs _) = xs--ltailM E = fail "MyersStack.ltailM: empty sequence"-ltailM (C _ _ xs _) = return xs--rview E = fail "MyersStack.rview: empty sequence"-rview xs = return (rhead xs, rtail xs)--rhead E = error "MyersStack.rhead: empty sequence"-rhead (C _ x xs xs') = rh x xs xs'- where rh _ _ (C _ y ys ys') = rh y ys ys'- rh _ (C _ y ys ys') E = rh y ys ys'- rh x E E = x--rheadM E = fail "MyersStack.rheadM: empty sequence"-rheadM (C _ x xs xs') = return (rh x xs xs')- where rh _ _ (C _ y ys ys') = rh y ys ys'- rh _ (C _ y ys ys') E = rh y ys ys'- rh x E E = x--rtail E = error "MyersStack.rtail: empty sequence"-rtail (C _ x xs _) = rt x xs- where rt _ E = E- rt y (C _ x xs _) = lcons y (rt x xs)--rtailM E = fail "MyersStack.rtailM: empty sequence"-rtailM (C _ x xs _) = return (rt x xs)- where rt _ E = E- rt y (C _ x xs _) = lcons y (rt x xs)--null E = True-null _ = False--size xs = go xs- where go E = (0::Int)- go (C j _ _ xs') = j + size xs'--reverseOnto E ys = ys-reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys)--map _ E = E-map f (C j x xs _')- | j == 1 = C j (f x) ys ys- | otherwise = C j (f x) ys (jump ys)- where ys = map f xs--fold = foldr-fold' f = foldl' (flip f)-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (C _ x xs _) = f x (foldr f e xs)--foldr' _ e E = e-foldr' f e (C _ x xs _) = f x $! (foldr' f e xs)--foldl _ e E = e-foldl f e (C _ x xs _) = foldl f (f e x) xs--foldl' _ e E = e-foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs--foldr1 _ E = error "MyersStack.foldr1: empty sequence"-foldr1 f (C _ x xs _) = fr x xs- where fr y E = y- fr y (C _ x xs _) = f y (fr x xs)--foldr1' _ E = error "MyersStack.foldr1': empty sequence"-foldr1' f (C _ x xs _) = fr x xs- where fr y E = y- fr y (C _ x xs _) = f y $! (fr x xs)--foldl1 _ E = error "MyersStack.foldl1: empty sequence"-foldl1 f (C _ x xs _) = foldl f x xs--foldl1' _ E = error "MyersStack.foldl1': empty sequence"-foldl1' f (C _ x xs _ ) = foldl' f x xs--inBounds i xs = inb xs i- where inb E _ = False- inb (C j _ _ xs') i- | i < j = (i >= 0)- | otherwise = inb xs' (i - j)--lookup i xs = runIdentity (lookupM i xs)--lookupM i xs = look xs i- where look E _ = fail "MyersStack.lookup: bad subscript"- look (C j x xs xs') i- | i >= j = look xs' (i - j)- | i > 0 = look xs (i - 1)- | i == 0 = return x- | otherwise = nothing- nothing = fail "MyersStack.lookup: not found"--lookupWithDefault d i xs = look xs i- where look E _ = d- look (C j x xs xs') i- | i >= j = look xs' (i - j)- | i > 0 = look xs (i - 1)- | i == 0 = x- | otherwise = d--update i y xs = upd i xs- where upd _ E = E- upd 0 (C j _ xs xs') = C j y xs xs'- upd i (C j x xs _)- | j == 1 = C j x ys ys- | otherwise = C j x ys (jump ys)- where ys = upd (i - 1) xs--adjust f i xs = adj i xs- where adj _ E = E- adj 0 (C j x xs xs') = C j (f x) xs xs'- adj i (C j x xs _)- | j == 1 = C j x ys ys- | otherwise = C j x ys (jump ys)- where ys = adj (i - (1::Int)) xs--drop n xs = drp n xs- where drp n xs | n <= 0 = xs- drp _ E = E- drp n (C j _ xs xs')- | n < j = drp (n - 1) xs- | otherwise = drp (n - j) xs'--unzip E = (E, E)-unzip (C j (x,y) ps _')- | j == 1 = (C j x xs xs, C j y ys ys)- | otherwise = (C j x xs (jump xs), C j y ys (jump ys))- where (xs,ys) = unzip ps--unzip3 E = (E, E, E)-unzip3 (C j (x,y,z) ts _')- | j == 1 = (C j x xs xs, C j y ys ys, C j z zs zs)- | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs))- where (xs,ys,zs) = unzip3 ts--unzipWith _ _ E = (E, E)-unzipWith f g (C j x xs _)- | j == 1 = (C j (f x) as as, C j (g x) bs bs)- | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs))- where (as,bs) = unzipWith f g xs--unzipWith3 _ _ _ E = (E, E, E)-unzipWith3 f g h (C j x xs _)- | j == 1 = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs)- | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs),- C j (h x) cs (jump cs))- where (as,bs,cs) = unzipWith3 f g h xs--strict s@E = s-strict s@(C _ _ xs _) = strict xs `seq` s--strictWith _ s@E = s-strictWith f s@(C _ x xs _) = f x `seq` strictWith f xs `seq` s---- the remaining functions all use defaults--rcons = rconsUsingFoldr-append = appendUsingFoldr-concat = concatUsingFoldr-reverse = reverseUsingReverseOnto-fromList = fromListUsingCons-toList = toListUsingFoldr-concatMap = concatMapUsingFoldr-reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1 = reduce1UsingLists-reduce1' = reduce1'UsingLists-copy = copyUsingLists-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-take = takeUsingLists-splitAt = splitAtDefault-filter = filterUsingFoldr-partition = partitionUsingFoldr-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview---- for zips, could optimize by calculating which one is shorter and--- retaining its shape--zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists---- FIXME what are the structural invariants?-structuralInvariant = const True---- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty--instance Eq a => Eq (Seq a) where- xs == ys =- (size xs == size ys) && (toList xs == toList ys)--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList---instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = do xs <- arbitrary- return (fromList xs)--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary xs = coarbitrary (toList xs)--instance Monoid (Seq a) where- mempty = empty- mappend = append------------------{--questions:- - any benefit to- E | C1 x xs | CJ Int# x xs xs'-- - any benefit to length instead of delta?-- - any benefit to delta not counting x (i.e., base 0 instead of base 1)?--I don't believe any will do any better, except possibly the first--}-+-- | +-- Module : Data.Edison.Seq.MyersStack +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Meyers Stacks. All operations are as listed in "Data.Edison.Seq" except +-- the following: +-- +-- * lookup, inBounds, drop @O( min(i, log n) )@ +-- +-- * rhead*, size @O( log n )@ +-- +-- * subseq @O( min (i, log n) + len )@ +-- +-- /References:/ +-- +-- * Eugene Myers. \"An applicative random-access stack\". /Information +-- Processing Letters/, 17(5):241-248, December 1983. + +module Data.Edison.Seq.MyersStack ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.MyersStack" + + +data Seq a = E | C !Int a (Seq a) (Seq a) + -- what about strictness flags on tail and jump-tail? + +-- auxiliary function +jump :: Seq t -> Seq t +jump (C _ _ _ (C _ _ _ xs')) = xs' +jump _ = error "MyersStack.jump: bug!" + +empty = E +singleton x = C 1 x E E + +lcons x xs@(C i _ _ (C j _ _ xs')) + | i == j = C (1 + i + j) x xs xs' +lcons x xs = C 1 x xs xs + +lview E = fail "MyersStack.lview: empty sequence" +lview (C _ x xs _) = return (x, xs) + +lhead E = error "MyersStack.lhead: empty sequence" +lhead (C _ x _ _) = x + +lheadM E = fail "MyersStack.lheadM: empty sequence" +lheadM (C _ x _ _) = return x + +ltail E = error "MyersStack.ltail: empty sequence" +ltail (C _ _ xs _) = xs + +ltailM E = fail "MyersStack.ltailM: empty sequence" +ltailM (C _ _ xs _) = return xs + +rview E = fail "MyersStack.rview: empty sequence" +rview xs = return (rhead xs, rtail xs) + +rhead E = error "MyersStack.rhead: empty sequence" +rhead (C _ x xs xs') = rh x xs xs' + where rh _ _ (C _ y ys ys') = rh y ys ys' + rh _ (C _ y ys ys') E = rh y ys ys' + rh x E E = x + +rheadM E = fail "MyersStack.rheadM: empty sequence" +rheadM (C _ x xs xs') = return (rh x xs xs') + where rh _ _ (C _ y ys ys') = rh y ys ys' + rh _ (C _ y ys ys') E = rh y ys ys' + rh x E E = x + +rtail E = error "MyersStack.rtail: empty sequence" +rtail (C _ x xs _) = rt x xs + where rt _ E = E + rt y (C _ x xs _) = lcons y (rt x xs) + +rtailM E = fail "MyersStack.rtailM: empty sequence" +rtailM (C _ x xs _) = return (rt x xs) + where rt _ E = E + rt y (C _ x xs _) = lcons y (rt x xs) + +null E = True +null _ = False + +size xs = go xs + where go E = (0::Int) + go (C j _ _ xs') = j + size xs' + +reverseOnto E ys = ys +reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys) + +map _ E = E +map f (C j x xs _') + | j == 1 = C j (f x) ys ys + | otherwise = C j (f x) ys (jump ys) + where ys = map f xs + +fold = foldr +fold' f = foldl' (flip f) +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr _ e E = e +foldr f e (C _ x xs _) = f x (foldr f e xs) + +foldr' _ e E = e +foldr' f e (C _ x xs _) = f x $! (foldr' f e xs) + +foldl _ e E = e +foldl f e (C _ x xs _) = foldl f (f e x) xs + +foldl' _ e E = e +foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs + +foldr1 _ E = error "MyersStack.foldr1: empty sequence" +foldr1 f (C _ x xs _) = fr x xs + where fr y E = y + fr y (C _ x xs _) = f y (fr x xs) + +foldr1' _ E = error "MyersStack.foldr1': empty sequence" +foldr1' f (C _ x xs _) = fr x xs + where fr y E = y + fr y (C _ x xs _) = f y $! (fr x xs) + +foldl1 _ E = error "MyersStack.foldl1: empty sequence" +foldl1 f (C _ x xs _) = foldl f x xs + +foldl1' _ E = error "MyersStack.foldl1': empty sequence" +foldl1' f (C _ x xs _ ) = foldl' f x xs + +inBounds i xs = inb xs i + where inb E _ = False + inb (C j _ _ xs') i + | i < j = (i >= 0) + | otherwise = inb xs' (i - j) + +lookup i xs = runFail_ (lookupM i xs) + +lookupM i xs = look xs i + where look E _ = fail "MyersStack.lookup: bad subscript" + look (C j x xs xs') i + | i >= j = look xs' (i - j) + | i > 0 = look xs (i - 1) + | i == 0 = return x + | otherwise = nothing + nothing = fail "MyersStack.lookup: not found" + +lookupWithDefault d i xs = look xs i + where look E _ = d + look (C j x xs xs') i + | i >= j = look xs' (i - j) + | i > 0 = look xs (i - 1) + | i == 0 = x + | otherwise = d + +update i y xs = upd i xs + where upd _ E = E + upd 0 (C j _ xs xs') = C j y xs xs' + upd i (C j x xs _) + | j == 1 = C j x ys ys + | otherwise = C j x ys (jump ys) + where ys = upd (i - 1) xs + +adjust f i xs = adj i xs + where adj _ E = E + adj 0 (C j x xs xs') = C j (f x) xs xs' + adj i (C j x xs _) + | j == 1 = C j x ys ys + | otherwise = C j x ys (jump ys) + where ys = adj (i - (1::Int)) xs + +drop n xs = drp n xs + where drp n xs | n <= 0 = xs + drp _ E = E + drp n (C j _ xs xs') + | n < j = drp (n - 1) xs + | otherwise = drp (n - j) xs' + +unzip E = (E, E) +unzip (C j (x,y) ps _') + | j == 1 = (C j x xs xs, C j y ys ys) + | otherwise = (C j x xs (jump xs), C j y ys (jump ys)) + where (xs,ys) = unzip ps + +unzip3 E = (E, E, E) +unzip3 (C j (x,y,z) ts _') + | j == 1 = (C j x xs xs, C j y ys ys, C j z zs zs) + | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs)) + where (xs,ys,zs) = unzip3 ts + +unzipWith _ _ E = (E, E) +unzipWith f g (C j x xs _) + | j == 1 = (C j (f x) as as, C j (g x) bs bs) + | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs)) + where (as,bs) = unzipWith f g xs + +unzipWith3 _ _ _ E = (E, E, E) +unzipWith3 f g h (C j x xs _) + | j == 1 = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs) + | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs), + C j (h x) cs (jump cs)) + where (as,bs,cs) = unzipWith3 f g h xs + +strict s@E = s +strict s@(C _ _ xs _) = strict xs `seq` s + +strictWith _ s@E = s +strictWith f s@(C _ x xs _) = f x `seq` strictWith f xs `seq` s + +-- the remaining functions all use defaults + +rcons = rconsUsingFoldr +append = appendUsingFoldr +concat = concatUsingFoldr +reverse = reverseUsingReverseOnto +fromList = fromListUsingCons +toList = toListUsingFoldr +concatMap = concatMapUsingFoldr +reducer = reducerUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel = reducelUsingReduce1 +reducel' = reducel'UsingReduce1' +reduce1 = reduce1UsingLists +reduce1' = reduce1'UsingLists +copy = copyUsingLists +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists +take = takeUsingLists +splitAt = splitAtDefault +filter = filterUsingFoldr +partition = partitionUsingFoldr +subseq = subseqDefault +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview + +-- for zips, could optimize by calculating which one is shorter and +-- retaining its shape + +zip = zipUsingLists +zip3 = zip3UsingLists +zipWith = zipWithUsingLists +zipWith3 = zipWith3UsingLists + +-- FIXME what are the structural invariants? +structuralInvariant = const True + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + xs == ys = + (size xs == size ys) && (toList xs == toList ys) + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + return (fromList xs) + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary xs = coarbitrary (toList xs) + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>) + +------------- + +{- +questions: + - any benefit to + E | C1 x xs | CJ Int# x xs xs' + + - any benefit to length instead of delta? + + - any benefit to delta not counting x (i.e., base 0 instead of base 1)? + +I don't believe any will do any better, except possibly the first +-}
src/Data/Edison/Seq/RandList.hs view
@@ -1,482 +1,500 @@--- |--- Module : Data.Edison.Seq.RandList--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Random-Access Lists. All operations are as listed in "Data.Edison.Seq"--- except the following:------ * rhead*, size @O( log n )@------ * copy, inBounds @O( log i )@------ * lookup*, update, adjust, drop @O( min( i, log n ) )@------ * subseq @O( min( i, log n ) + len )@------ /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.--- Section 9.3.1.------ * Chris Okasaki. \"Purely Functional Random Access Lists\". FPCA'95,--- pages 86-95.--module Data.Edison.Seq.RandList (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S( Sequence(..) )-import Data.Edison.Seq.Defaults-import Control.Monad.Identity-import Data.Monoid-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-moduleName = "Data.Edison.Seq.RandList"---data Tree a = L a | T a (Tree a) (Tree a) deriving (Eq)-data Seq a = E | C !Int (Tree a) (Seq a) deriving (Eq)--half :: Int -> Int-half n = n `quot` 2 -- use a shift?--empty = E-singleton x = C 1 (L x) E--lcons x (C i s (C j t xs'))- | i == j = C (1 + i + j) (T x s t) xs'-lcons x xs = C 1 (L x) xs--copy n x = if n <= 0 then E else buildTrees (1::Int) (L x)- where buildTrees j t- | j > n = takeTrees n (half j) (child t) E- | otherwise = buildTrees (1 + j + j) (T x t t)-- takeTrees i j t xs- | i >= j = takeTrees (i - j) j t (C j t xs)- | i > 0 = takeTrees i (half j) (child t) xs- | otherwise = xs-- child (T _ _ t) = t- child _ = error "RandList.copy: bug!"--lview E = fail "RandList.lview: empty sequence"-lview (C _ (L x) xs) = return (x, xs)-lview (C i (T x s t) xs) = return (x, C j s (C j t xs))- where j = half i--lhead E = error "RandList.lhead: empty sequence"-lhead (C _ (L x) _) = x-lhead (C _ (T x _ _) _) = x--lheadM E = fail "RandList.lheadM: empty sequence"-lheadM (C _ (L x) _) = return x-lheadM (C _ (T x _ _) _) = return x--ltail E = error "RandList.ltail: empty sequence"-ltail (C _ (L _) xs) = xs-ltail (C i (T _ s t) xs) = C j s (C j t xs)- where j = half i--ltailM E = fail "RandList.ltailM: empty sequence"-ltailM (C _ (L _) xs) = return xs-ltailM (C i (T _ s t) xs) = return (C j s (C j t xs))- where j = half i--rhead E = error "RandList.rhead: empty sequence"-rhead (C _ t E) = treeLast t- where treeLast (L x) = x- treeLast (T _ _ t) = treeLast t-rhead (C _ _ xs) = rhead xs--rheadM E = fail "RandList.rhead: empty sequence"-rheadM (C _ t E) = return(treeLast t)- where treeLast (L x) = x- treeLast (T _ _ t) = treeLast t-rheadM (C _ _ xs) = rheadM xs---null E = True-null _ = False--size xs = sz xs- where sz E = (0::Int)- sz (C j _ xs) = j + sz xs--reverseOnto E ys = ys-reverseOnto (C _ t xs) ys = reverseOnto xs (revTree t ys)- where revTree (L x) ys = lcons x ys- revTree (T x s t) ys = revTree t (revTree s (lcons x ys))--map _ E = E-map f (C j t xs) = C j (mapTree f t) (map f xs)- where mapTree f (L x) = L (f x)- mapTree f (T x s t) = T (f x) (mapTree f s) (mapTree f t)--fold = foldr-fold' f = foldl' (flip f)-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'--foldr _ e E = e-foldr f e (C _ t xs) = foldTree t (foldr f e xs)- where foldTree (L x) e = f x e- foldTree (T x s t) e = f x (foldTree s (foldTree t e))--foldr' _ e E = e-foldr' f e (C _ t xs) = foldTree t $! (foldr' f e xs)- where foldTree (L x) e = f x $! e- foldTree (T x s t) e = f x $! (foldTree s $! (foldTree t $! e))--foldl _ e E = e-foldl f e (C _ t xs) = foldl f (foldTree e t) xs- where foldTree e (L x) = f e x- foldTree e (T x s t) = foldTree (foldTree (f e x) s) t--foldl' _ e E = e-foldl' f e (C _ t xs) = (foldl f $! (foldTree e t)) xs- where foldTree e (L x) = e `seq` f e x- foldTree e (T x s t) = e `seq` (foldTree $! (foldTree (f e x) s)) t--reduce1 f xs = case lview xs of- Nothing -> error "RandList.reduce1: empty seq"- Just (x, xs) -> red1 x xs- where red1 x E = x- red1 x (C _ t xs) = red1 (redTree x t) xs-- redTree x (L y) = f x y- redTree x (T y s t) = redTree (redTree (f x y) s) t--reduce1' f xs = case lview xs of- Nothing -> error "RandList.reduce1': empty seq"- Just (x, xs) -> red1 x xs- where red1 x E = x- red1 x (C _ t xs) = (red1 $! (redTree x t)) xs-- redTree x (L y) = x `seq` y `seq` f x y- redTree x (T y s t) = x `seq` y `seq` (redTree $! (redTree (f x y) s)) t---inBounds i xs = inb xs i- where inb E _ = False- inb (C j _ xs) i- | i < j = (i >= 0)- | otherwise = inb xs (i - j)--lookup i xs = runIdentity (lookupM i xs)--lookupM i xs = look xs i- where look E _ = fail "RandList.lookup bad subscript"- look (C j t xs) i- | i < j = lookTree j t i- | otherwise = look xs (i - j)-- lookTree _ (L x) i- | i == 0 = return x- | otherwise = nothing- lookTree j (T x s t) i- | i > k = lookTree k t (i - 1 - k)- | i /= 0 = lookTree k s (i - 1)- | otherwise = return x- where k = half j- nothing = fail "RandList.lookup: not found"--lookupWithDefault d i xs = look xs i- where look E _ = d- look (C j t xs) i- | i < j = lookTree j t i- | otherwise = look xs (i - j)-- lookTree _ (L x) i- | i == 0 = x- | otherwise = d- lookTree j (T x s t) i- | i > k = lookTree k t (i - 1 - k)- | i /= 0 = lookTree k s (i - 1)- | otherwise = x- where k = half j--update i y xs = upd i xs- where upd _ E = E- upd i (C j t xs)- | i < j = C j (updTree i j t) xs- | otherwise = C j t (upd (i - j) xs)-- updTree i _ t@(L _)- | i == 0 = L y- | otherwise = t- updTree i j (T x s t)- | i > k = T x s (updTree (i - 1 - k) k t)- | i /= 0 = T x (updTree (i - 1) k s) t- | otherwise = T y s t- where k = half j--adjust f i xs = adj i xs- where adj _ E = E- adj i (C j t xs)- | i < j = C j (adjTree i j t) xs- | otherwise = C j t (adj (i - j) xs)-- adjTree i _ t@(L x)- | i == 0 = L (f x)- | otherwise = t- adjTree i j (T x s t)- | i > k = T x s (adjTree (i - 1 - k) k t)- | i /= 0 = T x (adjTree (i - 1) k s) t- | otherwise = T (f x) s t- where k = half j--drop n xs = if n < 0 then xs else drp n xs- where drp _ E = E- drp i (C j t xs)- | i < j = drpTree i j t xs- | otherwise = drp (i - j) xs-- drpTree 0 j t xs = C j t xs- drpTree _ _ (L _) _ = error "RandList.drop: bug. Impossible case!"- drpTree i j (T _ s t) xs- | i > k = drpTree (i - 1 - k) k t xs- | otherwise = drpTree (i - 1) k s (C k t xs)- where k = half j--strict s@E = s-strict s@(C _ t xs) = strictTree t `seq` strict xs `seq` s--strictTree :: Tree t -> Tree t-strictTree t@(L _) = t-strictTree t@(T _ l r) = strictTree l `seq` strictTree r `seq` t--strictWith _ s@E = s-strictWith f s@(C _ t xs) = strictWithTree f t `seq` strictWith f xs `seq` s--strictWithTree :: (t -> a) -> Tree t -> Tree t-strictWithTree f t@(L x) = f x `seq` t-strictWithTree f t@(T x l r) = f x `seq` strictWithTree f l `seq` strictWithTree f r `seq` t----- the remaining functions all use defaults--rcons = rconsUsingFoldr-append = appendUsingFoldr-rview = rviewDefault-rtail = rtailUsingLview-rtailM = rtailMUsingLview-concat = concatUsingFoldr-reverse = reverseUsingReverseOnto-fromList = fromListUsingCons-toList = toListUsingFoldr-concatMap = concatMapUsingFoldr-foldr1 = foldr1UsingLview-foldr1' = foldr1'UsingLview-foldl1 = foldl1UsingFoldl-foldl1' = foldl1'UsingFoldl'-reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-take = takeUsingLists-splitAt = splitAtDefault-filter = filterUsingFoldr-partition = partitionUsingFoldr-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview---- for zips, could optimize by calculating which one is shorter and--- retaining its shape--zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- invariants:--- * list of complete binary trees in non-decreasing--- order by size--- * first argument to 'C' is the number--- of nodes in the tree-structuralInvariant :: Seq t -> Bool-structuralInvariant E = True-structuralInvariant (C x t s) = x > 0 && checkTree x t && checkSeq x s-- where checkTree 1 (L _) = True- checkTree w (T _ l r) =- let w' = (w - 1) `div` 2- in w' > 0 && checkTree w' l && checkTree w' r- checkTree _ _ = False-- checkSeq _ E = True- checkSeq x (C y t s) =- x <= y && checkTree y t && checkSeq y s----- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = do xs <- arbitrary- return (fromList xs)--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary xs = coarbitrary (toList xs)--instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.RandList +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Random-Access Lists. All operations are as listed in "Data.Edison.Seq" +-- except the following: +-- +-- * rhead*, size @O( log n )@ +-- +-- * copy, inBounds @O( log i )@ +-- +-- * lookup*, update, adjust, drop @O( min( i, log n ) )@ +-- +-- * subseq @O( min( i, log n ) + len )@ +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. +-- Section 9.3.1. +-- +-- * Chris Okasaki. \"Purely Functional Random Access Lists\". FPCA'95, +-- pages 86-95. + +module Data.Edison.Seq.RandList ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App + +import Data.Edison.Prelude ( runFail_ ) +import qualified Data.Edison.Seq as S( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Control.Monad.Fail as Fail +import Control.Monad +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +moduleName = "Data.Edison.Seq.RandList" + + +data Tree a = L a | T a (Tree a) (Tree a) deriving (Eq) +data Seq a = E | C !Int (Tree a) (Seq a) deriving (Eq) + +half :: Int -> Int +half n = n `quot` 2 -- use a shift? + +empty = E +singleton x = C 1 (L x) E + +lcons x (C i s (C j t xs')) + | i == j = C (1 + i + j) (T x s t) xs' +lcons x xs = C 1 (L x) xs + +copy n x = if n <= 0 then E else buildTrees (1::Int) (L x) + where buildTrees j t + | j > n = takeTrees n (half j) (child t) E + | otherwise = buildTrees (1 + j + j) (T x t t) + + takeTrees i j t xs + | i >= j = takeTrees (i - j) j t (C j t xs) + | i > 0 = takeTrees i (half j) (child t) xs + | otherwise = xs + + child (T _ _ t) = t + child _ = error "RandList.copy: bug!" + +lview E = fail "RandList.lview: empty sequence" +lview (C _ (L x) xs) = return (x, xs) +lview (C i (T x s t) xs) = return (x, C j s (C j t xs)) + where j = half i + +lhead E = error "RandList.lhead: empty sequence" +lhead (C _ (L x) _) = x +lhead (C _ (T x _ _) _) = x + +lheadM E = fail "RandList.lheadM: empty sequence" +lheadM (C _ (L x) _) = return x +lheadM (C _ (T x _ _) _) = return x + +ltail E = error "RandList.ltail: empty sequence" +ltail (C _ (L _) xs) = xs +ltail (C i (T _ s t) xs) = C j s (C j t xs) + where j = half i + +ltailM E = fail "RandList.ltailM: empty sequence" +ltailM (C _ (L _) xs) = return xs +ltailM (C i (T _ s t) xs) = return (C j s (C j t xs)) + where j = half i + +rhead E = error "RandList.rhead: empty sequence" +rhead (C _ t E) = treeLast t + where treeLast (L x) = x + treeLast (T _ _ t) = treeLast t +rhead (C _ _ xs) = rhead xs + +rheadM E = fail "RandList.rhead: empty sequence" +rheadM (C _ t E) = return(treeLast t) + where treeLast (L x) = x + treeLast (T _ _ t) = treeLast t +rheadM (C _ _ xs) = rheadM xs + + +null E = True +null _ = False + +size xs = sz xs + where sz E = (0::Int) + sz (C j _ xs) = j + sz xs + +reverseOnto E ys = ys +reverseOnto (C _ t xs) ys = reverseOnto xs (revTree t ys) + where revTree (L x) ys = lcons x ys + revTree (T x s t) ys = revTree t (revTree s (lcons x ys)) + +map _ E = E +map f (C j t xs) = C j (mapTree f t) (map f xs) + where mapTree f (L x) = L (f x) + mapTree f (T x s t) = T (f x) (mapTree f s) (mapTree f t) + +fold = foldr +fold' f = foldl' (flip f) +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr _ e E = e +foldr f e (C _ t xs) = foldTree t (foldr f e xs) + where foldTree (L x) e = f x e + foldTree (T x s t) e = f x (foldTree s (foldTree t e)) + +foldr' _ e E = e +foldr' f e (C _ t xs) = foldTree t $! (foldr' f e xs) + where foldTree (L x) e = f x $! e + foldTree (T x s t) e = f x $! (foldTree s $! (foldTree t $! e)) + +foldl _ e E = e +foldl f e (C _ t xs) = foldl f (foldTree e t) xs + where foldTree e (L x) = f e x + foldTree e (T x s t) = foldTree (foldTree (f e x) s) t + +foldl' _ e E = e +foldl' f e (C _ t xs) = (foldl f $! (foldTree e t)) xs + where foldTree e (L x) = e `seq` f e x + foldTree e (T x s t) = e `seq` (foldTree $! (foldTree (f e x) s)) t + +reduce1 f xs = case lview xs of + Nothing -> error "RandList.reduce1: empty seq" + Just (x, xs) -> red1 x xs + where red1 x E = x + red1 x (C _ t xs) = red1 (redTree x t) xs + + redTree x (L y) = f x y + redTree x (T y s t) = redTree (redTree (f x y) s) t + +reduce1' f xs = case lview xs of + Nothing -> error "RandList.reduce1': empty seq" + Just (x, xs) -> red1 x xs + where red1 x E = x + red1 x (C _ t xs) = (red1 $! (redTree x t)) xs + + redTree x (L y) = x `seq` y `seq` f x y + redTree x (T y s t) = x `seq` y `seq` (redTree $! (redTree (f x y) s)) t + + +inBounds i xs = inb xs i + where inb E _ = False + inb (C j _ xs) i + | i < j = (i >= 0) + | otherwise = inb xs (i - j) + +lookup i xs = runFail_ (lookupM i xs) + +lookupM i xs = look xs i + where look E _ = fail "RandList.lookup bad subscript" + look (C j t xs) i + | i < j = lookTree j t i + | otherwise = look xs (i - j) + + lookTree _ (L x) i + | i == 0 = return x + | otherwise = nothing + lookTree j (T x s t) i + | i > k = lookTree k t (i - 1 - k) + | i /= 0 = lookTree k s (i - 1) + | otherwise = return x + where k = half j + nothing = fail "RandList.lookup: not found" + +lookupWithDefault d i xs = look xs i + where look E _ = d + look (C j t xs) i + | i < j = lookTree j t i + | otherwise = look xs (i - j) + + lookTree _ (L x) i + | i == 0 = x + | otherwise = d + lookTree j (T x s t) i + | i > k = lookTree k t (i - 1 - k) + | i /= 0 = lookTree k s (i - 1) + | otherwise = x + where k = half j + +update i y xs = upd i xs + where upd _ E = E + upd i (C j t xs) + | i < j = C j (updTree i j t) xs + | otherwise = C j t (upd (i - j) xs) + + updTree i _ t@(L _) + | i == 0 = L y + | otherwise = t + updTree i j (T x s t) + | i > k = T x s (updTree (i - 1 - k) k t) + | i /= 0 = T x (updTree (i - 1) k s) t + | otherwise = T y s t + where k = half j + +adjust f i xs = adj i xs + where adj _ E = E + adj i (C j t xs) + | i < j = C j (adjTree i j t) xs + | otherwise = C j t (adj (i - j) xs) + + adjTree i _ t@(L x) + | i == 0 = L (f x) + | otherwise = t + adjTree i j (T x s t) + | i > k = T x s (adjTree (i - 1 - k) k t) + | i /= 0 = T x (adjTree (i - 1) k s) t + | otherwise = T (f x) s t + where k = half j + +drop n xs = if n < 0 then xs else drp n xs + where drp _ E = E + drp i (C j t xs) + | i < j = drpTree i j t xs + | otherwise = drp (i - j) xs + + drpTree 0 j t xs = C j t xs + drpTree _ _ (L _) _ = error "RandList.drop: bug. Impossible case!" + drpTree i j (T _ s t) xs + | i > k = drpTree (i - 1 - k) k t xs + | otherwise = drpTree (i - 1) k s (C k t xs) + where k = half j + +strict s@E = s +strict s@(C _ t xs) = strictTree t `seq` strict xs `seq` s + +strictTree :: Tree t -> Tree t +strictTree t@(L _) = t +strictTree t@(T _ l r) = strictTree l `seq` strictTree r `seq` t + +strictWith _ s@E = s +strictWith f s@(C _ t xs) = strictWithTree f t `seq` strictWith f xs `seq` s + +strictWithTree :: (t -> a) -> Tree t -> Tree t +strictWithTree f t@(L x) = f x `seq` t +strictWithTree f t@(T x l r) = f x `seq` strictWithTree f l `seq` strictWithTree f r `seq` t + + +-- the remaining functions all use defaults + +rcons = rconsUsingFoldr +append = appendUsingFoldr +rview = rviewDefault +rtail = rtailUsingLview +rtailM = rtailMUsingLview +concat = concatUsingFoldr +reverse = reverseUsingReverseOnto +fromList = fromListUsingCons +toList = toListUsingFoldr +concatMap = concatMapUsingFoldr +foldr1 = foldr1UsingLview +foldr1' = foldr1'UsingLview +foldl1 = foldl1UsingFoldl +foldl1' = foldl1'UsingFoldl' +reducer = reducerUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel = reducelUsingReduce1 +reducel' = reducel'UsingReduce1' +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists +take = takeUsingLists +splitAt = splitAtDefault +filter = filterUsingFoldr +partition = partitionUsingFoldr +subseq = subseqDefault +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview + +-- for zips, could optimize by calculating which one is shorter and +-- retaining its shape + +zip = zipUsingLists +zip3 = zip3UsingLists +zipWith = zipWithUsingLists +zipWith3 = zipWith3UsingLists +unzip = unzipUsingLists +unzip3 = unzip3UsingLists +unzipWith = unzipWithUsingLists +unzipWith3 = unzipWith3UsingLists + +-- invariants: +-- * list of complete binary trees in non-decreasing +-- order by size +-- * first argument to 'C' is the number +-- of nodes in the tree +structuralInvariant :: Seq t -> Bool +structuralInvariant E = True +structuralInvariant (C x t s) = x > 0 && checkTree x t && checkSeq x s + + where checkTree 1 (L _) = True + checkTree w (T _ l r) = + let w' = (w - 1) `div` 2 + in w' > 0 && checkTree w' l && checkTree w' r + checkTree _ _ = False + + checkSeq _ E = True + checkSeq x (C y t s) = + x <= y && checkTree y t && checkSeq y s + + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + return (fromList xs) + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary xs = coarbitrary (toList xs) + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/RevSeq.hs view
@@ -1,382 +1,399 @@--- |--- Module : Data.Edison.Seq.RevSeq--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ This module defines a sequence adaptor @Rev s@.--- If @s@ is a sequence type constructor, then @Rev s@--- is a sequence type constructor that is identical to @s@,--- except that it is kept in the opposite order.--- Also keeps explicit track of the size of the sequence,--- similar to the @Sized@ adaptor in "Data.Edison.Seq.SizedSeq".------ This module is most useful when s is a sequence type--- that offers fast access to the front but slow access--- to the rear, and your application needs the opposite--- (i.e., fast access to the rear but slow access to the--- front).------ All time complexities are determined by the underlying--- sequence, except that the complexities for accessing--- the left and right sides of the sequence are exchanged,--- and size becomes @O( 1 )@.--module Data.Edison.Seq.RevSeq (- -- * Rev Sequence Type- Rev, -- Rev s instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName,instanceName,-- -- * Other supported operations- fromSeq,toSeq--) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults -- only used by concatMap-import Control.Monad-import Data.Monoid-import Test.QuickCheck----- signatures for exported functions-moduleName :: String-instanceName :: S.Sequence s => Rev s a -> String-empty :: S.Sequence s => Rev s a-singleton :: S.Sequence s => a -> Rev s a-lcons :: S.Sequence s => a -> Rev s a -> Rev s a-rcons :: S.Sequence s => a -> Rev s a -> Rev s a-append :: S.Sequence s => Rev s a -> Rev s a -> Rev s a-lview :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a)-lhead :: S.Sequence s => Rev s a -> a-lheadM :: (S.Sequence s, Monad m) => Rev s a -> m a-ltail :: S.Sequence s => Rev s a -> Rev s a-ltailM :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a)-rview :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a)-rhead :: S.Sequence s => Rev s a -> a-rheadM :: (S.Sequence s, Monad m) => Rev s a -> m a-rtail :: S.Sequence s => Rev s a -> Rev s a-rtailM :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a)-null :: S.Sequence s => Rev s a -> Bool-size :: S.Sequence s => Rev s a -> Int-concat :: S.Sequence s => Rev s (Rev s a) -> Rev s a-reverse :: S.Sequence s => Rev s a -> Rev s a-reverseOnto :: S.Sequence s => Rev s a -> Rev s a -> Rev s a-fromList :: S.Sequence s => [a] -> Rev s a-toList :: S.Sequence s => Rev s a -> [a]-map :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b-concatMap :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b-fold :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-fold' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-fold1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-fold1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldr :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-foldl :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b-foldr1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldl1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-reducer :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reducel :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reduce1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldr' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b-foldl' :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b-foldr1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-foldl1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-reducer' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reducel' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a-reduce1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a-copy :: S.Sequence s => Int -> a -> Rev s a-inBounds :: S.Sequence s => Int -> Rev s a -> Bool-lookup :: S.Sequence s => Int -> Rev s a -> a-lookupM :: (S.Sequence s, Monad m) => Int -> Rev s a -> m a-lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a-update :: S.Sequence s => Int -> a -> Rev s a -> Rev s a-adjust :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a-mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b-foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b-foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b-foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b-foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b-take :: S.Sequence s => Int -> Rev s a -> Rev s a-drop :: S.Sequence s => Int -> Rev s a -> Rev s a-splitAt :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a)-subseq :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a-filter :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a-partition :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)-takeWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a-dropWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a-splitWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a)-zip :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b)-zip3 :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c)-zipWith :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c-zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d-unzip :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b)-unzip3 :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c)-unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c)-unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d)-strict :: S.Sequence s => Rev s a -> Rev s a-strictWith :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a-structuralInvariant :: S.Sequence s => Rev s a -> Bool---- bonus functions, not in Sequence signature-fromSeq :: S.Sequence s => s a -> Rev s a-toSeq :: S.Sequence s => Rev s a -> s a---moduleName = "Data.Edison.Seq.RevSeq"-instanceName (N _ s) = "RevSeq(" ++ S.instanceName s ++ ")"--data Rev s a = N !Int (s a)- -- The Int is the size minus one. The "minus one" makes indexing- -- calculations easier.--fromSeq xs = N (S.size xs - 1) xs-toSeq (N _ xs) = xs--empty = N (-1) S.empty-singleton x = N 0 (S.singleton x)-lcons x (N m xs) = N (m+1) (S.rcons x xs)-rcons x (N m xs) = N (m+1) (S.lcons x xs)-append (N m xs) (N n ys) = N (m+n+1) (S.append ys xs)--lview (N m xs) = case S.rview xs of- Nothing -> fail "RevSeq.lview: empty sequence"- Just (x,xs) -> return (x, N (m-1) xs)--lhead (N _ xs) = S.rhead xs--lheadM (N _ xs) = S.rheadM xs--ltail (N (-1) _) = error "RevSeq.ltail: empty sequence"-ltail (N m xs) = N (m-1) (S.rtail xs)--ltailM (N (-1) _) = fail "RevSeq.ltailM: empty sequence"-ltailM (N m xs) = return (N (m-1) (S.rtail xs))--rview (N m xs) = case S.lview xs of- Nothing -> fail "RevSeq.rview: empty sequence"- Just (x,xs) -> return (x, N (m-1) xs)--rhead (N _ xs) = S.lhead xs--rheadM (N _ xs) = S.lheadM xs--rtail (N (-1) _) = error "RevSeq.rtail: empty sequence"-rtail (N m xs) = N (m-1) (S.ltail xs)--rtailM (N (-1) _) = fail "RevSeq.rtailM: empty sequence"-rtailM (N m xs) = return (N (m-1) (S.ltail xs))--null (N m _) = m == -1-size (N m _) = m+1-concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss))-reverse (N m xs) = N m (S.reverse xs)-reverseOnto (N m xs) (N n ys) = N (m+n+1) (S.append ys (S.reverse xs))-fromList = fromSeq . S.fromList . L.reverse-toList (N _ xs) = S.foldl (flip (:)) [] xs-map f (N m xs) = N m (S.map f xs)--concatMap = concatMapUsingFoldr -- only function that uses a default--fold f e (N _ xs) = S.fold f e xs-fold' f e (N _ xs) = S.fold' f e xs-fold1 f (N _ xs) = S.fold1 f xs-fold1' f (N _ xs) = S.fold1' f xs-foldr f e (N _ xs) = S.foldl (flip f) e xs-foldr' f e (N _ xs) = S.foldl' (flip f) e xs-foldl f e (N _ xs) = S.foldr (flip f) e xs-foldl' f e (N _ xs) = S.foldr' (flip f) e xs-foldr1 f (N _ xs) = S.foldl1 (flip f) xs-foldr1' f (N _ xs) = S.foldl1' (flip f) xs-foldl1 f (N _ xs) = S.foldr1 (flip f) xs-foldl1' f (N _ xs) = S.foldr1' (flip f) xs-reducer f e (N _ xs) = S.reducel (flip f) e xs-reducer' f e (N _ xs) = S.reducel' (flip f) e xs-reducel f e (N _ xs) = S.reducer (flip f) e xs-reducel' f e (N _ xs) = S.reducer' (flip f) e xs-reduce1 f (N _ xs) = S.reduce1 (flip f) xs-reduce1' f (N _ xs) = S.reduce1' (flip f) xs--copy n x- | n <= 0 = empty- | otherwise = N (n-1) (S.copy n x)--inBounds i (N m _) = (i >= 0) && (i <= m)-lookup i (N m xs) = S.lookup (m-i) xs-lookupM i (N m xs) = S.lookupM (m-i) xs-lookupWithDefault d i (N m xs) = S.lookupWithDefault d (m-i) xs-update i x (N m xs) = N m (S.update (m-i) x xs)-adjust f i (N m xs) = N m (S.adjust f (m-i) xs)-mapWithIndex f (N m xs) = N m (S.mapWithIndex (f . (m-)) xs)--foldrWithIndex f e (N m xs) = S.foldlWithIndex f' e xs- where f' xs i x = f (m-i) x xs-foldrWithIndex' f e (N m xs) = S.foldlWithIndex' f' e xs- where f' xs i x = f (m-i) x xs--foldlWithIndex f e (N m xs) = S.foldrWithIndex f' e xs- where f' i x xs = f xs (m-i) x-foldlWithIndex' f e (N m xs) = S.foldrWithIndex' f' e xs- where f' i x xs = f xs (m-i) x--take i original@(N m xs)- | i <= 0 = empty- | i > m = original- | otherwise = N (i-1) (S.drop (m-i+1) xs)--drop i original@(N m xs)- | i <= 0 = original- | i > m = empty- | otherwise = N (m-i) (S.take (m-i+1) xs)--splitAt i original@(N m xs)- | i <= 0 = (empty, original)- | i > m = (original, empty)- | otherwise = let (ys,zs) = S.splitAt (m-i+1) xs- in (N (i-1) zs, N (m-i) ys)--subseq i len original@(N m xs)- | i <= 0 = take len original- | i > m || len <= 0 = empty- | i+len > m = N (m-i) (S.take (m-i+1) xs)- | otherwise = N (len-1) (S.subseq (m-i-len+1) len xs)--filter p = fromSeq . S.filter p . toSeq--partition p (N m xs) = (N (k-1) ys, N (m-k) zs)- where (ys,zs) = S.partition p xs- k = S.size ys--takeWhile p = fromSeq . S.reverse . S.takeWhile p . S.reverse . toSeq-dropWhile p = fromSeq . S.reverse . S.dropWhile p . S.reverse . toSeq--splitWhile p (N m xs) = (N (k-1) (S.reverse ys), N (m-k) (S.reverse zs))- where (ys,zs) = S.splitWhile p (S.reverse xs)- k = S.size ys--zip (N m xs) (N n ys)- | m < n = N m (S.zip xs (S.drop (n-m) ys))- | m > n = N n (S.zip (S.drop (m-n) xs) ys)- | otherwise = N m (S.zip xs ys)-zip3 (N l xs) (N m ys) (N n zs) = N k (S.zip3 xs' ys' zs')- where k = min l (min m n)- xs' = if l == k then xs else S.drop (l-k) xs- ys' = if m == k then ys else S.drop (m-k) ys- zs' = if n == k then zs else S.drop (n-k) zs--zipWith f (N m xs) (N n ys)- | m < n = N m (S.zipWith f xs (S.drop (n-m) ys))- | m > n = N n (S.zipWith f (S.drop (m-n) xs) ys)- | otherwise = N m (S.zipWith f xs ys)-zipWith3 f (N l xs) (N m ys) (N n zs) = N k (S.zipWith3 f xs' ys' zs')- where k = min l (min m n)- xs' = if l == k then xs else S.drop (l-k) xs- ys' = if m == k then ys else S.drop (m-k) ys- zs' = if n == k then zs else S.drop (n-k) zs--unzip (N m xys) = (N m xs, N m ys)- where (xs,ys) = S.unzip xys--unzip3 (N m xyzs) = (N m xs, N m ys, N m zs)- where (xs,ys,zs) = S.unzip3 xyzs--unzipWith f g (N m xys) = (N m xs, N m ys)- where (xs,ys) = S.unzipWith f g xys--unzipWith3 f g h (N m xyzs) = (N m xs, N m ys, N m zs)- where (xs,ys,zs) = S.unzipWith3 f g h xyzs--strict s@(N _ s') = S.strict s' `seq` s-strictWith f s@(N _ s') = S.strictWith f s' `seq` s--structuralInvariant (N i s) = i == ((S.size s) - 1)---- instances--instance S.Sequence s => S.Sequence (Rev s) where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName = instanceName}--instance S.Sequence s => Functor (Rev s) where- fmap = map--instance S.Sequence s => Monad (Rev s) where- return = singleton- xs >>= k = concatMap k xs--instance S.Sequence s => MonadPlus (Rev s) where- mplus = append- mzero = empty--instance Eq (s a) => Eq (Rev s a) where- (N m xs) == (N n ys) = (m == n) && (xs == ys)--instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Rev s a) where- compare = defaultCompare--instance (S.Sequence s, Show (s a)) => Show (Rev s a) where- showsPrec i xs rest- | i == 0 = L.concat [ moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]- | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]--instance (S.Sequence s, Read (s a)) => Read (Rev s a) where- readsPrec _ xs = maybeParens p xs- where p xs = tokenMatch (moduleName++".fromSeq") xs- >>= readsPrec 10- >>= \(l,rest) -> return (fromSeq l,rest)--instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Rev s a) where- arbitrary = do xs <- arbitrary- return (fromSeq xs)--instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Rev s a) where- coarbitrary xs = coarbitrary (toSeq xs)--instance S.Sequence s => Monoid (Rev s a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.RevSeq +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module defines a sequence adaptor @Rev s@. +-- If @s@ is a sequence type constructor, then @Rev s@ +-- is a sequence type constructor that is identical to @s@, +-- except that it is kept in the opposite order. +-- Also keeps explicit track of the size of the sequence, +-- similar to the @Sized@ adaptor in "Data.Edison.Seq.SizedSeq". +-- +-- This module is most useful when s is a sequence type +-- that offers fast access to the front but slow access +-- to the rear, and your application needs the opposite +-- (i.e., fast access to the rear but slow access to the +-- front). +-- +-- All time complexities are determined by the underlying +-- sequence, except that the complexities for accessing +-- the left and right sides of the sequence are exchanged, +-- and size becomes @O( 1 )@. + +module Data.Edison.Seq.RevSeq ( + -- * Rev Sequence Type + Rev, -- Rev s instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName,instanceName, + + -- * Other supported operations + fromSeq,toSeq + +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App + +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults -- only used by concatMap +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Data.Monoid +import Data.Semigroup as SG +import Test.QuickCheck + + +-- signatures for exported functions +moduleName :: String +instanceName :: S.Sequence s => Rev s a -> String +empty :: S.Sequence s => Rev s a +singleton :: S.Sequence s => a -> Rev s a +lcons :: S.Sequence s => a -> Rev s a -> Rev s a +rcons :: S.Sequence s => a -> Rev s a -> Rev s a +append :: S.Sequence s => Rev s a -> Rev s a -> Rev s a +lview :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (a, Rev s a) +lhead :: S.Sequence s => Rev s a -> a +lheadM :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m a +ltail :: S.Sequence s => Rev s a -> Rev s a +ltailM :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (Rev s a) +rview :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (a, Rev s a) +rhead :: S.Sequence s => Rev s a -> a +rheadM :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m a +rtail :: S.Sequence s => Rev s a -> Rev s a +rtailM :: (S.Sequence s, Fail.MonadFail m) => Rev s a -> m (Rev s a) +null :: S.Sequence s => Rev s a -> Bool +size :: S.Sequence s => Rev s a -> Int +concat :: S.Sequence s => Rev s (Rev s a) -> Rev s a +reverse :: S.Sequence s => Rev s a -> Rev s a +reverseOnto :: S.Sequence s => Rev s a -> Rev s a -> Rev s a +fromList :: S.Sequence s => [a] -> Rev s a +toList :: S.Sequence s => Rev s a -> [a] +map :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b +concatMap :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b +fold :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +fold' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +fold1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +fold1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldr :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +foldl :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b +foldr1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldl1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +reducer :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reducel :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reduce1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldr' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +foldl' :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b +foldr1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldl1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +reducer' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reducel' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reduce1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +copy :: S.Sequence s => Int -> a -> Rev s a +inBounds :: S.Sequence s => Int -> Rev s a -> Bool +lookup :: S.Sequence s => Int -> Rev s a -> a +lookupM :: (S.Sequence s, Fail.MonadFail m) => Int -> Rev s a -> m a +lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a +update :: S.Sequence s => Int -> a -> Rev s a -> Rev s a +adjust :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a +mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b +foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b +foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b +foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b +foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b +take :: S.Sequence s => Int -> Rev s a -> Rev s a +drop :: S.Sequence s => Int -> Rev s a -> Rev s a +splitAt :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a) +subseq :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a +filter :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a +partition :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a) +takeWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a +dropWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a +splitWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a) +zip :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b) +zip3 :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c) +zipWith :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c +zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d +unzip :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b) +unzip3 :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c) +unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c) +unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d) +strict :: S.Sequence s => Rev s a -> Rev s a +strictWith :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a +structuralInvariant :: S.Sequence s => Rev s a -> Bool + +-- bonus functions, not in Sequence signature +fromSeq :: S.Sequence s => s a -> Rev s a +toSeq :: S.Sequence s => Rev s a -> s a + + +moduleName = "Data.Edison.Seq.RevSeq" +instanceName (N _ s) = "RevSeq(" ++ S.instanceName s ++ ")" + +data Rev s a = N !Int (s a) + -- The Int is the size minus one. The "minus one" makes indexing + -- calculations easier. + +fromSeq xs = N (S.size xs - 1) xs +toSeq (N _ xs) = xs + +empty = N (-1) S.empty +singleton x = N 0 (S.singleton x) +lcons x (N m xs) = N (m+1) (S.rcons x xs) +rcons x (N m xs) = N (m+1) (S.lcons x xs) +append (N m xs) (N n ys) = N (m+n+1) (S.append ys xs) + +lview (N m xs) = case S.rview xs of + Nothing -> fail "RevSeq.lview: empty sequence" + Just (x,xs) -> return (x, N (m-1) xs) + +lhead (N _ xs) = S.rhead xs + +lheadM (N _ xs) = S.rheadM xs + +ltail (N (-1) _) = error "RevSeq.ltail: empty sequence" +ltail (N m xs) = N (m-1) (S.rtail xs) + +ltailM (N (-1) _) = fail "RevSeq.ltailM: empty sequence" +ltailM (N m xs) = return (N (m-1) (S.rtail xs)) + +rview (N m xs) = case S.lview xs of + Nothing -> fail "RevSeq.rview: empty sequence" + Just (x,xs) -> return (x, N (m-1) xs) + +rhead (N _ xs) = S.lhead xs + +rheadM (N _ xs) = S.lheadM xs + +rtail (N (-1) _) = error "RevSeq.rtail: empty sequence" +rtail (N m xs) = N (m-1) (S.ltail xs) + +rtailM (N (-1) _) = fail "RevSeq.rtailM: empty sequence" +rtailM (N m xs) = return (N (m-1) (S.ltail xs)) + +null (N m _) = m == -1 +size (N m _) = m+1 +concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss)) +reverse (N m xs) = N m (S.reverse xs) +reverseOnto (N m xs) (N n ys) = N (m+n+1) (S.append ys (S.reverse xs)) +fromList = fromSeq . S.fromList . L.reverse +toList (N _ xs) = S.foldl (flip (:)) [] xs +map f (N m xs) = N m (S.map f xs) + +concatMap = concatMapUsingFoldr -- only function that uses a default + +fold f e (N _ xs) = S.fold f e xs +fold' f e (N _ xs) = S.fold' f e xs +fold1 f (N _ xs) = S.fold1 f xs +fold1' f (N _ xs) = S.fold1' f xs +foldr f e (N _ xs) = S.foldl (flip f) e xs +foldr' f e (N _ xs) = S.foldl' (flip f) e xs +foldl f e (N _ xs) = S.foldr (flip f) e xs +foldl' f e (N _ xs) = S.foldr' (flip f) e xs +foldr1 f (N _ xs) = S.foldl1 (flip f) xs +foldr1' f (N _ xs) = S.foldl1' (flip f) xs +foldl1 f (N _ xs) = S.foldr1 (flip f) xs +foldl1' f (N _ xs) = S.foldr1' (flip f) xs +reducer f e (N _ xs) = S.reducel (flip f) e xs +reducer' f e (N _ xs) = S.reducel' (flip f) e xs +reducel f e (N _ xs) = S.reducer (flip f) e xs +reducel' f e (N _ xs) = S.reducer' (flip f) e xs +reduce1 f (N _ xs) = S.reduce1 (flip f) xs +reduce1' f (N _ xs) = S.reduce1' (flip f) xs + +copy n x + | n <= 0 = empty + | otherwise = N (n-1) (S.copy n x) + +inBounds i (N m _) = (i >= 0) && (i <= m) +lookup i (N m xs) = S.lookup (m-i) xs +lookupM i (N m xs) = S.lookupM (m-i) xs +lookupWithDefault d i (N m xs) = S.lookupWithDefault d (m-i) xs +update i x (N m xs) = N m (S.update (m-i) x xs) +adjust f i (N m xs) = N m (S.adjust f (m-i) xs) +mapWithIndex f (N m xs) = N m (S.mapWithIndex (f . (m-)) xs) + +foldrWithIndex f e (N m xs) = S.foldlWithIndex f' e xs + where f' xs i x = f (m-i) x xs +foldrWithIndex' f e (N m xs) = S.foldlWithIndex' f' e xs + where f' xs i x = f (m-i) x xs + +foldlWithIndex f e (N m xs) = S.foldrWithIndex f' e xs + where f' i x xs = f xs (m-i) x +foldlWithIndex' f e (N m xs) = S.foldrWithIndex' f' e xs + where f' i x xs = f xs (m-i) x + +take i original@(N m xs) + | i <= 0 = empty + | i > m = original + | otherwise = N (i-1) (S.drop (m-i+1) xs) + +drop i original@(N m xs) + | i <= 0 = original + | i > m = empty + | otherwise = N (m-i) (S.take (m-i+1) xs) + +splitAt i original@(N m xs) + | i <= 0 = (empty, original) + | i > m = (original, empty) + | otherwise = let (ys,zs) = S.splitAt (m-i+1) xs + in (N (i-1) zs, N (m-i) ys) + +subseq i len original@(N m xs) + | i <= 0 = take len original + | i > m || len <= 0 = empty + | i+len > m = N (m-i) (S.take (m-i+1) xs) + | otherwise = N (len-1) (S.subseq (m-i-len+1) len xs) + +filter p = fromSeq . S.filter p . toSeq + +partition p (N m xs) = (N (k-1) ys, N (m-k) zs) + where (ys,zs) = S.partition p xs + k = S.size ys + +takeWhile p = fromSeq . S.reverse . S.takeWhile p . S.reverse . toSeq +dropWhile p = fromSeq . S.reverse . S.dropWhile p . S.reverse . toSeq + +splitWhile p (N m xs) = (N (k-1) (S.reverse ys), N (m-k) (S.reverse zs)) + where (ys,zs) = S.splitWhile p (S.reverse xs) + k = S.size ys + +zip (N m xs) (N n ys) + | m < n = N m (S.zip xs (S.drop (n-m) ys)) + | m > n = N n (S.zip (S.drop (m-n) xs) ys) + | otherwise = N m (S.zip xs ys) +zip3 (N l xs) (N m ys) (N n zs) = N k (S.zip3 xs' ys' zs') + where k = min l (min m n) + xs' = if l == k then xs else S.drop (l-k) xs + ys' = if m == k then ys else S.drop (m-k) ys + zs' = if n == k then zs else S.drop (n-k) zs + +zipWith f (N m xs) (N n ys) + | m < n = N m (S.zipWith f xs (S.drop (n-m) ys)) + | m > n = N n (S.zipWith f (S.drop (m-n) xs) ys) + | otherwise = N m (S.zipWith f xs ys) +zipWith3 f (N l xs) (N m ys) (N n zs) = N k (S.zipWith3 f xs' ys' zs') + where k = min l (min m n) + xs' = if l == k then xs else S.drop (l-k) xs + ys' = if m == k then ys else S.drop (m-k) ys + zs' = if n == k then zs else S.drop (n-k) zs + +unzip (N m xys) = (N m xs, N m ys) + where (xs,ys) = S.unzip xys + +unzip3 (N m xyzs) = (N m xs, N m ys, N m zs) + where (xs,ys,zs) = S.unzip3 xyzs + +unzipWith f g (N m xys) = (N m xs, N m ys) + where (xs,ys) = S.unzipWith f g xys + +unzipWith3 f g h (N m xyzs) = (N m xs, N m ys, N m zs) + where (xs,ys,zs) = S.unzipWith3 f g h xyzs + +strict s@(N _ s') = S.strict s' `seq` s +strictWith f s@(N _ s') = S.strictWith f s' `seq` s + +structuralInvariant (N i s) = i == ((S.size s) - 1) + +-- instances + +instance S.Sequence s => S.Sequence (Rev s) where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName = instanceName} + +instance S.Sequence s => Functor (Rev s) where + fmap = map + +instance S.Sequence s => App.Alternative (Rev s) where + empty = empty + (<|>) = append + +instance S.Sequence s => App.Applicative (Rev s) where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance S.Sequence s => Monad (Rev s) where + return = singleton + xs >>= k = concatMap k xs + +instance S.Sequence s => MonadPlus (Rev s) where + mplus = append + mzero = empty + +instance Eq (s a) => Eq (Rev s a) where + (N m xs) == (N n ys) = (m == n) && (xs == ys) + +instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Rev s a) where + compare = defaultCompare + +instance (S.Sequence s, Show (s a)) => Show (Rev s a) where + showsPrec i xs rest + | i == 0 = L.concat [ moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest] + | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)] + +instance (S.Sequence s, Read (s a)) => Read (Rev s a) where + readsPrec _ xs = maybeParens p xs + where p xs = tokenMatch (moduleName++".fromSeq") xs + >>= readsPrec 10 + >>= \(l,rest) -> return (fromSeq l,rest) + +instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Rev s a) where + arbitrary = do xs <- arbitrary + return (fromSeq xs) + +instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Rev s a) where + coarbitrary xs = coarbitrary (toSeq xs) + +instance S.Sequence s => Semigroup (Rev s a) where + (<>) = append +instance S.Sequence s => Monoid (Rev s a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/SimpleQueue.hs view
@@ -1,374 +1,391 @@--- |--- Module : Data.Edison.Seq.SimpleQueue--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ Simple Queues. All operations have running times as listed in--- "Data.Edison.Seq" except for the following:------ * rcons, fromList @O( 1 )@------ * lview, ltail* @O( 1 )@ if single threaded, @O( n )@ otherwise------ * inBounds, lookup, update, drop, splitAt @O( n )@------ /References:/------ * Chris Okasaki. /Purely Functional Data Structures/. 1998.--- Section 5.2.------ * F. Warren Burton. \"An efficient functional implementation of FIFO queues\".--- /Information Processing Letters/, 14(5):205-206, July 1982.--module Data.Edison.Seq.SimpleQueue (- -- * Sequence Type- Seq, -- instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S ( Sequence(..) )-import Data.Edison.Seq.Defaults-import qualified Data.Edison.Seq.ListSeq as L-import Data.Monoid-import Control.Monad-import Test.QuickCheck---- signatures for exported functions-moduleName :: String-empty :: Seq a-singleton :: a -> Seq a-lcons :: a -> Seq a -> Seq a-rcons :: a -> Seq a -> Seq a-append :: Seq a -> Seq a -> Seq a-lview :: (Monad m) => Seq a -> m (a, Seq a)-lhead :: Seq a -> a-lheadM :: (Monad m) => Seq a -> m a-ltail :: Seq a -> Seq a-ltailM :: (Monad m) => Seq a -> m (Seq a)-rview :: (Monad m) => Seq a -> m (a, Seq a)-rhead :: Seq a -> a-rheadM :: (Monad m) => Seq a -> m a-rtail :: Seq a -> Seq a-rtailM :: (Monad m) => Seq a -> m (Seq a)-null :: Seq a -> Bool-size :: Seq a -> Int-concat :: Seq (Seq a) -> Seq a-reverse :: Seq a -> Seq a-reverseOnto :: Seq a -> Seq a -> Seq a-fromList :: [a] -> Seq a-toList :: Seq a -> [a]-map :: (a -> b) -> Seq a -> Seq b-concatMap :: (a -> Seq b) -> Seq a -> Seq b-fold :: (a -> b -> b) -> b -> Seq a -> b-fold' :: (a -> b -> b) -> b -> Seq a -> b-fold1 :: (a -> a -> a) -> Seq a -> a-fold1' :: (a -> a -> a) -> Seq a -> a-foldr :: (a -> b -> b) -> b -> Seq a -> b-foldl :: (b -> a -> b) -> b -> Seq a -> b-foldr1 :: (a -> a -> a) -> Seq a -> a-foldl1 :: (a -> a -> a) -> Seq a -> a-reducer :: (a -> a -> a) -> a -> Seq a -> a-reducel :: (a -> a -> a) -> a -> Seq a -> a-reduce1 :: (a -> a -> a) -> Seq a -> a-foldr' :: (a -> b -> b) -> b -> Seq a -> b-foldl' :: (b -> a -> b) -> b -> Seq a -> b-foldr1' :: (a -> a -> a) -> Seq a -> a-foldl1' :: (a -> a -> a) -> Seq a -> a-reducer' :: (a -> a -> a) -> a -> Seq a -> a-reducel' :: (a -> a -> a) -> a -> Seq a -> a-reduce1' :: (a -> a -> a) -> Seq a -> a-copy :: Int -> a -> Seq a-inBounds :: Int -> Seq a -> Bool-lookup :: Int -> Seq a -> a-lookupM :: (Monad m) => Int -> Seq a -> m a-lookupWithDefault :: a -> Int -> Seq a -> a-update :: Int -> a -> Seq a -> Seq a-adjust :: (a -> a) -> Int -> Seq a -> Seq a-mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b-foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b-foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b-foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b-take :: Int -> Seq a -> Seq a-drop :: Int -> Seq a -> Seq a-splitAt :: Int -> Seq a -> (Seq a, Seq a)-subseq :: Int -> Int -> Seq a -> Seq a-filter :: (a -> Bool) -> Seq a -> Seq a-partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-takeWhile :: (a -> Bool) -> Seq a -> Seq a-dropWhile :: (a -> Bool) -> Seq a -> Seq a-splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a)-zip :: Seq a -> Seq b -> Seq (a,b)-zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)-zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c-zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d-unzip :: Seq (a,b) -> (Seq a, Seq b)-unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)-unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)-unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)-strict :: Seq a -> Seq a-strictWith :: (a -> b) -> Seq a -> Seq a-structuralInvariant :: Seq a -> Bool--moduleName = "Data.Edison.Seq.SimpleQueue"---data Seq a = Q [a] [a]- -- invariant: front empty only if rear also empty---- not exported-makeQ :: [a] -> [a] -> Seq a-makeQ [] ys = Q (L.reverse ys) []-makeQ xs ys = Q xs ys--empty = Q [] []-singleton x = Q [x] []-lcons x (Q xs ys) = Q (x:xs) ys--rcons y (Q [] _) = Q [y] []-rcons y (Q xs ys) = Q xs (y:ys)--append (Q xs1 ys1) (Q xs2 ys2) =- Q (xs1 ++ L.reverseOnto ys1 xs2) ys2--lview (Q [] _) = fail "SimpleQueue.lview: empty sequence"-lview (Q [x] ys) = return (x, Q (L.reverse ys) [])-lview (Q (x:xs) ys) = return (x, Q xs ys)--lhead (Q [] _) = error "SimpleQueue.lhead: empty sequence"-lhead (Q (x:_) _) = x--lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence"-lheadM (Q (x:_) _) = return x--ltail (Q [_] ys) = Q (L.reverse ys) []-ltail (Q (_:xs) ys) = Q xs ys-ltail (Q [] _) = error "SimpleQueue.ltail: empty sequence"--ltailM (Q [_] ys) = return (Q (L.reverse ys) [])-ltailM (Q (_:xs) ys) = return (Q xs ys)-ltailM (Q [] _) = fail "SimpleQueue.ltailM: empty sequence"--rview (Q xs (y:ys)) = return (y, Q xs ys)-rview (Q xs []) =- case L.rview xs of- Nothing -> fail "SimpleQueue.rview: empty sequence"- Just (x,xs') -> return (x, Q xs' [])--rhead (Q _ (y:_)) = y-rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence"-rhead (Q xs []) = L.rhead xs--rheadM (Q _ (y:_)) = return y-rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence"-rheadM (Q xs []) = return (L.rhead xs)--rtail (Q xs (_:ys)) = Q xs ys-rtail (Q [] []) = error "SimpleQueue.rtail: empty sequence"-rtail (Q xs []) = Q (L.rtail xs) []--rtailM (Q xs (_:ys)) = return (Q xs ys)-rtailM (Q [] []) = fail "SimpleQueue.rtailM: empty sequence"-rtailM (Q xs []) = return (Q (L.rtail xs) [])--null (Q [] _) = True-null _ = False--size (Q xs ys) = length xs + length ys--reverse (Q xs []) = Q (L.reverse xs) []-reverse (Q xs ys) = Q ys xs--reverseOnto (Q xs1 ys1) (Q xs2 ys2) =- Q (ys1 ++ L.reverseOnto xs1 xs2) ys2--fromList xs = Q xs []--toList (Q xs []) = xs-toList (Q xs ys) = xs ++ L.reverse ys--map f (Q xs ys) = Q (L.map f xs) (L.map f ys)---- local fn on lists-revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1-revfoldr _ e [] = e-revfoldr f e (x:xs) = revfoldr f (f x e) xs--revfoldr' :: (t -> a -> a) -> a -> [t] -> a-revfoldr' _ e [] = e-revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs---- local fn on lists-revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t-revfoldl _ e [] = e-revfoldl f e (x:xs) = f (revfoldl f e xs) x--revfoldl' :: (a -> t -> a) -> a -> [t] -> a-revfoldl' _ e [] = e-revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x--fold f e (Q xs ys) = L.foldr f (L.foldr f e ys) xs-fold' f e (Q xs ys) = L.foldl' (flip f) (L.foldl' (flip f) e ys) xs-fold1 = fold1UsingFold-fold1' = fold1'UsingFold'--foldr f e (Q xs ys) = L.foldr f (revfoldr f e ys) xs-foldr' f e (Q xs ys) = L.foldr' f (revfoldr' f e ys) xs--foldl f e (Q xs ys) = revfoldl f (L.foldl f e xs) ys-foldl' f e (Q xs ys) = revfoldl' f (L.foldl' f e xs) ys--foldr1 f (Q xs (y:ys)) = L.foldr f (revfoldr f y ys) xs-foldr1 _ (Q [] []) = error "SimpleQueue.foldr1: empty sequence"-foldr1 f (Q xs []) = L.foldr1 f xs--foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs-foldr1' _ (Q [] []) = error "SimpleQueye.foldr1': empty sequence"-foldr1' f (Q xs []) = L.foldr1' f xs--foldl1 f (Q (x:xs) ys) = revfoldl f (L.foldl f x xs) ys-foldl1 _ (Q [] _) = error "SimpleQueue.foldl1: empty sequence"--foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys-foldl1' _ (Q [] _) = error "SimpleQueue.foldl1': empty sequence"--filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys)--partition p (Q xs ys)- = (makeQ xsT ysT, makeQ xsF ysF)- where- (xsT,xsF) = L.partition p xs- (ysT,ysF) = L.partition p ys--strict s@(Q xs ys) = L.strict xs `seq` L.strict ys `seq` s-strictWith f s@(Q xs ys) = L.strictWith f xs `seq` L.strictWith f ys `seq` s---- the remaining functions all use defaults--concat = concatUsingFoldr-concatMap = concatMapUsingFoldr-reducer = reducerUsingReduce1-reducer' = reducer'UsingReduce1'-reducel = reducelUsingReduce1-reducel' = reducel'UsingReduce1'-reduce1 = reduce1UsingLists-reduce1' = reduce1'UsingLists-copy = copyUsingLists-inBounds = inBoundsUsingLookupM-lookup = lookupUsingLookupM-lookupM = lookupMUsingDrop-lookupWithDefault = lookupWithDefaultUsingLookupM-update = updateUsingAdjust-adjust = adjustUsingLists-mapWithIndex = mapWithIndexUsingLists-foldrWithIndex = foldrWithIndexUsingLists-foldrWithIndex' = foldrWithIndex'UsingLists-foldlWithIndex = foldlWithIndexUsingLists-foldlWithIndex' = foldlWithIndex'UsingLists-take = takeUsingLists-drop = dropUsingLists-splitAt = splitAtDefault-subseq = subseqDefault-takeWhile = takeWhileUsingLview-dropWhile = dropWhileUsingLview-splitWhile = splitWhileUsingLview-zip = zipUsingLists-zip3 = zip3UsingLists-zipWith = zipWithUsingLists-zipWith3 = zipWith3UsingLists-unzip = unzipUsingLists-unzip3 = unzip3UsingLists-unzipWith = unzipWithUsingLists-unzipWith3 = unzipWith3UsingLists---- invariant:--- * front empty only if rear also empty--structuralInvariant (Q x y) = not (L.null x) || L.null y---- instances--instance S.Sequence Seq where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName _ = moduleName}--instance Functor Seq where- fmap = map--instance Monad Seq where- return = singleton- xs >>= k = concatMap k xs--instance MonadPlus Seq where- mplus = append- mzero = empty--instance Eq a => Eq (Seq a) where- q1 == q2 = toList q1 == toList q2--instance Ord a => Ord (Seq a) where- compare = defaultCompare--instance Show a => Show (Seq a) where- showsPrec = showsPrecUsingToList--instance Read a => Read (Seq a) where- readsPrec = readsPrecUsingFromList--instance Arbitrary a => Arbitrary (Seq a) where- arbitrary = do xs <- arbitrary- ys <- arbitrary- return (if L.null xs then Q ys [] else Q xs ys)--instance CoArbitrary a => CoArbitrary (Seq a) where- coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys--instance Monoid (Seq a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.SimpleQueue +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Simple Queues. All operations have running times as listed in +-- "Data.Edison.Seq" except for the following: +-- +-- * rcons, fromList @O( 1 )@ +-- +-- * lview, ltail* @O( 1 )@ if single threaded, @O( n )@ otherwise +-- +-- * inBounds, lookup, update, drop, splitAt @O( n )@ +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. +-- Section 5.2. +-- +-- * F. Warren Burton. \"An efficient functional implementation of FIFO queues\". +-- /Information Processing Letters/, 14(5):205-206, July 1982. + +module Data.Edison.Seq.SimpleQueue ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App + +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Data.Edison.Seq.ListSeq as L +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Fail.MonadFail m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +rview :: (Fail.MonadFail m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Fail.MonadFail m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Fail.MonadFail m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Fail.MonadFail m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.SimpleQueue" + + +data Seq a = Q [a] [a] + -- invariant: front empty only if rear also empty + +-- not exported +makeQ :: [a] -> [a] -> Seq a +makeQ [] ys = Q (L.reverse ys) [] +makeQ xs ys = Q xs ys + +empty = Q [] [] +singleton x = Q [x] [] +lcons x (Q xs ys) = Q (x:xs) ys + +rcons y (Q [] _) = Q [y] [] +rcons y (Q xs ys) = Q xs (y:ys) + +append (Q xs1 ys1) (Q xs2 ys2) = + Q (xs1 ++ L.reverseOnto ys1 xs2) ys2 + +lview (Q [] _) = fail "SimpleQueue.lview: empty sequence" +lview (Q [x] ys) = return (x, Q (L.reverse ys) []) +lview (Q (x:xs) ys) = return (x, Q xs ys) + +lhead (Q [] _) = error "SimpleQueue.lhead: empty sequence" +lhead (Q (x:_) _) = x + +lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence" +lheadM (Q (x:_) _) = return x + +ltail (Q [_] ys) = Q (L.reverse ys) [] +ltail (Q (_:xs) ys) = Q xs ys +ltail (Q [] _) = error "SimpleQueue.ltail: empty sequence" + +ltailM (Q [_] ys) = return (Q (L.reverse ys) []) +ltailM (Q (_:xs) ys) = return (Q xs ys) +ltailM (Q [] _) = fail "SimpleQueue.ltailM: empty sequence" + +rview (Q xs (y:ys)) = return (y, Q xs ys) +rview (Q xs []) = + case L.rview xs of + Nothing -> fail "SimpleQueue.rview: empty sequence" + Just (x,xs') -> return (x, Q xs' []) + +rhead (Q _ (y:_)) = y +rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence" +rhead (Q xs []) = L.rhead xs + +rheadM (Q _ (y:_)) = return y +rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence" +rheadM (Q xs []) = return (L.rhead xs) + +rtail (Q xs (_:ys)) = Q xs ys +rtail (Q [] []) = error "SimpleQueue.rtail: empty sequence" +rtail (Q xs []) = Q (L.rtail xs) [] + +rtailM (Q xs (_:ys)) = return (Q xs ys) +rtailM (Q [] []) = fail "SimpleQueue.rtailM: empty sequence" +rtailM (Q xs []) = return (Q (L.rtail xs) []) + +null (Q [] _) = True +null _ = False + +size (Q xs ys) = length xs + length ys + +reverse (Q xs []) = Q (L.reverse xs) [] +reverse (Q xs ys) = Q ys xs + +reverseOnto (Q xs1 ys1) (Q xs2 ys2) = + Q (ys1 ++ L.reverseOnto xs1 xs2) ys2 + +fromList xs = Q xs [] + +toList (Q xs []) = xs +toList (Q xs ys) = xs ++ L.reverse ys + +map f (Q xs ys) = Q (L.map f xs) (L.map f ys) + +-- local fn on lists +revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1 +revfoldr _ e [] = e +revfoldr f e (x:xs) = revfoldr f (f x e) xs + +revfoldr' :: (t -> a -> a) -> a -> [t] -> a +revfoldr' _ e [] = e +revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs + +-- local fn on lists +revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t +revfoldl _ e [] = e +revfoldl f e (x:xs) = f (revfoldl f e xs) x + +revfoldl' :: (a -> t -> a) -> a -> [t] -> a +revfoldl' _ e [] = e +revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x + +fold f e (Q xs ys) = L.foldr f (L.foldr f e ys) xs +fold' f e (Q xs ys) = L.foldl' (flip f) (L.foldl' (flip f) e ys) xs +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr f e (Q xs ys) = L.foldr f (revfoldr f e ys) xs +foldr' f e (Q xs ys) = L.foldr' f (revfoldr' f e ys) xs + +foldl f e (Q xs ys) = revfoldl f (L.foldl f e xs) ys +foldl' f e (Q xs ys) = revfoldl' f (L.foldl' f e xs) ys + +foldr1 f (Q xs (y:ys)) = L.foldr f (revfoldr f y ys) xs +foldr1 _ (Q [] []) = error "SimpleQueue.foldr1: empty sequence" +foldr1 f (Q xs []) = L.foldr1 f xs + +foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs +foldr1' _ (Q [] []) = error "SimpleQueye.foldr1': empty sequence" +foldr1' f (Q xs []) = L.foldr1' f xs + +foldl1 f (Q (x:xs) ys) = revfoldl f (L.foldl f x xs) ys +foldl1 _ (Q [] _) = error "SimpleQueue.foldl1: empty sequence" + +foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys +foldl1' _ (Q [] _) = error "SimpleQueue.foldl1': empty sequence" + +filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys) + +partition p (Q xs ys) + = (makeQ xsT ysT, makeQ xsF ysF) + where + (xsT,xsF) = L.partition p xs + (ysT,ysF) = L.partition p ys + +strict s@(Q xs ys) = L.strict xs `seq` L.strict ys `seq` s +strictWith f s@(Q xs ys) = L.strictWith f xs `seq` L.strictWith f ys `seq` s + +-- the remaining functions all use defaults + +concat = concatUsingFoldr +concatMap = concatMapUsingFoldr +reducer = reducerUsingReduce1 +reducer' = reducer'UsingReduce1' +reducel = reducelUsingReduce1 +reducel' = reducel'UsingReduce1' +reduce1 = reduce1UsingLists +reduce1' = reduce1'UsingLists +copy = copyUsingLists +inBounds = inBoundsUsingLookupM +lookup = lookupUsingLookupM +lookupM = lookupMUsingDrop +lookupWithDefault = lookupWithDefaultUsingLookupM +update = updateUsingAdjust +adjust = adjustUsingLists +mapWithIndex = mapWithIndexUsingLists +foldrWithIndex = foldrWithIndexUsingLists +foldrWithIndex' = foldrWithIndex'UsingLists +foldlWithIndex = foldlWithIndexUsingLists +foldlWithIndex' = foldlWithIndex'UsingLists +take = takeUsingLists +drop = dropUsingLists +splitAt = splitAtDefault +subseq = subseqDefault +takeWhile = takeWhileUsingLview +dropWhile = dropWhileUsingLview +splitWhile = splitWhileUsingLview +zip = zipUsingLists +zip3 = zip3UsingLists +zipWith = zipWithUsingLists +zipWith3 = zipWith3UsingLists +unzip = unzipUsingLists +unzip3 = unzip3UsingLists +unzipWith = unzipWithUsingLists +unzipWith3 = unzipWith3UsingLists + +-- invariant: +-- * front empty only if rear also empty + +structuralInvariant (Q x y) = not (L.null x) || L.null y + +-- instances + +instance S.Sequence Seq where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName _ = moduleName} + +instance Functor Seq where + fmap = map + +instance App.Alternative Seq where + empty = empty + (<|>) = append + +instance App.Applicative Seq where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + q1 == q2 = toList q1 == toList q2 + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + ys <- arbitrary + return (if L.null xs then Q ys [] else Q xs ys) + +instance CoArbitrary a => CoArbitrary (Seq a) where + coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys + +instance Semigroup (Seq a) where + (<>) = append +instance Monoid (Seq a) where + mempty = empty + mappend = (SG.<>)
src/Data/Edison/Seq/SizedSeq.hs view
@@ -1,355 +1,373 @@--- |--- Module : Data.Edison.Seq.SizedSeq--- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki--- License : MIT; see COPYRIGHT file for terms and conditions------ Maintainer : robdockins AT fastmail DOT fm--- Stability : stable--- Portability : GHC, Hugs (MPTC and FD)------ This module defines a sequence adaptor @Sized s@.--- If @s@ is a sequence type constructor, then @Sized s@--- is a sequence type constructor that is identical to @s@,--- except that it also keeps track of the current size of--- each sequence.------ All time complexities are determined by the underlying--- sequence, except that size becomes @O( 1 )@.--module Data.Edison.Seq.SizedSeq (- -- * Sized Sequence Type- Sized, -- Sized s instance of Sequence, Functor, Monad, MonadPlus-- -- * Sequence Operations- empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,- lheadM,ltailM,rheadM,rtailM,- null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,- fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',- reducer,reducer',reducel,reducel',reduce1,reduce1',- copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,- mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex',- take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,- zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,- strict, strictWith,-- -- * Unit testing- structuralInvariant,-- -- * Documentation- moduleName,instanceName,-- -- * Other supported operations- fromSeq,toSeq-) where--import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,- filter,takeWhile,dropWhile,lookup,take,drop,splitAt,- zip,zip3,zipWith,zipWith3,unzip,unzip3,null)--import qualified Data.Edison.Seq as S-import qualified Data.Edison.Seq.ListSeq as L-import Data.Edison.Seq.Defaults -- only used by concatMap-import Data.Monoid-import Control.Monad-import Test.QuickCheck----- signatures for exported functions-moduleName :: String-instanceName :: S.Sequence s => Sized s a -> String-empty :: S.Sequence s => Sized s a-singleton :: S.Sequence s => a -> Sized s a-lcons :: S.Sequence s => a -> Sized s a -> Sized s a-rcons :: S.Sequence s => a -> Sized s a -> Sized s a-append :: S.Sequence s => Sized s a -> Sized s a -> Sized s a-lview :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a)-lhead :: S.Sequence s => Sized s a -> a-lheadM :: (S.Sequence s, Monad m) => Sized s a -> m a-ltail :: S.Sequence s => Sized s a -> Sized s a-ltailM :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a)-rview :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a)-rhead :: S.Sequence s => Sized s a -> a-rheadM :: (S.Sequence s, Monad m) => Sized s a -> m a-rtail :: S.Sequence s => Sized s a -> Sized s a-rtailM :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a)-null :: S.Sequence s => Sized s a -> Bool-size :: S.Sequence s => Sized s a -> Int-concat :: S.Sequence s => Sized s (Sized s a) -> Sized s a-reverse :: S.Sequence s => Sized s a -> Sized s a-reverseOnto :: S.Sequence s => Sized s a -> Sized s a -> Sized s a-fromList :: S.Sequence s => [a] -> Sized s a-toList :: S.Sequence s => Sized s a -> [a]-map :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b-concatMap :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b-fold :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-fold' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-fold1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-fold1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldr :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-foldl :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b-foldr1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldl1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-reducer :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reducel :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reduce1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldr' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b-foldl' :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b-foldr1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-foldl1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-reducer' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reducel' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a-reduce1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a-copy :: S.Sequence s => Int -> a -> Sized s a-inBounds :: S.Sequence s => Int -> Sized s a -> Bool-lookup :: S.Sequence s => Int -> Sized s a -> a-lookupM :: (S.Sequence s, Monad m) => Int -> Sized s a -> m a-lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a-update :: S.Sequence s => Int -> a -> Sized s a -> Sized s a-adjust :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a-mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b-foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b-foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b-foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b-foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b-take :: S.Sequence s => Int -> Sized s a -> Sized s a-drop :: S.Sequence s => Int -> Sized s a -> Sized s a-splitAt :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a)-subseq :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a-filter :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a-partition :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)-takeWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a-dropWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a-splitWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a)-zip :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b)-zip3 :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c)-zipWith :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c-zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d-unzip :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b)-unzip3 :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c)-unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c)-unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d)-strict :: S.Sequence s => Sized s a -> Sized s a-strictWith :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a-structuralInvariant :: S.Sequence s => Sized s a -> Bool---- bonus functions, not in Sequence signature-fromSeq :: S.Sequence s => s a -> Sized s a-toSeq :: S.Sequence s => Sized s a -> s a----moduleName = "Data.Edison.Seq.SizedSeq"-instanceName (N _ s) = "SizedSeq(" ++ S.instanceName s ++ ")"--data Sized s a = N !Int (s a)--fromSeq xs = N (S.size xs) xs-toSeq (N _ xs) = xs--empty = N 0 S.empty-singleton x = N 1 (S.singleton x)-lcons x (N n xs) = N (n+1) (S.lcons x xs)-rcons x (N n xs) = N (n+1) (S.rcons x xs)-append (N m xs) (N n ys) = N (m+n) (S.append xs ys)--lview (N n xs) = case S.lview xs of- Nothing -> fail "SizedSeq.lview: empty sequence"- Just (x,xs) -> return (x, N (n-1) xs)--lhead (N _ xs) = S.lhead xs--lheadM (N _ xs) = S.lheadM xs--ltail (N 0 _) = error "SizedSeq.ltail: empty sequence"-ltail (N n xs) = N (n-1) (S.ltail xs)--ltailM (N 0 _) = fail "SizedSeq.ltailM: empty sequence"-ltailM (N n xs) = return (N (n-1) (S.ltail xs))--rview (N n xs) = case S.rview xs of- Nothing -> fail "SizedSeq.rview: empty sequence"- Just (x,xs) -> return (x, N (n-1) xs)--rhead (N _ xs) = S.rhead xs--rheadM (N _ xs) = S.rheadM xs--rtail (N 0 _) = error "SizedSeq.rtail: empty sequence"-rtail (N n xs) = N (n-1) (S.rtail xs)--rtailM (N 0 _) = fail "SizedSeq.rtailM: empty sequence"-rtailM (N n xs) = return (N (n-1) (S.rtail xs))--null (N n _) = n == 0-size (N n _) = n-concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss))-reverse (N n xs) = N n (S.reverse xs)-reverseOnto (N m xs) (N n ys) = N (m+n) (S.reverseOnto xs ys)-fromList = fromSeq . S.fromList-toList (N _ xs) = S.toList xs-map f (N n xs) = N n (S.map f xs)--concatMap = concatMapUsingFoldr -- only function that uses a default--fold f e (N _ xs) = S.fold f e xs-fold' f e (N _ xs) = S.fold' f e xs-fold1 f (N _ xs) = S.fold1 f xs-fold1' f (N _ xs) = S.fold1' f xs-foldr f e (N _ xs) = S.foldr f e xs-foldr' f e (N _ xs) = S.foldr' f e xs-foldl f e (N _ xs) = S.foldl f e xs-foldl' f e (N _ xs) = S.foldl' f e xs-foldr1 f (N _ xs) = S.foldr1 f xs-foldr1' f (N _ xs) = S.foldr1' f xs-foldl1 f (N _ xs) = S.foldl1 f xs-foldl1' f (N _ xs) = S.foldl1' f xs-reducer f e (N _ xs) = S.reducer f e xs-reducer' f e (N _ xs) = S.reducer' f e xs-reducel f e (N _ xs) = S.reducel f e xs-reducel' f e (N _ xs) = S.reducel' f e xs-reduce1 f (N _ xs) = S.reduce1 f xs-reduce1' f (N _ xs) = S.reduce1' f xs--copy n x- | n <= 0 = empty- | otherwise = N n (S.copy n x)--inBounds i (N n _) = (i >= 0) && (i < n)-lookup i (N _ xs) = S.lookup i xs-lookupM i (N _ xs) = S.lookupM i xs-lookupWithDefault d i (N _ xs) = S.lookupWithDefault d i xs-update i x (N n xs) = N n (S.update i x xs)-adjust f i (N n xs) = N n (S.adjust f i xs)-mapWithIndex f (N n xs) = N n (S.mapWithIndex f xs)-foldrWithIndex f e (N _ xs) = S.foldrWithIndex f e xs-foldrWithIndex' f e (N _ xs) = S.foldrWithIndex' f e xs-foldlWithIndex f e (N _ xs) = S.foldlWithIndex f e xs-foldlWithIndex' f e (N _ xs) = S.foldlWithIndex' f e xs--take i original@(N n xs)- | i <= 0 = empty- | i >= n = original- | otherwise = N i (S.take i xs)--drop i original@(N n xs)- | i <= 0 = original- | i >= n = empty- | otherwise = N (n-i) (S.drop i xs)--splitAt i original@(N n xs)- | i <= 0 = (empty, original)- | i >= n = (original, empty)- | otherwise = let (ys,zs) = S.splitAt i xs- in (N i ys, N (n-i) zs)--subseq i len original@(N n xs)- | i <= 0 = take len original- | i >= n || len <= 0 = empty- | i+len >= n = N (n-i) (S.drop i xs)- | otherwise = N len (S.subseq i len xs)--filter p = fromSeq . S.filter p . toSeq--partition p (N n xs) = (N m ys, N (n-m) zs)- where (ys,zs) = S.partition p xs- m = S.size ys--takeWhile p = fromSeq . S.takeWhile p . toSeq-dropWhile p = fromSeq . S.dropWhile p . toSeq--splitWhile p (N n xs) = (N m ys, N (n-m) zs)- where (ys,zs) = S.splitWhile p xs- m = S.size ys--zip (N m xs) (N n ys) = N (min m n) (S.zip xs ys)-zip3 (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zip3 xs ys zs)--zipWith f (N m xs) (N n ys) = N (min m n) (S.zipWith f xs ys)-zipWith3 f (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zipWith3 f xs ys zs)--unzip (N n xys) = (N n xs, N n ys)- where (xs,ys) = S.unzip xys--unzip3 (N n xyzs) = (N n xs, N n ys, N n zs)- where (xs,ys,zs) = S.unzip3 xyzs--unzipWith f g (N n xys) = (N n xs, N n ys)- where (xs,ys) = S.unzipWith f g xys--unzipWith3 f g h (N n xyzs) = (N n xs, N n ys, N n zs)- where (xs,ys,zs) = S.unzipWith3 f g h xyzs--strict s@(N _ s') = S.strict s' `seq` s-strictWith f s@(N _ s') = S.strictWith f s' `seq` s--structuralInvariant (N i s) = i == S.size s---- instances--instance S.Sequence s => S.Sequence (Sized s) where- {lcons = lcons; rcons = rcons;- lview = lview; lhead = lhead; ltail = ltail;- lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;- rview = rview; rhead = rhead; rtail = rtail; null = null;- size = size; concat = concat; reverse = reverse;- reverseOnto = reverseOnto; fromList = fromList; toList = toList;- fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';- foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';- foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';- reducer = reducer; reducer' = reducer'; reducel = reducel;- reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1';- copy = copy; inBounds = inBounds; lookup = lookup;- lookupM = lookupM; lookupWithDefault = lookupWithDefault;- update = update; adjust = adjust; mapWithIndex = mapWithIndex;- foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex';- foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex';- take = take; drop = drop; splitAt = splitAt; subseq = subseq;- filter = filter; partition = partition; takeWhile = takeWhile;- dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;- zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;- unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;- strict = strict; strictWith = strictWith;- structuralInvariant = structuralInvariant; instanceName = instanceName}--instance S.Sequence s => Functor (Sized s) where- fmap = map--instance S.Sequence s => Monad (Sized s) where- return = singleton- xs >>= k = concatMap k xs--instance S.Sequence s => MonadPlus (Sized s) where- mplus = append- mzero = empty---instance Eq (s a) => Eq (Sized s a) where- (N m xs) == (N n ys) = (m == n) && (xs == ys)- -- this is probably identical to the code that would be- -- generated by "deriving (Eq)", but I wanted to be *sure*- -- that the sizes were compared before the inner sequences--instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Sized s a) where- compare = defaultCompare--instance (S.Sequence s, Show (s a)) => Show (Sized s a) where- showsPrec i xs rest- | i == 0 = L.concat [ moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest]- | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)]--instance (S.Sequence s, Read (s a)) => Read (Sized s a) where- readsPrec _ xs = maybeParens p xs- where p xs = tokenMatch (moduleName++".fromSeq") xs- >>= readsPrec 10- >>= \(l,rest) -> return (fromSeq l, rest)--instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Sized s a) where- arbitrary = do xs <- arbitrary- return (fromSeq xs)--instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Sized s a) where- coarbitrary xs = coarbitrary (toSeq xs)--instance S.Sequence s => Monoid (Sized s a) where- mempty = empty- mappend = append+-- | +-- Module : Data.Edison.Seq.SizedSeq +-- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module defines a sequence adaptor @Sized s@. +-- If @s@ is a sequence type constructor, then @Sized s@ +-- is a sequence type constructor that is identical to @s@, +-- except that it also keeps track of the current size of +-- each sequence. +-- +-- All time complexities are determined by the underlying +-- sequence, except that size becomes @O( 1 )@. + +module Data.Edison.Seq.SizedSeq ( + -- * Sized Sequence Type + Sized, -- Sized s instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName,instanceName, + + -- * Other supported operations + fromSeq,toSeq +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,foldl', + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import qualified Control.Applicative as App + +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults -- only used by concatMap +import Data.Monoid +import Data.Semigroup as SG +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Test.QuickCheck + + +-- signatures for exported functions +moduleName :: String +instanceName :: S.Sequence s => Sized s a -> String +empty :: S.Sequence s => Sized s a +singleton :: S.Sequence s => a -> Sized s a +lcons :: S.Sequence s => a -> Sized s a -> Sized s a +rcons :: S.Sequence s => a -> Sized s a -> Sized s a +append :: S.Sequence s => Sized s a -> Sized s a -> Sized s a +lview :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (a, Sized s a) +lhead :: S.Sequence s => Sized s a -> a +lheadM :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m a +ltail :: S.Sequence s => Sized s a -> Sized s a +ltailM :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (Sized s a) +rview :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (a, Sized s a) +rhead :: S.Sequence s => Sized s a -> a +rheadM :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m a +rtail :: S.Sequence s => Sized s a -> Sized s a +rtailM :: (S.Sequence s, Fail.MonadFail m) => Sized s a -> m (Sized s a) +null :: S.Sequence s => Sized s a -> Bool +size :: S.Sequence s => Sized s a -> Int +concat :: S.Sequence s => Sized s (Sized s a) -> Sized s a +reverse :: S.Sequence s => Sized s a -> Sized s a +reverseOnto :: S.Sequence s => Sized s a -> Sized s a -> Sized s a +fromList :: S.Sequence s => [a] -> Sized s a +toList :: S.Sequence s => Sized s a -> [a] +map :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b +concatMap :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b +fold :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +fold' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +fold1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +fold1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldr :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +foldl :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b +foldr1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldl1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +reducer :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reducel :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reduce1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldr' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +foldl' :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b +foldr1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldl1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +reducer' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reducel' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reduce1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +copy :: S.Sequence s => Int -> a -> Sized s a +inBounds :: S.Sequence s => Int -> Sized s a -> Bool +lookup :: S.Sequence s => Int -> Sized s a -> a +lookupM :: (S.Sequence s, Fail.MonadFail m) => Int -> Sized s a -> m a +lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a +update :: S.Sequence s => Int -> a -> Sized s a -> Sized s a +adjust :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a +mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b +foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b +foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b +foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b +foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b +take :: S.Sequence s => Int -> Sized s a -> Sized s a +drop :: S.Sequence s => Int -> Sized s a -> Sized s a +splitAt :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a) +subseq :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a +filter :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a +partition :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a) +takeWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a +dropWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a +splitWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a) +zip :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b) +zip3 :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c) +zipWith :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c +zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d +unzip :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b) +unzip3 :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c) +unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c) +unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d) +strict :: S.Sequence s => Sized s a -> Sized s a +strictWith :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a +structuralInvariant :: S.Sequence s => Sized s a -> Bool + +-- bonus functions, not in Sequence signature +fromSeq :: S.Sequence s => s a -> Sized s a +toSeq :: S.Sequence s => Sized s a -> s a + + + +moduleName = "Data.Edison.Seq.SizedSeq" +instanceName (N _ s) = "SizedSeq(" ++ S.instanceName s ++ ")" + +data Sized s a = N !Int (s a) + +fromSeq xs = N (S.size xs) xs +toSeq (N _ xs) = xs + +empty = N 0 S.empty +singleton x = N 1 (S.singleton x) +lcons x (N n xs) = N (n+1) (S.lcons x xs) +rcons x (N n xs) = N (n+1) (S.rcons x xs) +append (N m xs) (N n ys) = N (m+n) (S.append xs ys) + +lview (N n xs) = case S.lview xs of + Nothing -> fail "SizedSeq.lview: empty sequence" + Just (x,xs) -> return (x, N (n-1) xs) + +lhead (N _ xs) = S.lhead xs + +lheadM (N _ xs) = S.lheadM xs + +ltail (N 0 _) = error "SizedSeq.ltail: empty sequence" +ltail (N n xs) = N (n-1) (S.ltail xs) + +ltailM (N 0 _) = fail "SizedSeq.ltailM: empty sequence" +ltailM (N n xs) = return (N (n-1) (S.ltail xs)) + +rview (N n xs) = case S.rview xs of + Nothing -> fail "SizedSeq.rview: empty sequence" + Just (x,xs) -> return (x, N (n-1) xs) + +rhead (N _ xs) = S.rhead xs + +rheadM (N _ xs) = S.rheadM xs + +rtail (N 0 _) = error "SizedSeq.rtail: empty sequence" +rtail (N n xs) = N (n-1) (S.rtail xs) + +rtailM (N 0 _) = fail "SizedSeq.rtailM: empty sequence" +rtailM (N n xs) = return (N (n-1) (S.rtail xs)) + +null (N n _) = n == 0 +size (N n _) = n +concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss)) +reverse (N n xs) = N n (S.reverse xs) +reverseOnto (N m xs) (N n ys) = N (m+n) (S.reverseOnto xs ys) +fromList = fromSeq . S.fromList +toList (N _ xs) = S.toList xs +map f (N n xs) = N n (S.map f xs) + +concatMap = concatMapUsingFoldr -- only function that uses a default + +fold f e (N _ xs) = S.fold f e xs +fold' f e (N _ xs) = S.fold' f e xs +fold1 f (N _ xs) = S.fold1 f xs +fold1' f (N _ xs) = S.fold1' f xs +foldr f e (N _ xs) = S.foldr f e xs +foldr' f e (N _ xs) = S.foldr' f e xs +foldl f e (N _ xs) = S.foldl f e xs +foldl' f e (N _ xs) = S.foldl' f e xs +foldr1 f (N _ xs) = S.foldr1 f xs +foldr1' f (N _ xs) = S.foldr1' f xs +foldl1 f (N _ xs) = S.foldl1 f xs +foldl1' f (N _ xs) = S.foldl1' f xs +reducer f e (N _ xs) = S.reducer f e xs +reducer' f e (N _ xs) = S.reducer' f e xs +reducel f e (N _ xs) = S.reducel f e xs +reducel' f e (N _ xs) = S.reducel' f e xs +reduce1 f (N _ xs) = S.reduce1 f xs +reduce1' f (N _ xs) = S.reduce1' f xs + +copy n x + | n <= 0 = empty + | otherwise = N n (S.copy n x) + +inBounds i (N n _) = (i >= 0) && (i < n) +lookup i (N _ xs) = S.lookup i xs +lookupM i (N _ xs) = S.lookupM i xs +lookupWithDefault d i (N _ xs) = S.lookupWithDefault d i xs +update i x (N n xs) = N n (S.update i x xs) +adjust f i (N n xs) = N n (S.adjust f i xs) +mapWithIndex f (N n xs) = N n (S.mapWithIndex f xs) +foldrWithIndex f e (N _ xs) = S.foldrWithIndex f e xs +foldrWithIndex' f e (N _ xs) = S.foldrWithIndex' f e xs +foldlWithIndex f e (N _ xs) = S.foldlWithIndex f e xs +foldlWithIndex' f e (N _ xs) = S.foldlWithIndex' f e xs + +take i original@(N n xs) + | i <= 0 = empty + | i >= n = original + | otherwise = N i (S.take i xs) + +drop i original@(N n xs) + | i <= 0 = original + | i >= n = empty + | otherwise = N (n-i) (S.drop i xs) + +splitAt i original@(N n xs) + | i <= 0 = (empty, original) + | i >= n = (original, empty) + | otherwise = let (ys,zs) = S.splitAt i xs + in (N i ys, N (n-i) zs) + +subseq i len original@(N n xs) + | i <= 0 = take len original + | i >= n || len <= 0 = empty + | i+len >= n = N (n-i) (S.drop i xs) + | otherwise = N len (S.subseq i len xs) + +filter p = fromSeq . S.filter p . toSeq + +partition p (N n xs) = (N m ys, N (n-m) zs) + where (ys,zs) = S.partition p xs + m = S.size ys + +takeWhile p = fromSeq . S.takeWhile p . toSeq +dropWhile p = fromSeq . S.dropWhile p . toSeq + +splitWhile p (N n xs) = (N m ys, N (n-m) zs) + where (ys,zs) = S.splitWhile p xs + m = S.size ys + +zip (N m xs) (N n ys) = N (min m n) (S.zip xs ys) +zip3 (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zip3 xs ys zs) + +zipWith f (N m xs) (N n ys) = N (min m n) (S.zipWith f xs ys) +zipWith3 f (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zipWith3 f xs ys zs) + +unzip (N n xys) = (N n xs, N n ys) + where (xs,ys) = S.unzip xys + +unzip3 (N n xyzs) = (N n xs, N n ys, N n zs) + where (xs,ys,zs) = S.unzip3 xyzs + +unzipWith f g (N n xys) = (N n xs, N n ys) + where (xs,ys) = S.unzipWith f g xys + +unzipWith3 f g h (N n xyzs) = (N n xs, N n ys, N n zs) + where (xs,ys,zs) = S.unzipWith3 f g h xyzs + +strict s@(N _ s') = S.strict s' `seq` s +strictWith f s@(N _ s') = S.strictWith f s' `seq` s + +structuralInvariant (N i s) = i == S.size s + +-- instances + +instance S.Sequence s => S.Sequence (Sized s) where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName = instanceName} + +instance S.Sequence s => Functor (Sized s) where + fmap = map + +instance S.Sequence s => App.Alternative (Sized s) where + empty = empty + (<|>) = append + +instance S.Sequence s => App.Applicative (Sized s) where + pure = return + x <*> y = do + x' <- x + y' <- y + return (x' y') + +instance S.Sequence s => Monad (Sized s) where + return = singleton + xs >>= k = concatMap k xs + +instance S.Sequence s => MonadPlus (Sized s) where + mplus = append + mzero = empty + + +instance Eq (s a) => Eq (Sized s a) where + (N m xs) == (N n ys) = (m == n) && (xs == ys) + -- this is probably identical to the code that would be + -- generated by "deriving (Eq)", but I wanted to be *sure* + -- that the sizes were compared before the inner sequences + +instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Sized s a) where + compare = defaultCompare + +instance (S.Sequence s, Show (s a)) => Show (Sized s a) where + showsPrec i xs rest + | i == 0 = L.concat [ moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest] + | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)] + +instance (S.Sequence s, Read (s a)) => Read (Sized s a) where + readsPrec _ xs = maybeParens p xs + where p xs = tokenMatch (moduleName++".fromSeq") xs + >>= readsPrec 10 + >>= \(l,rest) -> return (fromSeq l, rest) + +instance (S.Sequence s, Arbitrary (s a)) => Arbitrary (Sized s a) where + arbitrary = do xs <- arbitrary + return (fromSeq xs) + +instance (S.Sequence s, CoArbitrary (s a)) => CoArbitrary (Sized s a) where + coarbitrary xs = coarbitrary (toSeq xs) + + +instance S.Sequence s => Semigroup (Sized s a) where + (<>) = append +instance S.Sequence s => Monoid (Sized s a) where + mempty = empty + mappend = (SG.<>)