diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,118 +1,123 @@ -# Edison - -Changelog of EdisonAPI and EdisonCore. - -[Latest CHANGES.md](https://github.com/robdockins/edison/blob/master/CHANGES.md) - -## 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 +# 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 diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -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. diff --git a/EdisonCore.cabal b/EdisonCore.cabal --- a/EdisonCore.cabal +++ b/EdisonCore.cabal @@ -1,82 +1,81 @@ -Name: EdisonCore -Cabal-Version: >= 1.10 -Build-Type: Simple -Version: 1.3.3.2 -License: MIT -License-File: COPYRIGHT -Author: Chris Okasaki -Maintainer: robdockins AT fastmail DOT fm -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 - - -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.22, - QuickCheck >= 2.8.2 && < 3, - EdisonAPI >= 1.3.3 && < 1.4, - containers < 0.8, - array < 0.6 - - 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 -fwarn-incomplete-patterns - if impl(ghc >= 8.0) - Ghc-Options: -Wcompat +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 diff --git a/src/Data/Edison/Assoc/AssocList.hs b/src/Data/Edison/Assoc/AssocList.hs --- a/src/Data/Edison/Assoc/AssocList.hs +++ b/src/Data/Edison/Assoc/AssocList.hs @@ -1,628 +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,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 ( (x,delete k y)) . spanFM ( 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 - coarbitrary (I k a m) = variant 1 . 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 +-- | +-- 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 ( (x,delete k y)) . spanFM ( 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 diff --git a/src/Data/Edison/Assoc/Defaults.hs b/src/Data/Edison/Assoc/Defaults.hs --- a/src/Data/Edison/Assoc/Defaults.hs +++ b/src/Data/Edison/Assoc/Defaults.hs @@ -1,311 +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,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,_)] = 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 diff --git a/src/Data/Edison/Assoc/PatriciaLoMap.hs b/src/Data/Edison/Assoc/PatriciaLoMap.hs --- a/src/Data/Edison/Assoc/PatriciaLoMap.hs +++ b/src/Data/Edison/Assoc/PatriciaLoMap.hs @@ -1,854 +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,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 - 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 Semigroup (FM a) where - (<>) = union -instance Monoid (FM a) where - mempty = empty - mappend = (SG.<>) - 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 diff --git a/src/Data/Edison/Assoc/StandardMap.hs b/src/Data/Edison/Assoc/StandardMap.hs --- a/src/Data/Edison/Assoc/StandardMap.hs +++ b/src/Data/Edison/Assoc/StandardMap.hs @@ -1,362 +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,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 +-- | +-- 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 diff --git a/src/Data/Edison/Assoc/TernaryTrie.hs b/src/Data/Edison/Assoc/TernaryTrie.hs --- a/src/Data/Edison/Assoc/TernaryTrie.hs +++ b/src/Data/Edison/Assoc/TernaryTrie.hs @@ -1,1170 +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,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.Monoid -import Data.Semigroup as SG -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, 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) - -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 = 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 (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 (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 (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 (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 _ l (FMB' m) r) - = structuralInvariantFMB l - && structuralInvariantFMB m - && structuralInvariantFMB r - && 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::[([k],a)]) <- 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 => Semigroup (FM k a) where - (<>) = union -instance Ord k => Monoid (FM k a) where - mempty = empty - mappend = (SG.<>) - 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: +-- 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) 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] diff --git a/src/Data/Edison/Coll/Defaults.hs b/src/Data/Edison/Coll/Defaults.hs --- a/src/Data/Edison/Coll/Defaults.hs +++ b/src/Data/Edison/Coll/Defaults.hs @@ -1,247 +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,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,_)] = 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 + diff --git a/src/Data/Edison/Coll/EnumSet.hs b/src/Data/Edison/Coll/EnumSet.hs --- a/src/Data/Edison/Coll/EnumSet.hs +++ b/src/Data/Edison/Coll/EnumSet.hs @@ -1,808 +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 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 +----------------------------------------------------------------------------- +-- | +-- 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 diff --git a/src/Data/Edison/Coll/LazyPairingHeap.hs b/src/Data/Edison/Coll/LazyPairingHeap.hs --- a/src/Data/Edison/Coll/LazyPairingHeap.hs +++ b/src/Data/Edison/Coll/LazyPairingHeap.hs @@ -1,570 +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,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 = 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) => 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 +-- | +-- 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 diff --git a/src/Data/Edison/Coll/LeftistHeap.hs b/src/Data/Edison/Coll/LeftistHeap.hs --- a/src/Data/Edison/Coll/LeftistHeap.hs +++ b/src/Data/Edison/Coll/LeftistHeap.hs @@ -1,496 +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,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.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 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) => 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 +-- | +-- 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 diff --git a/src/Data/Edison/Coll/MinHeap.hs b/src/Data/Edison/Coll/MinHeap.hs --- a/src/Data/Edison/Coll/MinHeap.hs +++ b/src/Data/Edison/Coll/MinHeap.hs @@ -1,410 +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,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 - coarbitrary (M x xs) = variant 1 . 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 +-- | +-- 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 diff --git a/src/Data/Edison/Coll/SkewHeap.hs b/src/Data/Edison/Coll/SkewHeap.hs --- a/src/Data/Edison/Coll/SkewHeap.hs +++ b/src/Data/Edison/Coll/SkewHeap.hs @@ -1,464 +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,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.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 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) => 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 +-- | +-- 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 diff --git a/src/Data/Edison/Coll/SplayHeap.hs b/src/Data/Edison/Coll/SplayHeap.hs --- a/src/Data/Edison/Coll/SplayHeap.hs +++ b/src/Data/Edison/Coll/SplayHeap.hs @@ -1,498 +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,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 - coarbitrary (T a x b) = - variant 1 . 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 +-- | +-- 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 diff --git a/src/Data/Edison/Coll/StandardSet.hs b/src/Data/Edison/Coll/StandardSet.hs --- a/src/Data/Edison/Coll/StandardSet.hs +++ b/src/Data/Edison/Coll/StandardSet.hs @@ -1,265 +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,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 ( 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 +-- | +-- 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 ( 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 diff --git a/src/Data/Edison/Coll/UnbalancedSet.hs b/src/Data/Edison/Coll/UnbalancedSet.hs --- a/src/Data/Edison/Coll/UnbalancedSet.hs +++ b/src/Data/Edison/Coll/UnbalancedSet.hs @@ -1,443 +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,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.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 - 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::[a]) <- 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) => 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 +-- | +-- 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 diff --git a/src/Data/Edison/Concrete/FingerTree.hs b/src/Data/Edison/Concrete/FingerTree.hs --- a/src/Data/Edison/Concrete/FingerTree.hs +++ b/src/Data/Edison/Concrete/FingerTree.hs @@ -1,788 +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. --- --- --- 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 . 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. +-- +-- +-- 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 diff --git a/src/Data/Edison/Seq/BankersQueue.hs b/src/Data/Edison/Seq/BankersQueue.hs --- a/src/Data/Edison/Seq/BankersQueue.hs +++ b/src/Data/Edison/Seq/BankersQueue.hs @@ -1,440 +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,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.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/BinaryRandList.hs b/src/Data/Edison/Seq/BinaryRandList.hs --- a/src/Data/Edison/Seq/BinaryRandList.hs +++ b/src/Data/Edison/Seq/BinaryRandList.hs @@ -1,468 +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,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 - coarbitrary (Even ps) = variant 1 . coarbitrary ps - coarbitrary (Odd x ps) = variant 2 . coarbitrary x . coarbitrary ps - - -instance Semigroup (Seq a) where - (<>) = append -instance Monoid (Seq a) where - mempty = empty - mappend = (SG.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/BraunSeq.hs b/src/Data/Edison/Seq/BraunSeq.hs --- a/src/Data/Edison/Seq/BraunSeq.hs +++ b/src/Data/Edison/Seq/BraunSeq.hs @@ -1,570 +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,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!" - - (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 = 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.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/Defaults.hs b/src/Data/Edison/Seq/Defaults.hs --- a/src/Data/Edison/Seq/Defaults.hs +++ b/src/Data/Edison/Seq/Defaults.hs @@ -1,514 +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,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,_)] = 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 diff --git a/src/Data/Edison/Seq/FingerSeq.hs b/src/Data/Edison/Seq/FingerSeq.hs --- a/src/Data/Edison/Seq/FingerSeq.hs +++ b/src/Data/Edison/Seq/FingerSeq.hs @@ -1,402 +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,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.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/JoinList.hs b/src/Data/Edison/Seq/JoinList.hs --- a/src/Data/Edison/Seq/JoinList.hs +++ b/src/Data/Edison/Seq/JoinList.hs @@ -1,443 +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,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 - coarbitrary (L x) = variant 1 . coarbitrary x - coarbitrary (A xs ys) = variant 2 . coarbitrary xs . coarbitrary ys - -instance Semigroup (Seq a) where - (<>) = append -instance Monoid (Seq a) where - mempty = empty - mappend = (SG.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/MyersStack.hs b/src/Data/Edison/Seq/MyersStack.hs --- a/src/Data/Edison/Seq/MyersStack.hs +++ b/src/Data/Edison/Seq/MyersStack.hs @@ -1,453 +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,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 --} +-- | +-- 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 +-} diff --git a/src/Data/Edison/Seq/RandList.hs b/src/Data/Edison/Seq/RandList.hs --- a/src/Data/Edison/Seq/RandList.hs +++ b/src/Data/Edison/Seq/RandList.hs @@ -1,500 +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,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.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/RevSeq.hs b/src/Data/Edison/Seq/RevSeq.hs --- a/src/Data/Edison/Seq/RevSeq.hs +++ b/src/Data/Edison/Seq/RevSeq.hs @@ -1,399 +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,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.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/SimpleQueue.hs b/src/Data/Edison/Seq/SimpleQueue.hs --- a/src/Data/Edison/Seq/SimpleQueue.hs +++ b/src/Data/Edison/Seq/SimpleQueue.hs @@ -1,391 +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,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.<>) +-- | +-- 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.<>) diff --git a/src/Data/Edison/Seq/SizedSeq.hs b/src/Data/Edison/Seq/SizedSeq.hs --- a/src/Data/Edison/Seq/SizedSeq.hs +++ b/src/Data/Edison/Seq/SizedSeq.hs @@ -1,373 +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,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.<>) +-- | +-- 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.<>)