EdisonCore-1.3.2.1/0000755000000000000000000000000013223626550012100 5ustar0000000000000000EdisonCore-1.3.2.1/Setup.hs0000644000000000000000000000011013223626550013524 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain EdisonCore-1.3.2.1/COPYRIGHT0000644000000000000000000000235013223626550013373 0ustar0000000000000000Copyright (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. EdisonCore-1.3.2.1/CHANGES0000644000000000000000000000760713223626550013105 0ustar0000000000000000Changes in 1.3.2.1 * Fix compile problems on GHC 7.10 Changes in 1.3.2 * Add Semigroup instances for all types that previously had Monoid instances. * Remove use of depreciated functions in Data.Edison.Assoc.StandardMap Changes in 1.3.1 * Remove Arbitrary and Coarbitrary instances for Data.Set and Data.Map. These are now provided by QuickCheck >= 2.8.2 Changes in 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 Changes in 1.2.2 * Update edison-core to use QuickCheck version 2.* * Likewise update the test suite Changes in 1.2.1.3 * Minor fix to the StandardMap module to handle the API change in GHC 6.10 Changes in 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. Changes in 1.2.1.1 * Build system changes to make GHC 6.8 and cabal >= 1.2.2 happy Changes in 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. Changes in 1.2.0.1 * Change use more efficient operations for StandardSet.{filterGT,filterLT} and StandardMap.{filterLE,filterGE,partitionLE_GT,partitionLT_GE} Changes in 1.2 final * Fix documentation for sequences to reflect correct time complexities Changes in 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 Changes in 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 Changes in 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 Changes in 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 EdisonCore-1.3.2.1/EdisonCore.cabal0000644000000000000000000000457213223626550015126 0ustar0000000000000000Name: EdisonCore Cabal-Version: >= 1.10 Build-Type: Simple Version: 1.3.2.1 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: http://rwd.rdockins.name/edison/home/ Stability: Stable Description: This package provides the core Edison data structure implementations, including multiple sequence, set, bag, and finite map concrete implementations with various performance characteristics. The implementations in this package have no dependencies other than those commonly bundled with Haskell compilers. Extra-Source-Files: CHANGES 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.*, mtl, QuickCheck >= 2.8.2 && < 3, EdisonAPI == 1.3.*, containers, array if impl(ghc < 8.0) -- Provide/emulate Data.Semigroups` API for pre-GHC-8 Build-Depends: 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 EdisonCore-1.3.2.1/src/0000755000000000000000000000000013223626550012667 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/0000755000000000000000000000000013223626550013540 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/Edison/0000755000000000000000000000000013223626550014761 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/Edison/Assoc/0000755000000000000000000000000013223626550016031 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/Edison/Assoc/TernaryTrie.hs0000644000000000000000000012206513223626550020643 0ustar0000000000000000-- | -- Module : Data.Edison.Assoc.TernaryTrie -- Copyright : Copyright (c) 2002, 2008 Andrew Bromage -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Finite maps implemented as ternary search tries module Data.Edison.Assoc.TernaryTrie ( -- * Type of ternary search tries FM, -- * AssocX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, adjustOrDelete,adjustOrDeleteAll,strict,strictWith, map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, -- * Assoc operations toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, -- * FiniteMapX operations fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, properSubmap,submap,sameMap, -- * FiniteMap operations unionWithKey,unionSeqWithKey,intersectionWithKey, -- * OrdAssocX operations minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, unsafeInsertMax, foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE, partitionLT_GE, partitionLE_GT, partitionLT_GT, -- * OrdAssoc operations minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, -- * Other supported operations mergeVFM, mergeKVFM, -- * Documentation moduleName ) where import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter) import qualified Prelude import qualified Data.Edison.Assoc as A import qualified Data.Edison.Seq as S import qualified Data.List as L import Control.Monad.Identity import Data.Monoid import Data.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, Monad rm) => [k] -> FM k a -> rm a lookupAll :: (Ord k,S.Sequence seq) => [k] -> FM k a -> seq a lookupAndDelete :: Ord k => [k] -> FM k a -> (a, FM k a) lookupAndDeleteM :: (Ord k, Monad rm) => [k] -> FM k a -> rm (a, FM k a) lookupAndDeleteAll :: (Ord k, S.Sequence seq) => [k] -> FM k a -> (seq a,FM k a) lookupWithDefault :: Ord k => a -> [k] -> FM k a -> a adjust :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a adjustAll :: Ord k => (a -> a) -> [k] -> FM k a -> FM k a adjustOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a adjustAllOrInsert :: Ord k => (a -> a) -> a -> [k] -> FM k a -> FM k a adjustOrDelete :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> [k] -> FM k a -> FM k a strict :: FM k a -> FM k a strictWith :: (a -> b) -> FM k a -> FM k a map :: Ord k => (a -> b) -> FM k a -> FM k b fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b fold1 :: Ord k => (a -> a -> a) -> FM k a -> a fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b fold1' :: Ord k => (a -> a -> a) -> FM k a -> a filter :: Ord k => (a -> Bool) -> FM k a -> FM k a partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a, FM k a) elements :: (Ord k,S.Sequence seq) => FM k a -> seq a fromSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq ([k],a) -> FM k a fromSeqWithKey :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a insertWith :: Ord k => (a -> a -> a) -> [k] -> a -> FM k a -> FM k a insertWithKey :: Ord k => ([k] -> a -> a -> a) -> [k] -> a -> FM k a -> FM k a insertSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a insertSeqWithKey :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq ([k],a) -> FM k a -> FM k a unionl :: Ord k => FM k a -> FM k a -> FM k a unionr :: Ord k => FM k a -> FM k a -> FM k a unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a unionSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (FM k a) -> FM k a intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c difference :: Ord k => FM k a -> FM k b -> FM k a properSubset :: Ord k => FM k a -> FM k b -> Bool subset :: Ord k => FM k a -> FM k b -> Bool properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool properSubmap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool submap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool sameMap :: (Ord k, Eq a) => FM k a -> FM k a -> Bool toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a) keys :: (Ord k,S.Sequence seq) => FM k a -> seq [k] mapWithKey :: Ord k => ([k] -> a -> b) -> FM k a -> FM k b foldWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b foldWithKey' :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b filterWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> FM k a partitionWithKey :: Ord k => ([k] -> a -> Bool) -> FM k a -> (FM k a, FM k a) unionWithKey :: Ord k => ([k] -> a -> a -> a) -> FM k a -> FM k a -> FM k a unionSeqWithKey :: (Ord k,S.Sequence seq) => ([k] -> a -> a -> a) -> seq (FM k a) -> FM k a intersectionWithKey :: Ord k => ([k] -> a -> b -> c) -> FM k a -> FM k b -> FM k c foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a foldrWithKey :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b foldrWithKey' :: Ord k => ([k] -> a -> b -> b) -> b -> FM k a -> b foldlWithKey :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b foldlWithKey' :: Ord k => (b -> [k] -> a -> b) -> b -> FM k a -> b toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq ([k],a) moduleName = "Data.Edison.Assoc.TernaryTrie" data FM k a = FM !(Maybe a) !(FMB k a) data FMB k v = E | I !Int !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMB k v) newtype FMB' k v = FMB' (FMB k v) balance :: Int balance = 6 sizeFMB :: FMB k v -> Int sizeFMB E = 0 sizeFMB (I size _ _ _ _ _) = size mkFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v mkFMB k v l m r = I (1 + sizeFMB l + sizeFMB r) k v l m r lookupFMB :: (Ord k) => [k] -> FMB k v -> Maybe v lookupFMB [] _ = Nothing lookupFMB (_:_) E = Nothing lookupFMB nk@(x:xs) (I _ k v l (FMB' fmbm) r) = case compare x k of LT -> lookupFMB nk l GT -> lookupFMB nk r EQ -> if L.null xs then v else lookupFMB xs fmbm listToFMB :: [k] -> (Maybe v -> Maybe v) -> FMB k v listToFMB [x] fv = mkFMB x (fv Nothing) E (FMB' E) E listToFMB (x:xs) fv = mkFMB x Nothing E (FMB' $ listToFMB xs fv) E listToFMB _ _ = error "TernaryTrie.listToFMB: bug!" addToFMB :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FMB k v -> FMB k v addToFMB xs combiner E = listToFMB xs combiner addToFMB nk@(x:xs) combiner (I size k v l m@(FMB' fmbm) r) = case compare x k of LT -> mkBalancedFMB k v (addToFMB nk combiner l) m r GT -> mkBalancedFMB k v l m (addToFMB nk combiner r) EQ -> case xs of [] -> I size k (combiner v) l m r _ -> I size k v l (FMB' $ addToFMB xs combiner fmbm) r addToFMB _ _ _ = error "TernaryTrie.addToFMB: bug!" addToFM :: (Ord k) => [k] -> (Maybe v -> Maybe v) -> FM k v -> FM k v addToFM [] combiner (FM n fmb) = FM (combiner n) fmb addToFM xs combiner (FM n fmb) = FM n (addToFMB xs combiner fmb) lookupAndDelFromFMB :: (Ord k) => z -> (v -> FMB k v -> z) -> [k] -> FMB k v -> z lookupAndDelFromFMB onFail _ _ E = onFail lookupAndDelFromFMB onFail cont nk@(x:xs) (I size k v l m@(FMB' fmbm) r) = case compare x k of LT -> lookupAndDelFromFMB onFail (\w l' -> cont w (mkBalancedFMB k v l' m r)) nk l GT -> lookupAndDelFromFMB onFail (\w r' -> cont w (mkBalancedFMB k v l m r')) nk r EQ -> case xs of [] -> case v of Nothing -> onFail Just w -> case fmbm of E -> cont w (appendFMB l r) _ -> cont w (I size k Nothing l m r) _ -> lookupAndDelFromFMB onFail (\w m' -> cont w (I size k v l (FMB' m') r)) xs fmbm lookupAndDelFromFMB _ _ _ _ = error "TernaryTrie.lookupAndDelFromFMB: bug!" lookupAndDelFromFM :: (Ord k) => z -> (v -> FM k v -> z) -> [k] -> FM k v -> z lookupAndDelFromFM onFail _ [] (FM Nothing _) = onFail lookupAndDelFromFM _ cont [] (FM (Just v) fmb) = cont v (FM Nothing fmb) lookupAndDelFromFM onFail cont xs (FM n fmb) = lookupAndDelFromFMB onFail (\w fmb' -> cont w (FM n fmb')) xs fmb delFromFMB :: (Ord k) => [k] -> FMB k v -> FMB k v delFromFMB _ E = E delFromFMB nk@(x:xs) (I size k v l m@(FMB' fmbm) r) = case compare x k of LT -> mkBalancedFMB k v (delFromFMB nk l) m r GT -> mkBalancedFMB k v l m (delFromFMB nk r) EQ -> case xs of [] -> case fmbm of E -> appendFMB l r _ -> I size k Nothing l m r _ -> I size k v l (FMB' $ delFromFMB xs fmbm) r delFromFMB _ _ = error "TernaryTrie.delFromFMB: bug!" delFromFM :: (Ord k) => [k] -> FM k v -> FM k v delFromFM [] (FM _ fmb) = FM Nothing fmb delFromFM xs (FM n fmb) = FM n (delFromFMB xs fmb) mkBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v mkBalancedFMB k v l m r | size_l + size_r < 2 = mkFMB k v l m r | size_r > balance * size_l -- Right tree too big = case r of I _ _ _ rl _ rr | sizeFMB rl < 2 * sizeFMB rr -> single_L l m r | otherwise -> double_L l m r _ -> error "TernaryTrie.mkBalancedFMB: bug!" | size_l > balance * size_r -- Left tree too big = case l of I _ _ _ ll _ lr | sizeFMB lr < 2 * sizeFMB ll -> single_R l m r | otherwise -> double_R l m r _ -> error "TernaryTrie.mkBalancedFMB: bug!" | otherwise -- No imbalance = mkFMB k v l m r where size_l = sizeFMB l size_r = sizeFMB r single_L l m (I _ k_r v_r rl rm rr) = mkFMB k_r v_r (mkFMB k v l m rl) rm rr single_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" double_L l m (I _ k_r v_r (I _ k_rl v_rl rll rlm rlr) rm rr) = mkFMB k_rl v_rl (mkFMB k v l m rll) rlm (mkFMB k_r v_r rlr rm rr) double_L _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" single_R (I _ k_l v_l ll lm lr) m r = mkFMB k_l v_l ll lm (mkFMB k v lr m r) single_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" double_R (I _ k_l v_l ll lm (I _ k_lr v_lr lrl lrm lrr)) m r = mkFMB k_lr v_lr (mkFMB k_l v_l ll lm lrl) lrm (mkFMB k v lrr m r) double_R _ _ _ = error "TernaryTrie:mkBalancedFMB: bug!" mkVBalancedFMB :: k -> Maybe v -> FMB k v -> FMB' k v -> FMB k v -> FMB k v mkVBalancedFMB k v E m E = mkFMB k v E m E mkVBalancedFMB k v l@E m (I _ kr vr rl rm rr) = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr mkVBalancedFMB k v (I _ kl vl ll lm lr) m r@E = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r) mkVBalancedFMB k v l@(I _ kl vl ll lm lr) m r@(I _ kr vr rl rm rr) | balance * size_l < size_r = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr | balance * size_r < size_l = mkBalancedFMB kl vl ll lm (mkVBalancedFMB k v lr m r) | otherwise = mkFMB k v l m r where size_l = sizeFMB l size_r = sizeFMB r -- Constraint: All keys in the first FMB are less than -- that in the second FMB. appendFMB :: FMB k v -> FMB k v -> FMB k v appendFMB E m2 = m2 appendFMB m1 E = m1 appendFMB fmb1@(I size1 k1 v1 l1 m1 r1) fmb2@(I size2 k2 v2 l2 m2 r2) | size1 > size2 = mkVBalancedFMB k1 v1 l1 m1 (appendFMB r1 fmb2) | otherwise = mkVBalancedFMB k2 v2 (appendFMB fmb1 l2) m2 r2 mapVFM :: (Maybe a -> Maybe b) -> FM k a -> FM k b mapVFM f (FM n fmb) = FM (f n) (mapVFMB f fmb) mapVFMB :: (Maybe a -> Maybe b) -> FMB k a -> FMB k b mapVFMB f m = mapVFMB' m where mapVFMB' E = E mapVFMB' (I _ k v l (FMB' m) r) = case (mapVFMB' m, f v) of (E,Nothing) -> appendFMB (mapVFMB' l) (mapVFMB' r) (m',v') -> mkVBalancedFMB k v' (mapVFMB' l) (FMB' m') (mapVFMB' r) mapKVFM :: ([k] -> Maybe a -> Maybe b) -> FM k a -> FM k b mapKVFM f (FM n fmb) = FM (f [] n) (mapKVFMB [] fmb) where mapKVFMB _ E = E mapKVFMB ks (I _ k v l (FMB' m) r) = mkVBalancedFMB k (f (reverse (k:ks)) v) (mapKVFMB ks l) (FMB' (mapKVFMB (k:ks) m)) (mapKVFMB ks r) nullFMB :: FMB k v -> Bool nullFMB E = True nullFMB (I _ _ v l (FMB' m) r) = case v of Just _ -> False Nothing -> nullFMB l && nullFMB m && nullFMB r nullFM :: FM k v -> Bool nullFM (FM (Just _) _) = False nullFM (FM Nothing fmb) = nullFMB fmb data FMBCtx k v = T | L !k !(Maybe v) !(FMBCtx k v) !(FMB' k v) !(FMB k v) | R !k !(Maybe v) !(FMB k v) !(FMB' k v) !(FMBCtx k v) splayFMB :: (Ord k) => k -> FMB k a -> (Maybe a, FMB k a, FMB' k a, FMB k a) splayFMB key fmb = splaydown T fmb where splaydown ctx E = splayup ctx Nothing E (FMB' E) E splaydown ctx (I _ k v l m r) = case compare key k of LT -> splaydown (L k v ctx m r) l GT -> splaydown (R k v l m ctx) r EQ -> splayup ctx v l m r splayup ctx v l m r = splayup' ctx l r where splayup' T l r = (v, l, m, r) splayup' (L ck cv ctx cm cr) tl tr = splayup' ctx tl (mkVBalancedFMB ck cv tr cm cr) splayup' (R ck cv cl cm ctx) tl tr = splayup' ctx (mkVBalancedFMB ck cv cl cm tl) tr mergeVFMB :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) -> FMB k a -> FMB k b -> FMB k c mergeVFMB f fmbx fmby = mergeVFMB' fmbx fmby where mergeVFMB' E E = E mergeVFMB' E fmby@(I _ _ _ _ (FMB' _) _) = mapVFMB (\v -> f Nothing v) fmby mergeVFMB' fmbx@(I _ _ _ _ (FMB' _) _) E = mapVFMB (\v -> f v Nothing) fmbx mergeVFMB' fmbx@(I sizex kx vx lx (FMB' mx) rx) fmby@(I sizey ky vy ly (FMB' my) ry) | sizex >= sizey = let (vy, ly, FMB' my, ry) = splayFMB kx fmby in case (mergeVFMB' mx my, f vx vy) of (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry) (m',v) -> mkVBalancedFMB kx v (mergeVFMB' lx ly) (FMB' m') (mergeVFMB' rx ry) | otherwise = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx in case (mergeVFMB' mx my, f vx vy) of (E,Nothing) -> appendFMB (mergeVFMB' lx ly) (mergeVFMB' rx ry) (m',v) -> mkVBalancedFMB ky v (mergeVFMB' lx ly) (FMB' m') (mergeVFMB' rx ry) mergeVFM :: (Ord k) => (Maybe a -> Maybe b -> Maybe c) -> FM k a -> FM k b -> FM k c mergeVFM f (FM vx fmbx) (FM vy fmby) = FM (f vx vy) (mergeVFMB f fmbx fmby) mergeKVFMB :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) -> FMB k a -> FMB k b -> FMB k c mergeKVFMB f fmbx fmby = mergeKVFMB' [] fmbx fmby where mergeKVFMB' _ E E = E mergeKVFMB' ks E fmby = mergeKVFMBs (\k v -> f k Nothing v) ks fmby mergeKVFMB' ks fmbx E = mergeKVFMBs (\k v -> f k v Nothing) ks fmbx mergeKVFMB' ks fmbx@(I sizex kx vx lx (FMB' mx) rx) fmby@(I sizey ky vy ly (FMB' my) ry) | sizex >= sizey = let (vy, ly, FMB' my, ry) = splayFMB kx fmby ks' = reverse (kx:ks) in case (mergeKVFMB' ks' mx my, f ks' vx vy) of (E,Nothing) -> appendFMB (mergeKVFMB' ks lx ly) (mergeKVFMB' ks rx ry) (m',v) -> mkVBalancedFMB kx v (mergeKVFMB' ks lx ly) (FMB' m') (mergeKVFMB' ks rx ry) | otherwise = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx ks' = reverse (ky:ks) in case (mergeKVFMB' ks' mx my, f ks' vx vy) of (E,Nothing) -> appendFMB (mergeKVFMB' ks lx ly) (mergeKVFMB' ks rx ry) (m',v) -> mkVBalancedFMB ky v (mergeKVFMB' ks lx ly) (FMB' m') (mergeKVFMB' ks rx ry) mergeKVFMBs f ks fmb = mergeKVFMBs' ks fmb where mergeKVFMBs' _ E = E mergeKVFMBs' ks (I _ k v l (FMB' m) r) = case (mergeKVFMBs' (k:ks) m, f (reverse (k:ks)) v) of (E, Nothing) -> appendFMB (mergeKVFMBs' ks l) (mergeKVFMBs' ks r) (m,v) -> mkVBalancedFMB k v (mergeKVFMBs' ks l) (FMB' m) (mergeKVFMBs' ks r) mergeKVFM :: (Ord k) => ([k] -> Maybe a -> Maybe b -> Maybe c) -> FM k a -> FM k b -> FM k c mergeKVFM f (FM vx fmbx) (FM vy fmby) = FM (f [] vx vy) (mergeKVFMB f fmbx fmby) -- The public interface. -- -- AssocX empty = FM Nothing E singleton [] v = FM (Just v) E singleton xs v = FM Nothing (listToFMB xs (\_ -> Just v)) fromSeq = fromSeqUsingInsertSeq insert k v fm = addToFM k (\_ -> Just v) fm insertSeq = insertSeqUsingFoldr union = mergeVFM mplus unionSeq = unionSeqUsingReduce delete k fm = delFromFM k fm deleteAll = delete deleteSeq = deleteSeqUsingFoldr null = nullFM size (FM k fmb) | isNothing k = fmb_size fmb 0 | otherwise = fmb_size fmb 1 where fmb_size E k = k fmb_size (I _ _ Nothing l (FMB' m) r) k = fmb_size l $ fmb_size m $ fmb_size r k fmb_size (I _ _ _ l (FMB' m) r ) k = fmb_size l $ fmb_size m $ fmb_size r $! k+1 member = memberUsingLookupM count = countUsingMember lookup m k = runIdentity (lookupM m k) lookupM [] (FM Nothing _) = fail "TernaryTrie.lookup: lookup failed" lookupM [] (FM (Just v) _) = return v lookupM xs (FM _ fmb) = case lookupFMB xs fmb of Nothing -> fail "TernaryTrie.lookup: lookup failed" Just v -> return v lookupAll = lookupAllUsingLookupM lookupAndDelete = lookupAndDelFromFM (error "TernaryTrie.lookupAndDelete: lookup failed") (,) lookupAndDeleteM = lookupAndDelFromFM (fail "TernaryTrie.lookupAndDeleteM: lookup failed") (\w m -> return (w,m)) lookupAndDeleteAll k m = lookupAndDelFromFM (S.empty,m) (\w m' -> (S.singleton w,m')) k m lookupWithDefault = lookupWithDefaultUsingLookupM adjust f k = addToFM k (\mv -> case mv of Nothing -> mv Just v -> Just (f v)) adjustAll = adjust adjustOrInsert f z k = addToFM k (\mv -> case mv of Nothing -> Just z Just v -> Just (f v)) adjustAllOrInsert = adjustOrInsert adjustOrDelete f k = addToFM k (\mv -> case mv of Nothing -> mv Just v -> f v) adjustOrDeleteAll = adjustOrDelete map f = mapVFM (\mv -> case mv of Nothing -> Nothing Just v -> Just (f v)) fold = foldr fold' = foldr' foldr op z (FM n fmb) = foldMV n . foldFMB fmb $ z where foldMV Nothing = id foldMV (Just v) = op v foldFMB E = id foldFMB (I _ _ v l (FMB' m) r) = foldFMB l . foldMV v . foldFMB m . foldFMB r foldrWithKey f z (FM n fmb) = foldMV [] n . foldFMB id fmb $ z where foldMV _ Nothing = id foldMV ks (Just v) = f ks v foldFMB _ E = id foldFMB kf (I _ k mv l (FMB' m) r) = foldFMB kf l . foldMV (kf [k]) mv . foldFMB (kf . (k:)) m . foldFMB kf r foldlWithKey f z (FM n fmb) = foldFMB id fmb . foldMV [] n $ z where g k x a = f a k x foldMV _ Nothing = id foldMV ks (Just v) = g ks v foldFMB _ E = id foldFMB kf (I _ k mv l (FMB' m) r) = foldFMB kf r . foldFMB (kf . (k:)) m . foldMV (kf [k]) mv . foldFMB kf l foldrWithKey' = foldrWithKey foldlWithKey' = foldlWithKey foldl :: (a -> b -> a) -> a -> FM t b -> a foldl op z (FM n fmb) = foldFMB fmb . foldMV n $ z where foldMV Nothing = id foldMV (Just v) = (flip op) v foldFMB E = id foldFMB (I _ _ v l (FMB' m) r) = foldFMB r . foldFMB m . foldMV v . foldFMB l -- FIXME, undestand this code to strictify it foldr' = foldr foldl' :: (a -> b -> a) -> a -> FM t b -> a foldl' = foldl foldr1 f fm = case maxView fm of Just (z,fm') -> foldr f z fm' Nothing -> error $ moduleName++".foldr1: empty map" foldl1 :: (b -> b -> b) -> FM k b -> b foldl1 f fm = case minView fm of Just (z,fm') -> foldl f z fm' Nothing -> error $ moduleName++".foldl1: empty map" basecase :: Maybe t1 -> (t1 -> t) -> t -> t basecase Nothing = \_ n -> n basecase (Just x) = \j _ -> j x comb :: (t1 -> t1 -> t1) -> ((t1 -> t2) -> t2 -> t3) -> ((t1 -> t) -> t -> t2) -> (t1 -> t) -> t -> t3 comb f p1 p2 = \j n -> p1 (\x -> p2 (\y -> j (f x y)) (j x)) (p2 j n) fold1 f (FM mv fmb) = comb f (basecase mv) (fold1FMB fmb) id (error $ moduleName++".fold1: empty map") where fold1FMB E = \_ n -> n fold1FMB (I _ _ mv l (FMB' m) r) = comb f (basecase mv) $ comb f (fold1FMB l) $ comb f (fold1FMB m) $ (fold1FMB r) fold1' = fold1 {- FIXME -- can these be somehow fixed to have the right order... foldr1 f (FM v fmb) = comb f (basecase v) (fold1FMB fmb) id (error $ moduleName++".foldr1: empty map") where fold1FMB E = \j n -> n fold1FMB (I _ _ v l (FMB' m) r) = comb f (fold1FMB l) $ comb f (basecase v) $ comb f (fold1FMB m) $ (fold1FMB r) foldl1 f (FM v fmb) = comb f (fold1FMB fmb) (basecase v) id (error $ moduleName++".foldl1: empty map") where fold1FMB E = \j n -> n fold1FMB (I _ _ v l (FMB' m) r) = comb f (fold1FMB r) $ comb f (fold1FMB m) $ comb f (basecase v) $ (fold1FMB l) -} -- FIXME, undestand this code to strictify it foldr1' = foldr1 foldl1' :: (b -> b -> b) -> FM k b -> b foldl1' = foldl1 filter p = mapVFM (\mv -> case mv of Nothing -> mv Just v -> if p v then mv else Nothing) partition = partitionUsingFilter elements = elementsUsingFold strict z@(FM _ fmb) = strictFMB fmb `seq` z where strictFMB n@E = n strictFMB n@(I _ _ _ l (FMB' m) r) = strictFMB l `seq` strictFMB m `seq` strictFMB r `seq` n strictWith f z@(FM v fmb) = f' v `seq` strictWithFMB fmb `seq` z where f' v@Nothing = v f' v@(Just x) = f x `seq` v strictWithFMB n@E = n strictWithFMB n@(I _ _ v l (FMB' m) r) = f' v `seq` strictWithFMB l `seq` strictWithFMB m `seq` strictWithFMB r `seq` n -- FiniteMapX fromSeqWith = fromSeqWithUsingInsertSeqWith fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey insertWith f k v = addToFM k (\vem -> case vem of Nothing -> Just v Just ve -> Just (f ve v)) insertWithKey = insertWithKeyUsingInsertWith insertSeqWith = insertSeqWithUsingInsertWith insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey unionl = union unionr = flip union unionWith f = unionWithKey (const f) unionSeqWith = unionSeqWithUsingReduce intersectionWith f = intersectionWithKey (const f) difference mx my = mergeVFM (\v1 v2 -> case v2 of Nothing -> v1 Just _ -> Nothing) mx my properSubset = properSubsetUsingSubset subset (FM nx fmbx) (FM ny fmby) = subsetEqM nx ny && subsetEqFMB fmbx fmby where subsetEqM Nothing _ = True subsetEqM (Just _) Nothing = False subsetEqM (Just _) (Just _) = True subsetEqFMB E _ = True subsetEqFMB fmbx@(I _ _ _ _ _ _) E = nullFMB fmbx subsetEqFMB fmbx@(I sizex kx vx lx (FMB' mx) rx) fmby@(I sizey ky vy ly (FMB' my) ry) | sizex >= sizey = let (vy, ly, FMB' my, ry) = splayFMB kx fmby in subsetEqM vx vy && subsetEqFMB lx ly && subsetEqFMB mx my && subsetEqFMB rx ry | otherwise = let (vx, lx, FMB' mx, rx) = splayFMB ky fmbx in subsetEqM vx vy && subsetEqFMB lx ly && subsetEqFMB mx my && subsetEqFMB rx ry submapBy = submapByUsingLookupM properSubmapBy = properSubmapByUsingSubmapBy sameMapBy = sameMapByUsingSubmapBy properSubmap = A.properSubmap submap = A.submap sameMap = A.sameMap -- Assoc toSeq = toSeqUsingFoldWithKey keys = keysUsingFoldWithKey mapWithKey f = mapKVFM (\k mv -> case mv of Nothing -> Nothing Just v -> Just (f k v)) foldWithKey op r (FM n fmb) = foldWithKeyB [] n . foldWithKeyFM [] fmb $ r where foldWithKeyB _ Nothing = id foldWithKeyB k (Just v) = op k v foldWithKeyFM _ E = id foldWithKeyFM ks (I _ k v l (FMB' m) r) = foldWithKeyFM ks l . foldWithKeyB (reverse (k:ks)) v . foldWithKeyFM (k:ks) m . foldWithKeyFM ks r -- FIXME, make this strict foldWithKey' = foldWithKey filterWithKey f = mapKVFM (\k mv -> case mv of Nothing -> mv Just v -> if f k v then mv else Nothing) partitionWithKey f m = (filterWithKey f m, filterWithKey (\k v -> not (f k v)) m) -- FiniteMap unionWithKey f = mergeKVFM (\k v1m v2m -> case v1m of Nothing -> v2m Just v1 -> case v2m of Nothing -> v1m Just v2 -> Just (f k v1 v2)) unionSeqWithKey = unionSeqWithKeyUsingReduce intersectionWithKey f = mergeKVFM (\k v1m v2m -> case v1m of Nothing -> Nothing Just v1 -> case v2m of Nothing -> Nothing Just v2 -> Just (f k v1 v2)) -- OrdAssocX minViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a) minViewFMB E _ = fail $ moduleName++".minView: empty map" minViewFMB (I i k (Just v) E m r) f = return (v, f (I i k Nothing E m r)) minViewFMB (I _ _ Nothing E (FMB' E) _) _ = error $ moduleName++".minView: bug!" minViewFMB (I _ k Nothing E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) minViewFMB (I _ k mv l m r) f = minViewFMB l (\l' -> f (mkVBalancedFMB k mv l' m r)) minView :: Monad m => FM k a -> m (a,FM k a) minView (FM (Just v) fmb) = return (v, FM Nothing fmb) minView (FM Nothing fmb) = minViewFMB fmb (FM Nothing) minViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a) minViewWithKeyFMB E _ _ = fail $ moduleName++".minView: empty map" minViewWithKeyFMB (I i k (Just v) E m r) kf f = return ((kf [k],v),f (I i k Nothing E m r)) minViewWithKeyFMB (I _ _ Nothing E (FMB' E) _) _ _ = error $ moduleName++".minViewWithKey: bug!" minViewWithKeyFMB (I _ k Nothing E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:)) (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) minViewWithKeyFMB (I _ k mv l m r) kf f = minViewWithKeyFMB l kf (\l' -> f (mkVBalancedFMB k mv l' m r)) minViewWithKey :: Monad m => FM k a -> m (([k],a),FM k a) minViewWithKey (FM (Just v) fmb) = return (([],v),FM Nothing fmb) minViewWithKey (FM Nothing fmb) = minViewWithKeyFMB fmb id (FM Nothing) minElemFMB :: FMB k a -> a minElemFMB E = error $ moduleName++".minElem: empty map" minElemFMB (I _ _ (Just v) E _ _) = v minElemFMB (I _ _ Nothing E (FMB' m) _) = minElemFMB m minElemFMB (I _ _ _ l _ _) = minElemFMB l minElem :: FM t1 t -> t minElem (FM (Just v) _) = v minElem (FM Nothing fmb) = minElemFMB fmb minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a) minElemWithKeyFMB _ E = error $ moduleName++".minElemWithKey: empty map" minElemWithKeyFMB kf (I _ k (Just v) E _ _) = (kf [k],v) minElemWithKeyFMB kf (I _ k Nothing E (FMB' m) _) = minElemWithKeyFMB (kf . (k:)) m minElemWithKeyFMB kf (I _ _ _ l _ _) = minElemWithKeyFMB kf l minElemWithKey :: FM k a -> ([k],a) minElemWithKey (FM (Just v) _) = ([],v) minElemWithKey (FM Nothing fmb) = minElemWithKeyFMB id fmb deleteMin :: Ord k => FM k a -> FM k a deleteMin = deleteMinUsingMinView unsafeInsertMin :: Ord k => [k] -> a -> FM k a -> FM k a unsafeInsertMin = insert maxViewFMB :: Monad m => FMB k a -> (FMB k a -> FM k a) -> m (a, FM k a) maxViewFMB (I _ _ (Just v) l (FMB' E) E) f = return (v, f l) --maxViewFMB (I i k (Just v) l (FMB' E) E) f = return (v, f (I i k Nothing l (FMB' E) E)) maxViewFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxView: bug!" maxViewFMB (I i k mv l (FMB' m) E) f = maxViewFMB m (\m' -> f (I i k mv l (FMB' m') E)) maxViewFMB (I _ k mv l m r) f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r')) maxViewFMB E _ = error $ moduleName++".maxView: bug!" maxView :: Monad m => FM k a -> m (a, FM k a) maxView (FM Nothing E) = fail $ moduleName++".maxView: empty map" maxView (FM (Just v) E) = return (v,FM Nothing E) maxView (FM mv fmb) = maxViewFMB fmb (FM mv) maxViewWithKeyFMB :: Monad m => FMB k a -> ([k] -> [k]) -> (FMB k a -> FM k a) -> m (([k],a),FM k a) maxViewWithKeyFMB (I _ k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l) maxViewWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ _ = error $ moduleName++".maxViewWithKey: bug!" maxViewWithKeyFMB (I i k mv l (FMB' m) E) kf f = maxViewWithKeyFMB m (kf . (k:)) (\m' -> f (I i k mv l (FMB' m') E)) maxViewWithKeyFMB (I _ k mv l m r) kf f = maxViewWithKeyFMB r kf (\r' -> f (mkVBalancedFMB k mv l m r')) maxViewWithKeyFMB E _ _ = error $ moduleName++".maxViewWithKey: bug!" maxViewWithKey :: Monad m => FM k a -> m (([k],a), FM k a) maxViewWithKey (FM Nothing E) = fail $ moduleName++".maxViewWithKey: empty map" maxViewWithKey (FM (Just v) E) = return (([],v),FM Nothing E) maxViewWithKey (FM mv fmb) = maxViewWithKeyFMB fmb id (FM mv) maxElemFMB :: FMB k a -> a maxElemFMB (I _ _ (Just v) _ (FMB' E) E) = v maxElemFMB (I _ _ Nothing _ (FMB' E) E) = error $ moduleName++".maxElem: bug!" maxElemFMB (I _ _ _ _ (FMB' m) E) = maxElemFMB m maxElemFMB (I _ _ _ _ _ r) = maxElemFMB r maxElemFMB E = error $ moduleName++".maxElem: bug!" maxElem :: FM k a -> a maxElem (FM (Just v) E) = v maxElem (FM Nothing E) = error $ moduleName++".maxElem: empty map" maxElem (FM _ fmb) = maxElemFMB fmb maxElemWithKeyFMB :: FMB k a -> ([k] -> [k]) -> ([k],a) maxElemWithKeyFMB (I _ k (Just v) _ (FMB' E) E) kf = (kf [k],v) maxElemWithKeyFMB (I _ _ Nothing _ (FMB' E) E) _ = error $ moduleName++".maxElemWithKey: bug!" maxElemWithKeyFMB (I _ k _ _ (FMB' m) E) kf = maxElemWithKeyFMB m (kf . (k:)) maxElemWithKeyFMB (I _ _ _ _ _ r) kf = maxElemWithKeyFMB r kf maxElemWithKeyFMB E _ = error $ moduleName++".maxElemWithKey: bug!" maxElemWithKey :: FM k a -> ([k],a) maxElemWithKey (FM (Just v) E) = ([],v) maxElemWithKey (FM Nothing E) = error $ moduleName++".maxElemWithKey: empty map" maxElemWithKey (FM _ fmb) = maxElemWithKeyFMB fmb id deleteMax :: Ord k => FM k a -> FM k a deleteMax = deleteMaxUsingMaxView unsafeInsertMax :: Ord k => [k] -> a -> FM k a -> FM k a unsafeInsertMax = insert unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq ([k],a) -> FM k a unsafeFromOrdSeq = fromSeq unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a unsafeAppend = union -- FIXME this doesn't respect the structural invariant... why?? {- unsafeAppend (FM (Just v) fmb1) (FM Nothing fmb2) = FM (Just v) (appendFMB fmb1 fmb2) unsafeAppend (FM Nothing fmb1) (FM mv fmb2) = FM mv (appendFMB fmb1 fmb2) unsafeAppend (FM (Just _) _) (FM (Just _) _) = error $ moduleName++".unsafeAppend: bug!" -} filterL_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a filterL_FMB _ _ _ E = E filterL_FMB f k ks (I _ key mv l (FMB' m) r) | key < k = mkVBalancedFMB key mv l (FMB' m) (filterL_FMB f k ks r) | key > k = filterL_FMB f k ks l | otherwise = case ks of [] -> f k mv l (k':ks') -> mkVBalancedFMB key mv l (FMB' (filterL_FMB f k' ks' m)) E filterLT :: Ord k => [k] -> FM k a -> FM k a filterLT [] _ = FM Nothing E filterLT (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\_ _ l -> l) k ks fmb) filterLE :: Ord k => [k] -> FM k a -> FM k a filterLE [] (FM mv _) = FM mv E filterLE (k:ks) (FM mv fmb) = FM mv (filterL_FMB (\k mv l -> mkVBalancedFMB k mv l (FMB' E) E) k ks fmb) filterG_FMB :: Ord k => (k -> Maybe a -> FMB k a -> FMB k a -> FMB k a) -> k -> [k] -> FMB k a -> FMB k a filterG_FMB _ _ _ E = E filterG_FMB f k ks (I _ key mv l (FMB' m) r) | key < k = filterG_FMB f k ks r | key > k = mkVBalancedFMB key mv (filterG_FMB f k ks l) (FMB' m) r | otherwise = case ks of [] -> f k mv m r (k':ks') -> mkVBalancedFMB key Nothing E (FMB' (filterG_FMB f k' ks' m)) r filterGT :: Ord k => [k] -> FM k a -> FM k a filterGT [] (FM _ fmb) = FM Nothing fmb filterGT (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k _ m r -> mkVBalancedFMB k Nothing E (FMB' m) r) k ks fmb) filterGE :: Ord k => [k] -> FM k a -> FM k a filterGE [] fm = fm filterGE (k:ks) (FM _ fmb) = FM Nothing (filterG_FMB (\k mv m r -> mkVBalancedFMB k mv E (FMB' m) r) k ks fmb) --FIXME do better... partitionLT_GE :: Ord k => [k] -> FM k a -> (FM k a,FM k a) partitionLT_GE ks fm = (filterLT ks fm, filterGE ks fm) partitionLE_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a) partitionLE_GT ks fm = (filterLE ks fm, filterGT ks fm) partitionLT_GT :: Ord k => [k] -> FM k a -> (FM k a,FM k a) partitionLT_GT ks fm = (filterLT ks fm, filterGT ks fm) toOrdSeq = toOrdSeqUsingFoldrWithKey -- instance declarations instance Ord k => A.AssocX (FM k) [k] where {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; union = union; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; lookupAndDeleteAll = lookupAndDeleteAll; lookupWithDefault = lookupWithDefault; adjust = adjust; adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; adjustAllOrInsert = adjustAllOrInsert; adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; elements = elements; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Ord k => A.Assoc (FM k) [k] where {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; filterWithKey = filterWithKey; partitionWithKey = partitionWithKey} instance Ord k => A.FiniteMapX (FM k) [k] where {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; insertWith = insertWith; insertWithKey = insertWithKey; insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; unionl = unionl; unionr = unionr; unionWith = unionWith; unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; difference = difference; properSubset = properSubset; subset = subset; properSubmapBy = properSubmapBy; submapBy = submapBy; sameMapBy = sameMapBy} instance Ord k => A.FiniteMap (FM k) [k] where {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; intersectionWithKey = intersectionWithKey} instance Ord k => A.OrdAssocX (FM k) [k] where {minView = minView; minElem = minElem; deleteMin = deleteMin; unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance Ord k => A.OrdAssoc (FM k) [k] where {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; toOrdSeq = toOrdSeq} instance Ord k => A.OrdFiniteMapX (FM k) [k] instance Ord k => A.OrdFiniteMap (FM k) [k] instance Ord k => Functor (FM k) where fmap = map instance (Ord k, Show k, Show a) => Show (FM k a) where showsPrec = showsPrecUsingToList instance (Ord k, Read k, Read a) => Read (FM k a) where readsPrec = readsPrecUsingFromList instance (Ord k, Eq a) => Eq (FM k a) where (==) = sameMap instance (Ord k, Ord a) => Ord (FM k a) where compare = compareUsingToOrdList -- -- Test code follows -- keyInvariantFMB :: Ord k => (k -> Bool) -> FMB k a -> Bool keyInvariantFMB _ E = True keyInvariantFMB p (I _ k _ l _ r) = p k && keyInvariantFMB p l && keyInvariantFMB p r actualSizeFMB :: FMB k a -> Int actualSizeFMB E = 0 actualSizeFMB (I _ _ _ l _ r) = 1 + actualSizeFMB l + actualSizeFMB r structuralInvariantFMB :: Ord k => FMB k a -> Bool structuralInvariantFMB E = True structuralInvariantFMB fmb@(I size k _ l (FMB' m) r) = structuralInvariantFMB l && structuralInvariantFMB m && structuralInvariantFMB r && keyInvariantFMB (k) 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 EdisonCore-1.3.2.1/src/Data/Edison/Assoc/StandardMap.hs0000644000000000000000000004131713223626550020571 0ustar0000000000000000-- | -- Module : Data.Edison.Assoc.AssocList -- Copyright : Copyright (c) 2006, 2008 Robert Dockins -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- The standard library "Data.Map" repackaged as an Edison -- associative collection. module Data.Edison.Assoc.StandardMap ( -- * Type of standard finite maps FM, -- * AssocX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, adjustOrDelete,adjustOrDeleteAll,strict,strictWith, map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, -- * FiniteMapX operations fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, properSubmap,submap,sameMap, -- * OrdAssocX operations minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1', foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE, partitionLT_GE, partitionLE_GT, partitionLT_GT, -- * Assoc operations toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, -- * OrdAssoc operations minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, -- * FiniteMap operations unionWithKey,unionSeqWithKey,intersectionWithKey, -- * Documentation moduleName ) where import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter) import qualified Prelude import qualified Data.Edison.Assoc as A import qualified Data.Edison.Seq as S import qualified Data.Edison.Seq.ListSeq as L import Data.Edison.Assoc.Defaults import Data.Int import Test.QuickCheck (Arbitrary(..), CoArbitrary(..)) import qualified Data.Map as DM type FM = DM.Map moduleName :: String moduleName = "Data.Edison.Assoc.StandardMap" empty :: FM k a singleton :: Ord k => k -> a -> FM k a fromSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a insert :: Ord k => k -> a -> FM k a -> FM k a insertSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a union :: Ord k => FM k a -> FM k a -> FM k a unionSeq :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a delete :: Ord k => k -> FM k a -> FM k a deleteAll :: Ord k => k -> FM k a -> FM k a deleteSeq :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a null :: FM k a -> Bool size :: FM k a -> Int member :: Ord k => k -> FM k a -> Bool count :: Ord k => k -> FM k a -> Int lookup :: Ord k => k -> FM k a -> a lookupAll :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a lookupM :: (Ord k,Monad m) => k -> FM k a -> m a lookupWithDefault :: Ord k => a -> k -> FM k a -> a lookupAndDelete :: Ord k => k -> FM k a -> (a, FM k a) lookupAndDeleteM :: (Ord k,Monad m) => k -> FM k a -> m (a, FM k a) lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a) adjust :: Ord k => (a->a) -> k -> FM k a -> FM k a adjustAll :: Ord k => (a->a) -> k -> FM k a -> FM k a adjustOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a adjustOrDelete :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a strict :: Ord k => FM k a -> FM k a strictWith :: Ord k => (a -> b) -> FM k a -> FM k a map :: Ord k => (a -> b) -> FM k a -> FM k b fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b fold1 :: Ord k => (a -> a -> a) -> FM k a -> a fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b fold1' :: Ord k => (a -> a -> a) -> FM k a -> a filter :: Ord k => (a -> Bool) -> FM k a -> FM k a partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a) elements :: (Ord k,S.Sequence seq) => FM k a -> seq a minView :: (Ord k,Monad m) => FM k a -> m (a, FM k a) minElem :: Ord k => FM k a -> a deleteMin :: Ord k => FM k a -> FM k a unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a maxView :: (Ord k,Monad m) => FM k a -> m (a, FM k a) maxElem :: Ord k => FM k a -> a deleteMax :: Ord k => FM k a -> FM k a unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a filterLT :: Ord k => k -> FM k a -> FM k a filterGT :: Ord k => k -> FM k a -> FM k a filterLE :: Ord k => k -> FM k a -> FM k a filterGE :: Ord k => k -> FM k a -> FM k a partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a) partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) fromSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> FM k a fromSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a insertWith :: Ord k => (a -> a -> a) -> k -> a -> FM k a -> FM k a insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a insertSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a insertSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a unionl :: Ord k => FM k a -> FM k a -> FM k a unionr :: Ord k => FM k a -> FM k a -> FM k a unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a unionSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (FM k a) -> FM k a intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c difference :: Ord k => FM k a -> FM k b -> FM k a properSubset :: Ord k => FM k a -> FM k b -> Bool subset :: Ord k => FM k a -> FM k b -> Bool properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool properSubmap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool submap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool sameMap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) keys :: (Ord k,S.Sequence seq) => FM k a -> seq k mapWithKey :: Ord k => (k -> a -> b) -> FM k a -> FM k b foldWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b foldWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b filterWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a partitionWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a) minViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a) minElemWithKey :: Ord k => FM k a -> (k,a) maxViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a) maxElemWithKey :: Ord k => FM k a -> (k,a) foldrWithKey :: (k -> a -> b -> b) -> b -> FM k a -> b foldlWithKey :: (b -> k -> a -> b) -> b -> FM k a -> b foldrWithKey' :: (k -> a -> b -> b) -> b -> FM k a -> b foldlWithKey' :: (b -> k -> a -> b) -> b -> FM k a -> b toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) unionWithKey :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a unionSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (FM k a) -> FM k a intersectionWithKey :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c structuralInvariant :: Ord k => FM k a -> Bool structuralInvariant = DM.valid empty = DM.empty singleton = DM.singleton fromSeq = fromSeqUsingInsertSeq insert = DM.insert insertSeq = insertSeqUsingFoldr union = DM.union unionSeq = DM.unions . S.toList delete = DM.delete deleteAll = DM.delete -- by finite map property deleteSeq = deleteSeqUsingFoldr null = DM.null size = DM.size member = DM.member count = countUsingMember lookup k m = maybe (error (moduleName ++ ".lookup: failed")) id (DM.lookup k m) lookupM k m = maybe (fail (moduleName ++ ".lookupM: failed")) return (DM.lookup k m) lookupAll = lookupAllUsingLookupM lookupWithDefault = DM.findWithDefault lookupAndDelete = lookupAndDeleteDefault lookupAndDeleteM = lookupAndDeleteMDefault lookupAndDeleteAll = lookupAndDeleteAllDefault adjust = DM.adjust adjustAll = DM.adjust adjustOrInsert = adjustOrInsertUsingMember adjustAllOrInsert = adjustOrInsertUsingMember adjustOrDelete = DM.update adjustOrDeleteAll = DM.update strict xs = DM.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 EdisonCore-1.3.2.1/src/Data/Edison/Assoc/Defaults.hs0000644000000000000000000002643313223626550020144 0ustar0000000000000000-- | -- Module : Data.Edison.Assoc.Defaults -- Copyright : Copyright (c) 1998, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : internal (unstable) -- Portability : GHC, Hugs (MPTC and FD) -- -- This module provides default implementations of many of the associative -- collection operations. These function are used to fill in collection -- implementations and are not intended to be used directly by end users. module Data.Edison.Assoc.Defaults where import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter) import Data.Edison.Assoc import qualified Data.Edison.Seq as S import qualified Data.Edison.Seq.ListSeq as L import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) singletonUsingInsert :: (Assoc m k) => k -> a -> m a singletonUsingInsert k v = insert k v empty fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a fromSeqUsingInsertSeq kvs = insertSeq kvs empty insertSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a unionSeqUsingReduce ms = S.reducel union empty ms deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a deleteSeqUsingFoldr ks m = S.foldr delete m ks memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool memberUsingLookupM k m = case lookupM k m of Just _ -> True Nothing -> False countUsingMember :: AssocX m k => k -> m a -> Int countUsingMember k m = if member k m then 1 else 0 lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a lookupAllUsingLookupM k m = case lookupM k m of Just x -> S.singleton x Nothing -> S.empty lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a lookupWithDefaultUsingLookupM d k m = case lookupM k m of Just x -> x Nothing -> d partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a) partitionUsingFilter f m = (filter f m, filter (not . f) m) fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a fold1UsingElements op m = L.foldr1 op (elements m) elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a elementsUsingFold = fold S.lcons S.empty nullUsingElements :: (AssocX m k) => m a -> Bool nullUsingElements m = case elements m of [] -> True _ -> False insertWithUsingLookupM :: FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a insertWithUsingLookupM f k x m = case lookupM k m of Nothing -> insert k x m Just y -> insert k (f x y) m fromSeqWithUsingInsertSeqWith :: (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty fromSeqWithKeyUsingInsertSeqWithKey :: (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty insertWithKeyUsingInsertWith :: FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a insertWithKeyUsingInsertWith f k = insertWith (f k) k insertSeqWithUsingInsertWith :: (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a -> m a insertSeqWithUsingInsertWith f kvs m = S.foldr (uncurry (insertWith f)) m kvs insertSeqWithKeyUsingInsertWithKey :: (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a -> m a insertSeqWithKeyUsingInsertWithKey f kvs m = S.foldr (uncurry (insertWithKey f)) m kvs unionSeqWithUsingReduce :: (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms unionSeqWithUsingFoldr :: (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a) toSeqUsingFoldWithKey = foldWithKey conspair S.empty where conspair k v kvs = S.lcons (k,v) kvs keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k keysUsingFoldWithKey = foldWithKey conskey S.empty where conskey k _ ks = S.lcons k ks unionWithUsingInsertWith :: FiniteMap m k => (a -> a -> a) -> m a -> m a -> m a unionWithUsingInsertWith f m1 m2 = foldWithKey (insertWith f) m2 m1 unionWithKeyUsingInsertWithKey :: FiniteMap m k => (k -> a -> a -> a) -> m a -> m a -> m a unionWithKeyUsingInsertWithKey f m1 m2 = foldWithKey (insertWithKey f) m2 m1 unionSeqWithKeyUsingReduce :: (FiniteMap m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (m a) -> m a unionSeqWithKeyUsingReduce f ms = S.reducel (unionWithKey f) empty ms unionSeqWithKeyUsingFoldr :: (FiniteMap m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (m a) -> m a unionSeqWithKeyUsingFoldr f ms = S.foldr (unionWithKey f) empty ms intersectionWithUsingLookupM :: FiniteMap m k => (a -> b -> c) -> m a -> m b -> m c intersectionWithUsingLookupM f m1 m2 = foldWithKey ins empty m1 where ins k x m = case lookupM k m2 of Nothing -> m Just y -> insert k (f x y) m intersectionWithKeyUsingLookupM :: FiniteMap m k => (k -> a -> b -> c) -> m a -> m b -> m c intersectionWithKeyUsingLookupM f m1 m2 = foldWithKey ins empty m1 where ins k x m = case lookupM k m2 of Nothing -> m Just y -> insert k (f k x y) m differenceUsingDelete :: FiniteMap m k => m a -> m b -> m a differenceUsingDelete m1 m2 = foldWithKey del m1 m2 where del k _ m = delete k m properSubsetUsingSubset :: FiniteMapX m k => m a -> m b -> Bool properSubsetUsingSubset m1 m2 = size m1 < size m2 && subset m1 m2 subsetUsingMember :: FiniteMap m k => m a -> m b -> Bool subsetUsingMember m1 m2 = foldWithKey mem True m1 where mem k _ b = member k m2 && b submapByUsingLookupM :: FiniteMap m k => (a -> a -> Bool) -> m a -> m a -> Bool submapByUsingLookupM f m1 m2 = foldWithKey aux True m1 where aux k x b = case lookupM k m2 of Nothing -> False Just y -> f x y && b properSubmapByUsingSubmapBy :: FiniteMapX m k => (a -> a -> Bool) -> m a -> m a -> Bool properSubmapByUsingSubmapBy f m1 m2 = size m1 < size m2 && submapBy f m1 m2 sameMapByUsingOrdLists :: OrdFiniteMap m k => (a -> a -> Bool) -> m a -> m a -> Bool sameMapByUsingOrdLists f m1 m2 = let comp (k1,x1) (k2,x2) = k1 == k2 && f x1 x2 in L.foldr (&&) (size m1 == size m2) (L.zipWith comp (toOrdList m1) (toOrdList m2)) sameMapByUsingSubmapBy :: FiniteMapX m k => (a -> a -> Bool) -> m a -> m a -> Bool sameMapByUsingSubmapBy f m1 m2 = size m1 == size m2 && submapBy f m1 m2 lookupAndDeleteDefault :: AssocX m k => k -> m a -> (a, m a) lookupAndDeleteDefault k m = case lookupM k m of Nothing -> error (instanceName m ++ ".lookupAndDelete: lookup failed") Just x -> (x, delete k m) lookupAndDeleteMDefault :: (Monad rm, AssocX m k) => k -> m a -> rm (a, m a) lookupAndDeleteMDefault k m = case lookupM k m of Nothing -> fail (instanceName m ++ ".lookupAndDelete: lookup failed") Just x -> return (x, delete k m) lookupAndDeleteAllDefault :: (S.Sequence seq, AssocX m k) => k -> m a -> (seq a,m a) lookupAndDeleteAllDefault k m = (lookupAll k m,deleteAll k m) adjustOrInsertUsingMember :: AssocX m k => (a -> a) -> a -> k -> m a -> m a adjustOrInsertUsingMember f z k m = if member k m then adjust f k m else insert k z m adjustOrDeleteDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a adjustOrDeleteDefault f k m = case lookupAndDeleteM k m of Nothing -> m Just (element,m') -> case f element of Nothing -> m' Just x -> insert k x m' adjustOrDeleteAllDefault :: AssocX m k => (a -> Maybe a) -> k -> m a -> m a adjustOrDeleteAllDefault f k m = let (elems,m') = lookupAndDeleteAll k m adjSeq = S.map f elems ins Nothing n = n ins (Just x) n = insert k x n in L.foldr ins m' adjSeq minElemUsingMinView :: OrdAssocX m k => m a -> a minElemUsingMinView fm = case minView fm of Nothing -> error $ (instanceName fm)++".minElem: empty map" Just (x,_) -> x deleteMinUsingMinView :: OrdAssocX m k => m a -> m a deleteMinUsingMinView fm = case minView fm of Nothing -> error $ (instanceName fm)++".deleteMin: empty map" Just (_,m) -> m minElemWithKeyUsingMinViewWithKey :: OrdAssoc m k => m a -> (k,a) minElemWithKeyUsingMinViewWithKey fm = case minViewWithKey fm of Nothing -> error $ (instanceName fm)++".minElemWithKey: empty map" Just (x,_) -> x maxElemUsingMaxView :: OrdAssocX m k => m a -> a maxElemUsingMaxView fm = case maxView fm of Nothing -> error $ (instanceName fm)++".maxElem: empty map" Just (x,_) -> x deleteMaxUsingMaxView :: OrdAssocX m k => m a -> m a deleteMaxUsingMaxView fm = case maxView fm of Nothing -> error $ (instanceName fm)++".deleteMax: empty map" Just (_,m) -> m maxElemWithKeyUsingMaxViewWithKey :: OrdAssoc m k => m a -> (k,a) maxElemWithKeyUsingMaxViewWithKey fm = case maxViewWithKey fm of Nothing -> error $ (instanceName fm)++".maxElemWithKey: empty map" Just (x,_) -> x toOrdSeqUsingFoldrWithKey :: (OrdAssoc m k,S.Sequence seq) => m a -> seq (k,a) toOrdSeqUsingFoldrWithKey = foldrWithKey (\k x z -> S.lcons (k,x) z) S.empty showsPrecUsingToList :: (Show k, Show a, Assoc m k) => Int -> m a -> ShowS showsPrecUsingToList i xs rest | i == 0 = concat [ instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest] | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)] readsPrecUsingFromList :: (Read k, Read a, AssocX m k) => Int -> ReadS (m a) readsPrecUsingFromList _ xs = let result = maybeParens p xs p ys = tokenMatch ((instanceName x)++".fromSeq") ys >>= readsPrec 10 >>= \(l,rest) -> return (fromList l,rest) -- play games with the typechecker so we don't have to use -- extensions for scoped type variables ~[(x,_)] = result in result showsPrecUsingToOrdList :: (Show k,Show a,OrdAssoc m k) => Int -> m a -> ShowS showsPrecUsingToOrdList i xs rest | i == 0 = concat [ instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) rest] | otherwise = concat ["(",instanceName xs,".unsafeFromOrdSeq ",showsPrec 10 (toOrdList xs) (')':rest)] readsPrecUsingUnsafeFromOrdSeq :: (Read k,Read a,OrdAssoc m k) => Int -> ReadS (m a) readsPrecUsingUnsafeFromOrdSeq i xs = let result = maybeParens p xs p ys = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") ys >>= readsPrec i >>= \(l,rest) -> return (unsafeFromOrdList l,rest) -- play games with the typechecker so we don't have to use -- extensions for scoped type variables ~[(x,_)] = result in result compareUsingToOrdList :: (Ord a, OrdAssoc m k) => m a -> m a -> Ordering compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys) where cmp [] [] = EQ cmp [] _ = LT cmp _ [] = GT cmp (v:vs) (z:zs) = case compare v z of EQ -> cmp vs zs c -> c EdisonCore-1.3.2.1/src/Data/Edison/Assoc/PatriciaLoMap.hs0000644000000000000000000007121413223626550021057 0ustar0000000000000000-- | -- Module : Data.Edison.Assoc.PatriciaLoMap -- Copyright : Copyright (c) 1998, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Finite maps implemented as little-endian Patricia trees. -- -- /References:/ -- -- * Chris Okasaki and Any Gill. \"Fast Mergeable Integer Maps\". -- Workshop on ML, September 1998, pages 77-86. module Data.Edison.Assoc.PatriciaLoMap ( -- * Type of little-endian Patricia trees FM, -- * AssocX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll,strict,strictWith, lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert,map, fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, -- * Assoc operations toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, -- * FiniteMapX operations fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, properSubmap,submap,sameMap, -- * FiniteMap operations unionWithKey,unionSeqWithKey,intersectionWithKey, -- * OrdAssocX operations minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, unsafeInsertMax, foldr, foldr', foldr1, foldr1', foldl, foldl', foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE, partitionLT_GE, partitionLE_GT, partitionLT_GT, -- * OrdAssoc operations minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, -- * Documentation moduleName ) where import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter) import qualified Prelude import Control.Monad.Identity (runIdentity) import Data.Monoid import Data.Semigroup as SG import qualified Data.Edison.Assoc as A import qualified Data.Edison.Seq as S import qualified Data.Edison.Seq.ListSeq as L import Data.Edison.Assoc.Defaults import Data.Int import Data.Bits import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant) moduleName :: String moduleName = "Data.Edison.Assoc.PatriciaLoMap" data FM a = E | L Int a | B Int Int !(FM a) !(FM a) -- Invariants: -- * No B node has an E child -- * first argument to B is a prefix -- * second argument to B is the "branching bit" and is -- always an exact power of two -- * all bits in the prefix >= the branching bit are zeros -- * valid prefix bits match all subnodes structuralInvariant :: FM a -> Bool structuralInvariant E = True structuralInvariant (L _ _) = True structuralInvariant x = inv 0 0 x inv :: Int -> Int -> FM a -> Bool inv _ _ E = False inv pre msk (L k _) = k .&. msk == pre inv pre msk (B p m t0 t1) = (p .&. msk == pre) && (bitcount 0 m == 1) && (p .&. (complement (m - 1)) == 0) && inv p0 msk' t0 && inv p1 msk' t1 where p0 = p p1 = p .|. m msk' = (m `shiftL` 1) - 1 bitcount :: Int -> Int -> Int bitcount a 0 = a bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1)) -- auxiliary functions makeB :: Int -> Int -> FM t -> FM t -> FM t makeB _ _ E t = t makeB _ _ t E = t makeB p m t0 t1 = B p m t0 t1 lmakeB :: Int -> Int -> FM t -> FM t -> FM t lmakeB _ _ E t = t lmakeB p m t0 t1 = B p m t0 t1 rmakeB :: Int -> Int -> FM a -> FM a -> FM a rmakeB _ _ t E = t rmakeB p m t0 t1 = B p m t0 t1 lowestBit :: Int32 -> Int32 lowestBit x = x .&. (-x) branchingBit :: Int -> Int -> Int branchingBit p0 p1 = fromIntegral (lowestBit (fromIntegral p0 `xor` fromIntegral p1)) mask :: Int -> Int -> Int mask p m = fromIntegral (fromIntegral p .&. (fromIntegral m - (1 :: Int32))) zeroBit :: Int -> Int -> Bool zeroBit p m = (fromIntegral p) .&. (fromIntegral m) == (0 :: Int32) matchPrefix :: Int -> Int -> Int -> Bool matchPrefix k p m = mask k m == p join :: Int -> FM a -> Int -> FM a -> FM a join p0 t0 p1 t1 = let m = branchingBit p0 p1 in if zeroBit p0 m then B (mask p0 m) m t0 t1 else B (mask p0 m) m t1 t0 keepR :: forall t t1. t -> t1 -> t1 keepR _ y = y -- end auxiliary functions empty :: FM a empty = E singleton :: Int -> a -> FM a singleton k x = L k x fromSeq :: S.Sequence seq => seq (Int,a) -> FM a fromSeq = S.foldl (\t (k, x) -> insert k x t) E insert :: Int -> a -> FM a -> FM a insert k x E = L k x insert k x t@(L j _) = if j == k then L k x else join k (L k x) j t insert k x t@(B p m t0 t1) = if matchPrefix k p m then if zeroBit k m then B p m (insert k x t0) t1 else B p m t0 (insert k x t1) else join k (L k x) p t union :: FM a -> FM a -> FM a union s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then B p m (union s0 t) s1 else B p m s0 (union s1 t) else join p s q t | m > n = if matchPrefix p q n then if zeroBit p n then B q n (union s t0) t1 else B q n t0 (union s t1) else join p s q t | otherwise = if p == q then B p m (union s0 t0) (union s1 t1) else join p s q t union s@(B p m s0 s1) (L k x) = if matchPrefix k p m then if zeroBit k m then B p m (insert k x s0) s1 else B p m s0 (insert k x s1) else join k (L k x) p s union s@(B _ _ _ _) E = s union (L k x) t = insert k x t union E t = t delete :: Int -> FM a -> FM a delete _ E = E delete k t@(L j _) = if k == j then E else t delete k t@(B p m t0 t1) = if matchPrefix k p m then if zeroBit k m then lmakeB p m (delete k t0) t1 else rmakeB p m t0 (delete k t1) else t null :: FM a -> Bool null E = True null _ = False size :: FM a -> Int size E = 0 size (L _ _) = 1 size (B _ _ t0 t1) = size t0 + size t1 member :: Int -> FM a -> Bool member _ E = False member k (L j _) = (j == k) member k (B _ m t0 t1) = if zeroBit k m then member k t0 else member k t1 lookup :: Int -> FM a -> a lookup k m = runIdentity (lookupM k m) lookupM :: (Monad rm) => Int -> FM a -> rm a lookupM _ E = fail "PatriciaLoMap.lookup: lookup failed" lookupM k (L j x) | j == k = return x | otherwise = fail "PatriciaLoMap.lookup: lookup failed" lookupM k (B _ m t0 t1) = if zeroBit k m then lookupM k t0 else lookupM k t1 doLookupAndDelete :: z -> (a -> FM a -> z) -> Int -> FM a -> z doLookupAndDelete onFail _ _ E = onFail doLookupAndDelete onFail cont k (L j x) | j == k = cont x E | otherwise = onFail doLookupAndDelete onFail cont k (B p m t0 t1) | zeroBit k m = doLookupAndDelete onFail (\x t0' -> cont x (makeB p m t0' t1)) k t0 | otherwise = doLookupAndDelete onFail (\x t1' -> cont x (makeB p m t0 t1')) k t1 lookupAndDelete :: Int -> FM a -> (a, FM a) lookupAndDelete = doLookupAndDelete (error "PatriciaLoMap.lookupAndDelete: lookup failed") (,) lookupAndDeleteM :: Monad m => Int -> FM a -> m (a, FM a) lookupAndDeleteM = doLookupAndDelete (fail "PatriciaLoMap.lookupAndDelete: lookup failed") (\x m -> return (x,m)) lookupAndDeleteAll :: S.Sequence seq => Int -> FM a -> (seq a,FM a) lookupAndDeleteAll k m = doLookupAndDelete (S.empty, m) (\x m' -> (S.singleton x,m')) k m adjust :: (a -> a) -> Int -> FM a -> FM a adjust _ _ E = E adjust f k t@(L j x) = if k == j then L k (f x) else t adjust f k t@(B p m t0 t1) = if matchPrefix k p m then if zeroBit k m then B p m (adjust f k t0) t1 else B p m t0 (adjust f k t1) else t -- FIXME can we do better than this? adjustOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a adjustOrInsert = adjustOrInsertUsingMember adjustAllOrInsert :: (a -> a) -> a -> Int -> FM a -> FM a adjustAllOrInsert = adjustOrInsertUsingMember adjustOrDelete :: (a -> Maybe a) -> Int -> FM a -> FM a adjustOrDelete = adjustOrDeleteDefault adjustOrDeleteAll :: (a -> Maybe a) -> Int -> FM a -> FM a adjustOrDeleteAll = adjustOrDeleteDefault map :: (a -> b) -> FM a -> FM b map _ E = E map f (L k x) = L k (f x) map f (B p m t0 t1) = B p m (map f t0) (map f t1) fold :: (a -> b -> b) -> b -> FM a -> b fold _ c E = c fold f c (L _ x) = f x c fold f c (B _ _ t0 t1) = fold f (fold f c t1) t0 fold' :: (a -> b -> b) -> b -> FM a -> b fold' _ c E = c fold' f c (L _ x) = c `seq` f x c fold' f c (B _ _ t0 t1) = c `seq` (fold f $! (fold f c t1)) t0 fold1 :: (a -> a -> a) -> FM a -> a fold1 _ E = error "PatriciaLoMap.fold1: empty map" fold1 _ (L _ x) = x fold1 f (B _ _ t0 t1) = f (fold1 f t0) (fold1 f t1) fold1' :: (a -> a -> a) -> FM a -> a fold1' _ E = error "PatriciaLoMap.fold1: empty map" fold1' _ (L _ x) = x fold1' f (B _ _ t0 t1) = f (fold1' f t0) $! (fold1' f t1) filter :: (a -> Bool) -> FM a -> FM a filter _ E = E filter g t@(L _ x) = if g x then t else E filter g (B p m t0 t1) = makeB p m (filter g t0) (filter g t1) partition :: (a -> Bool) -> FM a -> (FM a, FM a) partition _ E = (E, E) partition g t@(L _ x) = if g x then (t, E) else (E, t) partition g (B p m t0 t1) = let (t0',t0'') = partition g t0 (t1',t1'') = partition g t1 in (makeB p m t0' t1', makeB p m t0'' t1'') fromSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a fromSeqWith f = S.foldl (\t (k, x) -> insertWith f k x t) E insertWith :: (a -> a -> a) -> Int -> a -> FM a -> FM a insertWith _ k x E = L k x insertWith f k x t@(L j y) = if j == k then L k (f x y) else join k (L k x) j t insertWith f k x t@(B p m t0 t1) = if matchPrefix k p m then if zeroBit k m then B p m (insertWith f k x t0) t1 else B p m t0 (insertWith f k x t1) else join k (L k x) p t unionl :: FM a -> FM a -> FM a unionl s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then B p m (unionl s0 t) s1 else B p m s0 (unionl s1 t) else join p s q t | m > n = if matchPrefix p q n then if zeroBit p n then B q n (unionl s t0) t1 else B q n t0 (unionl s t1) else join p s q t | otherwise = if p == q then B p m (unionl s0 t0) (unionl s1 t1) else join p s q t unionl s@(B p m s0 s1) (L k x) = if matchPrefix k p m then if zeroBit k m then B p m (insertWith keepR k x s0) s1 else B p m s0 (insertWith keepR k x s1) else join k (L k x) p s unionl s@(B _ _ _ _) E = s unionl (L k x) t = insert k x t unionl E t = t unionr :: FM a -> FM a -> FM a unionr s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then B p m (unionr s0 t) s1 else B p m s0 (unionr s1 t) else join p s q t | m > n = if matchPrefix p q n then if zeroBit p n then B q n (unionr s t0) t1 else B q n t0 (unionr s t1) else join p s q t | otherwise = if p == q then B p m (unionr s0 t0) (unionr s1 t1) else join p s q t unionr s@(B p m s0 s1) (L k x) = if matchPrefix k p m then if zeroBit k m then B p m (insert k x s0) s1 else B p m s0 (insert k x s1) else join k (L k x) p s unionr s@(B _ _ _ _) E = s unionr (L k x) t = insertWith keepR k x t unionr E t = t unionWith :: (a -> a -> a) -> FM a -> FM a -> FM a unionWith f s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then B p m (unionWith f s0 t) s1 else B p m s0 (unionWith f s1 t) else join p s q t | m > n = if matchPrefix p q n then if zeroBit p n then B q n (unionWith f s t0) t1 else B q n t0 (unionWith f s t1) else join p s q t | otherwise = if p == q then B p m (unionWith f s0 t0) (unionWith f s1 t1) else join p s q t unionWith f s@(B p m s0 s1) (L k x) = if matchPrefix k p m then if zeroBit k m then B p m (insertWith (flip f) k x s0) s1 else B p m s0 (insertWith (flip f) k x s1) else join k (L k x) p s unionWith _ s@(B _ _ _ _) E = s unionWith f (L k x) t = insertWith f k x t unionWith _ E t = t intersectionWith :: (a -> b -> c) -> FM a -> FM b -> FM c intersectionWith f s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then intersectionWith f s0 t else intersectionWith f s1 t else E | m > n = if matchPrefix p q n then if zeroBit p n then intersectionWith f s t0 else intersectionWith f s t1 else E | otherwise = if p /= q then E else makeB p m (intersectionWith f s0 t0) (intersectionWith f s1 t1) intersectionWith f (B _ m s0 s1) (L k y) = case lookupM k (if zeroBit k m then s0 else s1) of Just x -> L k (f x y) Nothing -> E intersectionWith _ (B _ _ _ _) E = E intersectionWith f (L k x) t = case lookupM k t of Just y -> L k (f x y) Nothing -> E intersectionWith _ E _ = E difference :: FM a -> FM b -> FM a difference s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then lmakeB p m (difference s0 t) s1 else rmakeB p m s0 (difference s1 t) else s | m > n = if matchPrefix p q n then if zeroBit p n then difference s t0 else difference s t1 else s | otherwise = if p /= q then s else makeB p m (difference s0 t0) (difference s1 t1) difference s@(B p m s0 s1) (L k _) = if matchPrefix k p m then if zeroBit k m then lmakeB p m (delete k s0) s1 else rmakeB p m s0 (delete k s1) else s difference s@(B _ _ _ _) E = s difference s@(L k _) t = if member k t then E else s difference E _ = E properSubset :: FM a -> FM b -> Bool properSubset s t = case subset' s t of {LT -> True; _ -> False} subset' :: FM t -> FM t1 -> Ordering subset' s@(B p m s0 s1) (B q n t0 t1) | m < n = GT | m > n = if matchPrefix p q n then if zeroBit p n then subset' s t0 else subset' s t1 else GT | otherwise = if p == q then case (subset' s0 t0,subset' s1 t1) of (GT,_) -> GT (_,GT) -> GT (EQ,EQ) -> EQ (_,_) -> LT else GT subset' (B _ _ _ _) _ = GT subset' (L k _) (L j _) = if k == j then EQ else GT subset' (L k _) t = if member k t then LT else GT subset' E E = EQ subset' E _ = LT subset :: FM a -> FM b -> Bool subset s@(B p m s0 s1) (B q n t0 t1) | m < n = False | m > n = matchPrefix p q n && (if zeroBit p n then subset s t0 else subset s t1) | otherwise = (p == q) && subset s0 t0 && subset s1 t1 subset (B _ _ _ _) _ = False subset (L k _) t = member k t subset E _ = True properSubmapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool properSubmapBy = properSubmapByUsingSubmapBy submapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool submapBy = submapByUsingLookupM sameMapBy :: (a -> a -> Bool) -> FM a -> FM a -> Bool sameMapBy = sameMapByUsingSubmapBy properSubmap :: (Eq a) => FM a -> FM a -> Bool properSubmap = A.properSubmap submap :: (Eq a) => FM a -> FM a -> Bool submap = A.submap sameMap :: (Eq a) => FM a -> FM a -> Bool sameMap = A.sameMap mapWithKey :: (Int -> a -> b) -> FM a -> FM b mapWithKey _ E = E mapWithKey f (L k x) = L k (f k x) mapWithKey f (B p m t0 t1) = B p m (mapWithKey f t0) (mapWithKey f t1) foldWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b foldWithKey _ c E = c foldWithKey f c (L k x) = f k x c foldWithKey f c (B _ _ t0 t1) = foldWithKey f (foldWithKey f c t1) t0 foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b foldWithKey' _ c E = c foldWithKey' f c (L k x) = c `seq` f k x c foldWithKey' f c (B _ _ t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0 filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a filterWithKey _ E = E filterWithKey g t@(L k x) = if g k x then t else E filterWithKey g (B p m t0 t1) = makeB p m (filterWithKey g t0) (filterWithKey g t1) partitionWithKey :: (Int -> a -> Bool) -> FM a -> (FM a, FM a) partitionWithKey _ E = (E, E) partitionWithKey g t@(L k x) = if g k x then (t, E) else (E, t) partitionWithKey g (B p m t0 t1) = let (t0',t0'') = partitionWithKey g t0 (t1',t1'') = partitionWithKey g t1 in (makeB p m t0' t1', makeB p m t0'' t1'') unionWithKey :: (Int -> a -> a -> a) -> FM a -> FM a -> FM a unionWithKey f s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then B p m (unionWithKey f s0 t) s1 else B p m s0 (unionWithKey f s1 t) else join p s q t | m > n = if matchPrefix p q n then if zeroBit p n then B q n (unionWithKey f s t0) t1 else B q n t0 (unionWithKey f s t1) else join p s q t | otherwise = if p == q then B p m (unionWithKey f s0 t0) (unionWithKey f s1 t1) else join p s q t unionWithKey f s@(B p m s0 s1) (L k x) = if matchPrefix k p m then if zeroBit k m then B p m (insertWith (flip (f k)) k x s0) s1 else B p m s0 (insertWith (flip (f k)) k x s1) else join k (L k x) p s unionWithKey _ s@(B _ _ _ _) E = s unionWithKey f (L k x) t = insertWith (f k) k x t unionWithKey _ E t = t intersectionWithKey :: (Int -> a -> b -> c) -> FM a -> FM b -> FM c intersectionWithKey f s@(B p m s0 s1) t@(B q n t0 t1) | m < n = if matchPrefix q p m then if zeroBit q m then intersectionWithKey f s0 t else intersectionWithKey f s1 t else E | m > n = if matchPrefix p q n then if zeroBit p n then intersectionWithKey f s t0 else intersectionWithKey f s t1 else E | otherwise = if p /= q then E else makeB p m (intersectionWithKey f s0 t0) (intersectionWithKey f s1 t1) intersectionWithKey f (B _ m s0 s1) (L k y) = case lookupM k (if zeroBit k m then s0 else s1) of Just x -> L k (f k x y) Nothing -> E intersectionWithKey _ (B _ _ _ _) E = E intersectionWithKey f (L k x) t = case lookupM k t of Just y -> L k (f k x y) Nothing -> E intersectionWithKey _ E _ = E -- Datastructure definition is strict in all submaps, -- no forcing required strict :: t -> t strict n = n strictWith :: (t -> a) -> FM t -> FM t strictWith _ n@E = n strictWith f n@(L _ x) = f x `seq` n strictWith f n@(B _ _ m1 m2) = strictWith f m1 `seq` strictWith f m2 `seq` n ordListFM :: FM a -> [(Int,a)] ordListFM E = [] ordListFM (L k x) = [(k,x)] ordListFM (B _ _ t0 t1) = merge (ordListFM t0) (ordListFM t1) where merge [] ys = ys merge xs [] = xs merge (x@(k1,_):xs) (y@(k2,_):ys) = case compare k1 k2 of LT -> x : merge xs (y:ys) GT -> y : merge (x:xs) ys EQ -> error "PatriciaLoMap: bug in ordListFM" ordListFM_rev :: FM a -> [(Int,a)] ordListFM_rev E = [] ordListFM_rev (L k x) = [(k,x)] ordListFM_rev (B _ _ t0 t1) = merge (ordListFM_rev t0) (ordListFM_rev t1) where merge [] ys = ys merge xs [] = xs merge (x@(k1,_):xs) (y@(k2,_):ys) = case compare k1 k2 of LT -> y : merge (x:xs) ys GT -> x : merge xs (y:ys) EQ -> error "PatriciaLoMap: bug in ordListFM_rev" minView :: Monad m => FM a -> m (a, FM a) minView fm = case ordListFM fm of [] -> fail $ moduleName++".minView: empty map" ((k,x):_) -> return (x,delete k fm) minViewWithKey :: Monad m => FM a -> m ((Int, a), FM a) minViewWithKey fm = case ordListFM fm of [] -> fail $ moduleName++".minViewWithKey: empty map" ((k,x):_) -> return ((k,x),delete k fm) maxView :: Monad m => FM a -> m (a, FM a) maxView fm = case ordListFM_rev fm of [] -> fail $ moduleName++".maxView: empty map" ((k,x):_) -> return (x,delete k fm) maxViewWithKey :: Monad m => FM a -> m ((Int, a), FM a) maxViewWithKey fm = case ordListFM_rev fm of [] -> fail $ moduleName++".maxViewWithKey: empty map" ((k,x):_) -> return ((k,x),delete k fm) minElem :: FM a -> a minElem = minElemUsingMinView minElemWithKey :: FM a -> (Int,a) minElemWithKey = minElemWithKeyUsingMinViewWithKey deleteMin :: FM a -> FM a deleteMin = deleteMinUsingMinView unsafeInsertMin :: Int -> a -> FM a -> FM a unsafeInsertMin = insert maxElem :: FM a -> a maxElem = maxElemUsingMaxView deleteMax :: FM a -> FM a deleteMax = deleteMaxUsingMaxView maxElemWithKey :: FM a -> (Int,a) maxElemWithKey = maxElemWithKeyUsingMaxViewWithKey unsafeInsertMax :: Int -> a -> FM a -> FM a unsafeInsertMax = insert foldr :: (a -> b -> b) -> b -> FM a -> b foldr f z fm = L.foldr f z . L.map snd . ordListFM $ fm foldr' :: (a -> b -> b) -> b -> FM a -> b foldr' f z fm = L.foldl' (flip f) z . L.map snd . ordListFM_rev $ fm foldr1 :: (a -> a -> a) -> FM a -> a foldr1 f fm = L.foldr1 f . L.map snd . ordListFM $ fm foldr1' :: (a -> a -> a) -> FM a -> a foldr1' f fm = L.foldl1' (flip f) . L.map snd . ordListFM_rev $ fm foldl :: (b -> a -> b) -> b -> FM a -> b foldl f z fm = L.foldr (flip f) z . L.map snd . ordListFM_rev $ fm foldl' :: (b -> a -> b) -> b -> FM a -> b foldl' f z fm = L.foldl' f z . L.map snd . ordListFM $ fm foldl1 :: (a -> a -> a) -> FM a -> a foldl1 f fm = L.foldr1 (flip f) . L.map snd . ordListFM_rev $ fm foldl1' :: (a -> a -> a) -> FM a -> a foldl1' f fm = L.foldl1' f . L.map snd . ordListFM $ fm foldrWithKey :: (Int -> a -> b -> b) -> b -> FM a -> b foldrWithKey f z fm = L.foldr (uncurry f) z . ordListFM $ fm foldrWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b foldrWithKey' f z fm = L.foldl' (flip (uncurry f)) z . ordListFM_rev $ fm foldlWithKey :: (b -> Int -> a -> b) -> b -> FM a -> b foldlWithKey f z fm = L.foldr (\(k,x) a -> f a k x) z . ordListFM_rev $ fm foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b foldlWithKey' f z fm = L.foldl' (\a (k,x) -> f a k x) z . ordListFM $ fm unsafeFromOrdSeq :: S.Sequence seq => seq (Int,a) -> FM a unsafeFromOrdSeq = fromSeq unsafeAppend :: FM a -> FM a -> FM a unsafeAppend = union filterLT :: Int -> FM a -> FM a filterLT k = filterWithKey (\k' _ -> k' < k) filterLE :: Int -> FM a -> FM a filterLE k = filterWithKey (\k' _ -> k' <= k) filterGT :: Int -> FM a -> FM a filterGT k = filterWithKey (\k' _ -> k' > k) filterGE :: Int -> FM a -> FM a filterGE k = filterWithKey (\k' _ -> k' >= k) partitionLT_GE :: Int -> FM a -> (FM a, FM a) partitionLT_GE k fm = (filterLT k fm,filterGE k fm) partitionLE_GT :: Int -> FM a -> (FM a,FM a) partitionLE_GT k fm = (filterLE k fm,filterGT k fm) partitionLT_GT :: Int -> FM a -> (FM a,FM a) partitionLT_GT k fm = (filterLT k fm,filterGT k fm) toOrdSeq :: S.Sequence seq => FM a -> seq (Int,a) toOrdSeq = L.foldr S.lcons S.empty . ordListFM -- defaults insertSeq :: S.Sequence seq => seq (Int,a) -> FM a -> FM a insertSeq = insertSeqUsingFoldr unionSeq :: S.Sequence seq => seq (FM a) -> FM a unionSeq = unionSeqUsingReduce deleteAll :: Int -> FM a -> FM a deleteAll = delete deleteSeq :: S.Sequence seq => seq Int -> FM a -> FM a deleteSeq = deleteSeqUsingFoldr count :: Int -> FM a -> Int count = countUsingMember lookupAll :: S.Sequence seq => Int -> FM a -> seq a lookupAll = lookupAllUsingLookupM lookupWithDefault :: a -> Int -> FM a -> a lookupWithDefault = lookupWithDefaultUsingLookupM elements :: S.Sequence seq => FM a -> seq a elements = elementsUsingFold fromSeqWithKey :: S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a fromSeqWithKey = fromSeqWithKeyUsingInsertSeqWithKey insertWithKey :: (Int -> a -> a -> a) -> Int -> a -> FM a -> FM a insertWithKey = insertWithKeyUsingInsertWith insertSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (Int,a) -> FM a -> FM a insertSeqWith = insertSeqWithUsingInsertWith insertSeqWithKey :: S.Sequence seq => (Int -> a -> a -> a) -> seq (Int,a) -> FM a -> FM a insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey adjustAll :: (a -> a) -> Int -> FM a -> FM a adjustAll = adjust unionSeqWith :: S.Sequence seq => (a -> a -> a) -> seq (FM a) -> FM a unionSeqWith = unionSeqWithUsingReduce toSeq :: S.Sequence seq => FM a -> seq (Int,a) toSeq = toSeqUsingFoldWithKey keys :: S.Sequence seq => FM a -> seq Int keys = keysUsingFoldWithKey unionSeqWithKey :: S.Sequence seq => (Int -> a -> a -> a) -> seq (FM a) -> FM a unionSeqWithKey = unionSeqWithKeyUsingReduce -- instance declarations instance A.AssocX FM Int where {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; union = union; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; lookupAndDeleteAll = lookupAndDeleteAll; lookupWithDefault = lookupWithDefault; adjust = adjust; adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; adjustAllOrInsert = adjustAllOrInsert; adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; elements = elements; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance A.Assoc FM Int where {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; filterWithKey = filterWithKey; partitionWithKey = partitionWithKey} instance A.FiniteMapX FM Int where {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; insertWith = insertWith; insertWithKey = insertWithKey; insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; unionl = unionl; unionr = unionr; unionWith = unionWith; unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; difference = difference; properSubset = properSubset; subset = subset; properSubmapBy = properSubmapBy; submapBy = submapBy; sameMapBy = sameMapBy} instance A.FiniteMap FM Int where {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; intersectionWithKey = intersectionWithKey} instance A.OrdAssocX FM Int where {minView = minView; minElem = minElem; deleteMin = deleteMin; unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance A.OrdAssoc FM Int where {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; toOrdSeq = toOrdSeq} instance A.OrdFiniteMapX FM Int instance A.OrdFiniteMap FM Int instance Functor FM where fmap = map instance (Show a) => Show (FM a) where showsPrec = showsPrecUsingToList instance (Read a) => Read (FM a) where readsPrec = readsPrecUsingFromList instance (Eq a) => Eq (FM a) where (==) = sameMap instance (Ord a) => Ord (FM a) where compare = compareUsingToOrdList instance (Arbitrary a) => Arbitrary (FM a) where arbitrary = do (xs::[(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 EdisonCore-1.3.2.1/src/Data/Edison/Assoc/AssocList.hs0000644000000000000000000005557413223626550020311 0ustar0000000000000000-- | -- Module : Data.Edison.Assoc.AssocList -- Copyright : Copyright (c) 1998, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- This module implements finite maps as simple association lists. -- -- Duplicates are removed conceptually, but not physically. The first -- occurrence of a given key is the one that is considered to be in the map. -- -- The list type is mildly customized to prevent boxing the pairs. module Data.Edison.Assoc.AssocList ( -- * Type of simple association lists FM, -- instance of Assoc(X), FiniteMap(X) -- also instance of Functor -- * AssocX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, adjustOrDelete,adjustOrDeleteAll,strict,strictWith, map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, -- * OrdAssocX operations minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1', foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend, filterLT, filterLE, filterGT, filterGE, partitionLT_GE, partitionLE_GT, partitionLT_GT, -- * Assoc operations toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, -- * OrdAssoc operations minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, -- * FiniteMapX operations fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, properSubmap,submap,sameMap, -- * FiniteMap operations unionWithKey,unionSeqWithKey,intersectionWithKey, -- * Documentation moduleName ) where import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter) import qualified Prelude import Data.Monoid import Data.Semigroup as SG import Control.Monad.Identity import qualified Data.Edison.Assoc as A import qualified Data.Edison.Seq as S import qualified Data.Edison.Seq.BinaryRandList as RL import Data.Edison.Assoc.Defaults import Test.QuickCheck (Arbitrary(..), CoArbitrary(..), variant) -- signatures for exported functions moduleName :: String empty :: Eq k => FM k a singleton :: Eq k => k -> a -> FM k a fromSeq :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a insert :: Eq k => k -> a -> FM k a -> FM k a insertSeq :: (Eq k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a union :: Eq k => FM k a -> FM k a -> FM k a unionSeq :: (Eq k,S.Sequence seq) => seq (FM k a) -> FM k a delete :: Eq k => k -> FM k a -> FM k a deleteAll :: Eq k => k -> FM k a -> FM k a deleteSeq :: (Eq k,S.Sequence seq) => seq k -> FM k a -> FM k a null :: Eq k => FM k a -> Bool size :: Eq k => FM k a -> Int member :: Eq k => k -> FM k a -> Bool count :: Eq k => k -> FM k a -> Int lookup :: Eq k => k -> FM k a -> a lookupM :: (Eq k, Monad rm) => k -> FM k a -> rm a lookupAll :: (Eq k,S.Sequence seq) => k -> FM k a -> seq a lookupAndDelete :: Eq k => k -> FM k a -> (a,FM k a) lookupAndDeleteM :: (Eq k,Monad rm) => k -> FM k a -> rm (a,FM k a) lookupAndDeleteAll :: (Eq k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a) lookupWithDefault :: Eq k => a -> k -> FM k a -> a adjust :: Eq k => (a -> a) -> k -> FM k a -> FM k a adjustAll :: Eq k => (a -> a) -> k -> FM k a -> FM k a adjustOrInsert :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a adjustAllOrInsert :: Eq k => (a -> a) -> a -> k -> FM k a -> FM k a adjustOrDelete :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a adjustOrDeleteAll :: Eq k => (a -> Maybe a) -> k -> FM k a -> FM k a strict :: FM k a -> FM k a strictWith :: (a -> b) -> FM k a -> FM k a map :: Eq k => (a -> b) -> FM k a -> FM k b fold :: Eq k => (a -> b -> b) -> b -> FM k a -> b fold1 :: Eq k => (a -> a -> a) -> FM k a -> a fold' :: Eq k => (a -> b -> b) -> b -> FM k a -> b fold1' :: Eq k => (a -> a -> a) -> FM k a -> a filter :: Eq k => (a -> Bool) -> FM k a -> FM k a partition :: Eq k => (a -> Bool) -> FM k a -> (FM k a, FM k a) elements :: (Eq k,S.Sequence seq) => FM k a -> seq a fromSeqWith :: (Eq k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> FM k a fromSeqWithKey :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a insertWith :: Eq k => (a -> a -> a) -> k -> a -> FM k a -> FM k a insertWithKey :: Eq k => (k -> a -> a -> a) -> k -> a -> FM k a -> FM k a insertSeqWith :: (Eq k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> FM k a -> FM k a insertSeqWithKey :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> FM k a -> FM k a unionl :: Eq k => FM k a -> FM k a -> FM k a unionr :: Eq k => FM k a -> FM k a -> FM k a unionWith :: Eq k => (a -> a -> a) -> FM k a -> FM k a -> FM k a unionSeqWith :: (Eq k,S.Sequence seq) => (a -> a -> a) -> seq (FM k a) -> FM k a intersectionWith :: Eq k => (a -> b -> c) -> FM k a -> FM k b -> FM k c difference :: Eq k => FM k a -> FM k b -> FM k a properSubset :: Eq k => FM k a -> FM k b -> Bool subset :: Eq k => FM k a -> FM k b -> Bool properSubmapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool submapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool sameMapBy :: Eq k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool properSubmap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool submap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool sameMap :: (Eq k, Eq a) => FM k a -> FM k a -> Bool toSeq :: (Eq k,S.Sequence seq) => FM k a -> seq (k,a) keys :: (Eq k,S.Sequence seq) => FM k a -> seq k mapWithKey :: Eq k => (k -> a -> b) -> FM k a -> FM k b foldWithKey :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b foldWithKey' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b filterWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> FM k a partitionWithKey :: Eq k => (k -> a -> Bool) -> FM k a -> (FM k a, FM k a) unionWithKey :: Eq k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a unionSeqWithKey :: (Eq k,S.Sequence seq) => (k -> a -> a -> a) -> seq (FM k a) -> FM k a intersectionWithKey :: Eq k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c minView :: (Ord k,Monad m) => FM k a -> m (a,FM k a) minElem :: Ord k => FM k a -> a deleteMin :: Ord k => FM k a -> FM k a unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a maxView :: (Ord k,Monad m) => FM k a -> m (a,FM k a) maxElem :: Ord k => FM k a -> a deleteMax :: Ord k => FM k a -> FM k a unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a filterLT :: Ord k => k -> FM k a -> FM k a filterLE :: Ord k => k -> FM k a -> FM k a filterGT :: Ord k => k -> FM k a -> FM k a filterGE :: Ord k => k -> FM k a -> FM k a partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a) partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) minViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a) minElemWithKey :: Ord k => FM k a -> (k,a) maxViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a) maxElemWithKey :: Ord k => FM k a -> (k,a) foldrWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b foldlWithKey :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b foldrWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b foldlWithKey' :: Ord k => (b -> k -> a -> b) -> b -> FM k a -> b toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) moduleName = "Data.Edison.Assoc.AssocList" data FM k a = E | I k a (FM k a) -- no invariants structuralInvariant :: Eq k => FM k a -> Bool structuralInvariant = const True --------------------------------------- -- some unexported utility functions -- uncurried insert. uinsert :: (t, t1) -> FM t t1 -> FM t t1 uinsert (k,x) = I k x -- left biased merge. mergeFM :: (Ord t) => FM t t1 -> FM t t1 -> FM t t1 mergeFM E m = m mergeFM m E = m mergeFM o1@(I k1 a1 m1) o2@(I k2 a2 m2) = case compare k1 k2 of LT -> I k1 a1 (mergeFM m1 o2) GT -> I k2 a2 (mergeFM o1 m2) EQ -> I k1 a1 (mergeFM m1 m2) toRandList :: FM t t1 -> RL.Seq (FM t t1) toRandList E = RL.empty toRandList (I k a m) = RL.lcons (I k a E) (toRandList m) mergeSortFM :: (Ord t) => FM t t1 -> FM t t1 mergeSortFM m = RL.reducer mergeFM E (toRandList m) foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b foldrFM _ z E = z foldrFM f z (I k a m) = f a (foldrFM f z (delete k m)) foldr1FM :: Eq k => (a -> a -> a) -> FM k a -> a foldr1FM _ (I _ a E) = a foldr1FM f (I k a m) = f a (foldr1FM f (delete k m)) foldr1FM _ _ = error "invalid call to foldr1FM on empty map" foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b foldrFM' _ z E = z foldrFM' f z (I k a m) = f a $! (foldrFM' f z (delete k m)) foldr1FM' :: Eq k => (a -> a -> a) -> FM k a -> a foldr1FM' _ (I _ a E) = a foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m)) foldr1FM' _ _ = error "invalid call to foldr1FM' on empty map" foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b foldlFM _ x E = x foldlFM f x (I k a m) = foldlFM f (f x a) (delete k m) foldlFM' :: Eq k => (b -> a -> b) -> b -> FM k a -> b foldlFM' _ x E = x foldlFM' f x (I k a m) = x `seq` foldlFM' f (f x a) (delete k m) foldrWithKeyFM :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b foldrWithKeyFM _ z E = z foldrWithKeyFM f z (I k a m) = f k a (foldrWithKeyFM f z (delete k m)) foldrWithKeyFM' :: Eq k => (k -> a -> b -> b) -> b -> FM k a -> b foldrWithKeyFM' _ z E = z foldrWithKeyFM' f z (I k a m) = f k a $! (foldrWithKeyFM' f z (delete k m)) foldlWithKeyFM :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b foldlWithKeyFM _ x E = x foldlWithKeyFM f x (I k a m) = foldlWithKeyFM f (f x k a) (delete k m) foldlWithKeyFM' :: Eq k => (b -> k -> a -> b) -> b -> FM k a -> b foldlWithKeyFM' _ x E = x foldlWithKeyFM' f x (I k a m) = x `seq` foldlWithKeyFM' f (f x k a) (delete k m) takeWhileFM :: (k -> Bool) -> FM k a -> FM k a takeWhileFM _ E = E takeWhileFM p (I k a m) | p k = I k a (takeWhileFM p m) | otherwise = E dropWhileFM :: (k -> Bool) -> FM k a -> FM k a dropWhileFM _ E = E dropWhileFM p o@(I k _ m) | p k = dropWhileFM p m | otherwise = o spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a) spanFM _ E = (E,E) spanFM p o@(I k a m) | p k = let (x,y) = spanFM p m in (I k a x,y) | otherwise = (E,o) --------------------------------------------------- -- interface functions empty = E singleton k x = I k x E insert = I insertSeq kxs m = S.foldr uinsert m kxs fromSeq = S.foldr uinsert E union m E = m union E m = m union (I k x m1) m2 = I k x (union m1 m2) unionSeq = S.foldr union E deleteAll _ E = E deleteAll key (I k x m) | key == k = deleteAll key m | otherwise = I k x (deleteAll key m) delete = deleteAll null E = True null (I _ _ _) = False size E = 0 size (I k _ m) = 1 + size (delete k m) member _ E = False member key (I k _ m) = key == k || member key m count _ E = 0 count key (I k _ m) | key == k = 1 | otherwise = count key m lookup key m = runIdentity (lookupM key m) lookupM _ E = fail "AssocList.lookup: lookup failed" lookupM key (I k x m) | key == k = return x | otherwise = lookupM key m lookupAll _ E = S.empty lookupAll key (I k x m) | key == k = S.singleton x | otherwise = lookupAll key m lookupAndDelete key m = runIdentity (lookupAndDeleteM key m) lookupAndDeleteM _ E = fail "AssocList.lookupAndDeleteM: lookup failed" lookupAndDeleteM key (I k x m) | key == k = return (x,delete k m) | otherwise = lookupAndDeleteM key m >>= \ (z, m') -> return (z, I k x m') lookupAndDeleteAll key m = case lookupAndDeleteM key m of Nothing -> (S.empty,m) Just (z,m') -> (S.singleton z,m') lookupWithDefault d _ E = d lookupWithDefault d key (I k x m) | key == k = x | otherwise = lookupWithDefault d key m elements E = S.empty elements (I k x m) = S.lcons x (elements (delete k m)) adjust _ _ E = E adjust f key (I k x m) | key == k = I key (f x) m | otherwise = I k x (adjust f key m) adjustAll = adjust adjustOrInsert _ z key E = singleton key z adjustOrInsert f z key (I k x m) | key == k = I key (f x) m | otherwise = I k x (adjustOrInsert f z key m) adjustAllOrInsert = adjustOrInsert adjustOrDelete = adjustOrDeleteDefault adjustOrDeleteAll = adjustOrDeleteAllDefault map _ E = E map f (I k x m) = I k (f x) (map f m) fold _ c E = c fold f c (I k x m) = fold f (f x c) (delete k m) fold' _ c E = c fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m) fold1 _ E = error "AssocList.fold1: empty map" fold1 f (I k x m) = fold f x (delete k m) fold1' _ E = error "AssocList.fold1': empty map" fold1' f (I k x m) = fold' f x (delete k m) filter _ E = E filter p (I k x m) | p x = I k x (filter p (delete k m)) | otherwise = filter p (delete k m) partition _ E = (E, E) partition p (I k x m) | p x = (I k x m1,m2) | otherwise = (m1,I k x m2) where (m1,m2) = partition p (delete k m) toSeq E = S.empty toSeq (I k x m) = S.lcons (k,x) (toSeq (delete k m)) keys E = S.empty keys (I k _ m) = S.lcons k (keys (delete k m)) mapWithKey _ E = E mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m) foldWithKey _ c E = c foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m) foldWithKey' _ c E = c foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m) filterWithKey _ E = E filterWithKey p (I k x m) | p k x = I k x (filterWithKey p (delete k m)) | otherwise = filterWithKey p (delete k m) partitionWithKey _ E = (E, E) partitionWithKey p (I k x m) | p k x = (I k x m1,m2) | otherwise = (m1,I k x m2) where (m1,m2) = partitionWithKey p (delete k m) unionl = union unionr = flip union findMin :: (Ord t) => t -> t1 -> FM t t1 -> (t, t1) findMin k0 x E = (k0,x) findMin k0 a0 (I k a m) | k < k0 = findMin k a (delete k m) | otherwise = findMin k0 a0 (delete k m) findMax ::( Ord t) => t -> t1 -> FM t t1 -> (t, t1) findMax k0 x E = (k0,x) findMax k0 a0 (I k a m) | k > k0 = findMax k a (delete k m) | otherwise = findMax k0 a0 (delete k m) minView E = fail (moduleName++".minView: empty map") minView n@(I k a m) = let (k',x) = findMin k a m in return (x,delete k' n) minElem E = error (moduleName++".minElem: empty map") minElem (I k a m) = let (_,x) = findMin k a m in x deleteMin E = error (moduleName++".deleteMin: empty map") deleteMin n@(I k a m) = let (k',_) = findMin k a m in delete k' n unsafeInsertMin = insert maxView E = fail (moduleName++".maxView: empty map") maxView n@(I k a m) = let (k',x) = findMax k a m in return (x,delete k' n) maxElem E = error (moduleName++".maxElem: empty map") maxElem (I k a m) = let (_,x) = findMax k a m in x deleteMax E = error (moduleName++".deleteMax: empty map") deleteMax n@(I k a m) = let (k',_) = findMax k a m in delete k' n unsafeInsertMax = insert foldr f z m = foldrFM f z (mergeSortFM m) foldr' f z m = foldrFM' f z (mergeSortFM m) foldr1 f m = case mergeSortFM m of E -> error $ moduleName++".foldlr1: empty map" n -> foldr1FM f n foldr1' f m = case mergeSortFM m of E -> error $ moduleName++".foldlr1': empty map" n -> foldr1FM' f n foldl f x m = foldlFM f x (mergeSortFM m) foldl' f x m = foldlFM' f x (mergeSortFM m) foldl1 f m = case mergeSortFM m of E -> error $ moduleName++".foldl1: empty map" I k a n -> foldlFM f a (delete k n) foldl1' f m = case mergeSortFM m of E -> error $ moduleName++".foldl1': empty map" I k a n -> foldlFM' f a (delete k n) unsafeFromOrdSeq = fromSeq unsafeAppend = union filterLT k = takeWhileFM ( (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 EdisonCore-1.3.2.1/src/Data/Edison/Seq/0000755000000000000000000000000013223626550015511 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/Edison/Seq/FingerSeq.hs0000644000000000000000000003137213223626550017736 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.FingerSeq -- Copyright : Copyright (c) 2006, 2008 Robert Dockins -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) module Data.Edison.Seq.FingerSeq ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldlWithIndex, take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import qualified Prelude import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Control.Applicative as App import Data.Edison.Prelude (measure, Measured()) import qualified Data.Edison.Seq as S import Data.Edison.Seq.Defaults import Control.Monad.Identity import Data.Monoid import Data.Semigroup as SG import Test.QuickCheck #ifdef __GLASGOW_HASKELL__ import GHC.Base (unsafeCoerce#) #endif import qualified Data.Edison.Concrete.FingerTree as FT moduleName :: String moduleName = "Data.Edison.Seq.FingerSeq" newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show) unSizeM :: SizeM -> Int unSizeM (SizeM x) = x instance 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 :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool #ifdef __GLASGOW_HASKELL__ mapElem, mapUnElem :: t -> b mapElem = unsafeCoerce# mapUnElem = unsafeCoerce# #else mapElem = Prelude.map Elem mapUnElem = Prelude.map unElem #endif null = FT.null . unSeq empty = Seq FT.empty singleton = Seq . FT.singleton . Elem lcons x = Seq . FT.lcons (Elem x) . unSeq rcons x = Seq . FT.rcons (Elem x) . unSeq append p q = Seq $ FT.append (unSeq p) (unSeq q) fromList = Seq . FT.fromList . mapElem toList = mapUnElem . FT.toList . unSeq reverse = Seq . FT.reverse . unSeq size = unSizeM . measure . unSeq strict = Seq . FT.strict . unSeq strictWith f = Seq . FT.strictWith (f . unElem) . unSeq structuralInvariant = FT.structuralInvariant . unSeq #ifdef __GLASGOW_HASKELL__ lview (Seq xs) = let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a) in f (FT.lview xs) rview (Seq xs) = let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a) in f (FT.rview xs) #else lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs) rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs) #endif lheadM xs = lview xs >>= return . fst ltailM xs = lview xs >>= return . snd rheadM xs = rview xs >>= return . fst rtailM xs = rview xs >>= return . snd lhead = runIdentity . lheadM ltail = runIdentity . ltailM rhead = runIdentity . rheadM rtail = runIdentity . rtailM fold = foldr fold' = foldr' fold1 = foldr1 fold1' = foldr1' #ifdef __GLASGOW_HASKELL__ foldr f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z) foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z) reduce1 f (Seq xs) = unElem $ FT.reduce1 (unsafeCoerce# f) xs reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs #else foldr f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z) foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z) reduce1 f (Seq xs) = unElem $ FT.reduce1 ( \(Elem x) (Elem y) -> Elem $ f x y) xs reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs #endif lookupM i (Seq xs) | inBounds i (Seq xs) = case FT.splitTree (> (SizeM i)) (SizeM 0) xs of FT.Split _ (Elem x) _ -> return x | otherwise = fail "FingerSeq.lookupM: index out of bounds" lookupWithDefault d i (Seq xs) | inBounds i (Seq xs) = case FT.splitTree (> (SizeM i)) (SizeM 0) xs of FT.Split _ (Elem x) _ -> x | otherwise = d update i x (Seq xs) | inBounds i (Seq xs) = case FT.splitTree (> (SizeM i)) (SizeM 0) xs of FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r | otherwise = Seq xs adjust f i (Seq xs) | inBounds i (Seq xs) = case FT.splitTree (> (SizeM i)) (SizeM 0) xs of FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r | otherwise = Seq xs take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b) inBounds = inBoundsUsingSize lookup = lookupUsingLookupM foldr1 f xs = case rview xs of Nothing -> error "FingerSeq.foldr1: empty sequence" Just (x,xs') -> foldr f x xs' foldr1' f xs = case rview xs of Nothing -> error "FingerSeq.foldr1': empty sequence" Just (x,xs') -> foldr' f x xs' foldl = foldlUsingLists foldl' = foldl'UsingLists foldl1 = foldl1UsingLists foldl1' = foldl1'UsingLists reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' copy = copyUsingLists concat = concatUsingFoldr reverseOnto = reverseOntoUsingReverse concatMap = concatMapUsingFoldr subseq = subseqDefault filter = filterUsingLview partition = partitionUsingFoldr takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists zip = zipUsingLview zip3 = zip3UsingLview zipWith = zipWithUsingLview zipWith3 = zipWith3UsingLview unzip = unzipUsingFoldr unzip3 = unzip3UsingFoldr unzipWith = unzipWithUsingFoldr unzipWith3 = unzipWith3UsingFoldr -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/RandList.hs0000644000000000000000000004037013223626550017571 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.RandList -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Random-Access Lists. All operations are as listed in "Data.Edison.Seq" -- except the following: -- -- * rhead*, size @O( log n )@ -- -- * copy, inBounds @O( log i )@ -- -- * lookup*, update, adjust, drop @O( min( i, log n ) )@ -- -- * subseq @O( min( i, log n ) + len )@ -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. -- Section 9.3.1. -- -- * Chris Okasaki. \"Purely Functional Random Access Lists\". FPCA'95, -- pages 86-95. module Data.Edison.Seq.RandList ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Control.Applicative as App import qualified Data.Edison.Seq as S( Sequence(..) ) import Data.Edison.Seq.Defaults import Control.Monad.Identity 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 :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a moduleName = "Data.Edison.Seq.RandList" data Tree a = L a | T a (Tree a) (Tree a) deriving (Eq) data Seq a = E | C !Int (Tree a) (Seq a) deriving (Eq) half :: Int -> Int half n = n `quot` 2 -- use a shift? empty = E singleton x = C 1 (L x) E lcons x (C i s (C j t xs')) | i == j = C (1 + i + j) (T x s t) xs' lcons x xs = C 1 (L x) xs copy n x = if n <= 0 then E else buildTrees (1::Int) (L x) where buildTrees j t | j > n = takeTrees n (half j) (child t) E | otherwise = buildTrees (1 + j + j) (T x t t) takeTrees i j t xs | i >= j = takeTrees (i - j) j t (C j t xs) | i > 0 = takeTrees i (half j) (child t) xs | otherwise = xs child (T _ _ t) = t child _ = error "RandList.copy: bug!" lview E = fail "RandList.lview: empty sequence" lview (C _ (L x) xs) = return (x, xs) lview (C i (T x s t) xs) = return (x, C j s (C j t xs)) where j = half i lhead E = error "RandList.lhead: empty sequence" lhead (C _ (L x) _) = x lhead (C _ (T x _ _) _) = x lheadM E = fail "RandList.lheadM: empty sequence" lheadM (C _ (L x) _) = return x lheadM (C _ (T x _ _) _) = return x ltail E = error "RandList.ltail: empty sequence" ltail (C _ (L _) xs) = xs ltail (C i (T _ s t) xs) = C j s (C j t xs) where j = half i ltailM E = fail "RandList.ltailM: empty sequence" ltailM (C _ (L _) xs) = return xs ltailM (C i (T _ s t) xs) = return (C j s (C j t xs)) where j = half i rhead E = error "RandList.rhead: empty sequence" rhead (C _ t E) = treeLast t where treeLast (L x) = x treeLast (T _ _ t) = treeLast t rhead (C _ _ xs) = rhead xs rheadM E = fail "RandList.rhead: empty sequence" rheadM (C _ t E) = return(treeLast t) where treeLast (L x) = x treeLast (T _ _ t) = treeLast t rheadM (C _ _ xs) = rheadM xs null E = True null _ = False size xs = sz xs where sz E = (0::Int) sz (C j _ xs) = j + sz xs reverseOnto E ys = ys reverseOnto (C _ t xs) ys = reverseOnto xs (revTree t ys) where revTree (L x) ys = lcons x ys revTree (T x s t) ys = revTree t (revTree s (lcons x ys)) map _ E = E map f (C j t xs) = C j (mapTree f t) (map f xs) where mapTree f (L x) = L (f x) mapTree f (T x s t) = T (f x) (mapTree f s) (mapTree f t) fold = foldr fold' f = foldl' (flip f) fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr _ e E = e foldr f e (C _ t xs) = foldTree t (foldr f e xs) where foldTree (L x) e = f x e foldTree (T x s t) e = f x (foldTree s (foldTree t e)) foldr' _ e E = e foldr' f e (C _ t xs) = foldTree t $! (foldr' f e xs) where foldTree (L x) e = f x $! e foldTree (T x s t) e = f x $! (foldTree s $! (foldTree t $! e)) foldl _ e E = e foldl f e (C _ t xs) = foldl f (foldTree e t) xs where foldTree e (L x) = f e x foldTree e (T x s t) = foldTree (foldTree (f e x) s) t foldl' _ e E = e foldl' f e (C _ t xs) = (foldl f $! (foldTree e t)) xs where foldTree e (L x) = e `seq` f e x foldTree e (T x s t) = e `seq` (foldTree $! (foldTree (f e x) s)) t reduce1 f xs = case lview xs of Nothing -> error "RandList.reduce1: empty seq" Just (x, xs) -> red1 x xs where red1 x E = x red1 x (C _ t xs) = red1 (redTree x t) xs redTree x (L y) = f x y redTree x (T y s t) = redTree (redTree (f x y) s) t reduce1' f xs = case lview xs of Nothing -> error "RandList.reduce1': empty seq" Just (x, xs) -> red1 x xs where red1 x E = x red1 x (C _ t xs) = (red1 $! (redTree x t)) xs redTree x (L y) = x `seq` y `seq` f x y redTree x (T y s t) = x `seq` y `seq` (redTree $! (redTree (f x y) s)) t inBounds i xs = inb xs i where inb E _ = False inb (C j _ xs) i | i < j = (i >= 0) | otherwise = inb xs (i - j) lookup i xs = runIdentity (lookupM i xs) lookupM i xs = look xs i where look E _ = fail "RandList.lookup bad subscript" look (C j t xs) i | i < j = lookTree j t i | otherwise = look xs (i - j) lookTree _ (L x) i | i == 0 = return x | otherwise = nothing lookTree j (T x s t) i | i > k = lookTree k t (i - 1 - k) | i /= 0 = lookTree k s (i - 1) | otherwise = return x where k = half j nothing = fail "RandList.lookup: not found" lookupWithDefault d i xs = look xs i where look E _ = d look (C j t xs) i | i < j = lookTree j t i | otherwise = look xs (i - j) lookTree _ (L x) i | i == 0 = x | otherwise = d lookTree j (T x s t) i | i > k = lookTree k t (i - 1 - k) | i /= 0 = lookTree k s (i - 1) | otherwise = x where k = half j update i y xs = upd i xs where upd _ E = E upd i (C j t xs) | i < j = C j (updTree i j t) xs | otherwise = C j t (upd (i - j) xs) updTree i _ t@(L _) | i == 0 = L y | otherwise = t updTree i j (T x s t) | i > k = T x s (updTree (i - 1 - k) k t) | i /= 0 = T x (updTree (i - 1) k s) t | otherwise = T y s t where k = half j adjust f i xs = adj i xs where adj _ E = E adj i (C j t xs) | i < j = C j (adjTree i j t) xs | otherwise = C j t (adj (i - j) xs) adjTree i _ t@(L x) | i == 0 = L (f x) | otherwise = t adjTree i j (T x s t) | i > k = T x s (adjTree (i - 1 - k) k t) | i /= 0 = T x (adjTree (i - 1) k s) t | otherwise = T (f x) s t where k = half j drop n xs = if n < 0 then xs else drp n xs where drp _ E = E drp i (C j t xs) | i < j = drpTree i j t xs | otherwise = drp (i - j) xs drpTree 0 j t xs = C j t xs drpTree _ _ (L _) _ = error "RandList.drop: bug. Impossible case!" drpTree i j (T _ s t) xs | i > k = drpTree (i - 1 - k) k t xs | otherwise = drpTree (i - 1) k s (C k t xs) where k = half j strict s@E = s strict s@(C _ t xs) = strictTree t `seq` strict xs `seq` s strictTree :: Tree t -> Tree t strictTree t@(L _) = t strictTree t@(T _ l r) = strictTree l `seq` strictTree r `seq` t strictWith _ s@E = s strictWith f s@(C _ t xs) = strictWithTree f t `seq` strictWith f xs `seq` s strictWithTree :: (t -> a) -> Tree t -> Tree t strictWithTree f t@(L x) = f x `seq` t strictWithTree f t@(T x l r) = f x `seq` strictWithTree f l `seq` strictWithTree f r `seq` t -- the remaining functions all use defaults rcons = rconsUsingFoldr append = appendUsingFoldr rview = rviewDefault rtail = rtailUsingLview rtailM = rtailMUsingLview concat = concatUsingFoldr reverse = reverseUsingReverseOnto fromList = fromListUsingCons toList = toListUsingFoldr concatMap = concatMapUsingFoldr foldr1 = foldr1UsingLview foldr1' = foldr1'UsingLview foldl1 = foldl1UsingFoldl foldl1' = foldl1'UsingFoldl' reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists take = takeUsingLists splitAt = splitAtDefault filter = filterUsingFoldr partition = partitionUsingFoldr subseq = subseqDefault takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview -- for zips, could optimize by calculating which one is shorter and -- retaining its shape zip = zipUsingLists zip3 = zip3UsingLists zipWith = zipWithUsingLists zipWith3 = zipWith3UsingLists unzip = unzipUsingLists unzip3 = unzip3UsingLists unzipWith = unzipWithUsingLists unzipWith3 = unzipWith3UsingLists -- invariants: -- * list of complete binary trees in non-decreasing -- order by size -- * first argument to 'C' is the number -- of nodes in the tree structuralInvariant :: Seq t -> Bool structuralInvariant E = True structuralInvariant (C x t s) = x > 0 && checkTree x t && checkSeq x s where checkTree 1 (L _) = True checkTree w (T _ l r) = let w' = (w - 1) `div` 2 in w' > 0 && checkTree w' l && checkTree w' r checkTree _ _ = False checkSeq _ E = True checkSeq x (C y t s) = x <= y && checkTree y t && checkSeq y s -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/SizedSeq.hs0000644000000000000000000003570713223626550017610 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.SizedSeq -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- This module defines a sequence adaptor @Sized s@. -- If @s@ is a sequence type constructor, then @Sized s@ -- is a sequence type constructor that is identical to @s@, -- except that it also keeps track of the current size of -- each sequence. -- -- All time complexities are determined by the underlying -- sequence, except that size becomes @O( 1 )@. module Data.Edison.Seq.SizedSeq ( -- * Sized Sequence Type Sized, -- Sized s instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName,instanceName, -- * Other supported operations fromSeq,toSeq ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified 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 Test.QuickCheck -- signatures for exported functions moduleName :: String instanceName :: S.Sequence s => Sized s a -> String empty :: S.Sequence s => Sized s a singleton :: S.Sequence s => a -> Sized s a lcons :: S.Sequence s => a -> Sized s a -> Sized s a rcons :: S.Sequence s => a -> Sized s a -> Sized s a append :: S.Sequence s => Sized s a -> Sized s a -> Sized s a lview :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a) lhead :: S.Sequence s => Sized s a -> a lheadM :: (S.Sequence s, Monad m) => Sized s a -> m a ltail :: S.Sequence s => Sized s a -> Sized s a ltailM :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a) rview :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a) rhead :: S.Sequence s => Sized s a -> a rheadM :: (S.Sequence s, Monad m) => Sized s a -> m a rtail :: S.Sequence s => Sized s a -> Sized s a rtailM :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a) null :: S.Sequence s => Sized s a -> Bool size :: S.Sequence s => Sized s a -> Int concat :: S.Sequence s => Sized s (Sized s a) -> Sized s a reverse :: S.Sequence s => Sized s a -> Sized s a reverseOnto :: S.Sequence s => Sized s a -> Sized s a -> Sized s a fromList :: S.Sequence s => [a] -> Sized s a toList :: S.Sequence s => Sized s a -> [a] map :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b concatMap :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b fold :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b fold' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b fold1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a fold1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a foldr :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b foldl :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b foldr1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a foldl1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a reducer :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a reducel :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a reduce1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a foldr' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b foldl' :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b foldr1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a foldl1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a reducer' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a reducel' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a reduce1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a copy :: S.Sequence s => Int -> a -> Sized s a inBounds :: S.Sequence s => Int -> Sized s a -> Bool lookup :: S.Sequence s => Int -> Sized s a -> a lookupM :: (S.Sequence s, Monad m) => Int -> Sized s a -> m a lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a update :: S.Sequence s => Int -> a -> Sized s a -> Sized s a adjust :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b take :: S.Sequence s => Int -> Sized s a -> Sized s a drop :: S.Sequence s => Int -> Sized s a -> Sized s a splitAt :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a) subseq :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a filter :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a partition :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a) takeWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a dropWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a splitWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a) zip :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b) zip3 :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c) zipWith :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d unzip :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b) unzip3 :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c) unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c) unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d) strict :: S.Sequence s => Sized s a -> Sized s a strictWith :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a structuralInvariant :: S.Sequence s => Sized s a -> Bool -- bonus functions, not in Sequence signature fromSeq :: S.Sequence s => s a -> Sized s a toSeq :: S.Sequence s => Sized s a -> s a moduleName = "Data.Edison.Seq.SizedSeq" instanceName (N _ s) = "SizedSeq(" ++ S.instanceName s ++ ")" data Sized s a = N !Int (s a) fromSeq xs = N (S.size xs) xs toSeq (N _ xs) = xs empty = N 0 S.empty singleton x = N 1 (S.singleton x) lcons x (N n xs) = N (n+1) (S.lcons x xs) rcons x (N n xs) = N (n+1) (S.rcons x xs) append (N m xs) (N n ys) = N (m+n) (S.append xs ys) lview (N n xs) = case S.lview xs of Nothing -> fail "SizedSeq.lview: empty sequence" Just (x,xs) -> return (x, N (n-1) xs) lhead (N _ xs) = S.lhead xs lheadM (N _ xs) = S.lheadM xs ltail (N 0 _) = error "SizedSeq.ltail: empty sequence" ltail (N n xs) = N (n-1) (S.ltail xs) ltailM (N 0 _) = fail "SizedSeq.ltailM: empty sequence" ltailM (N n xs) = return (N (n-1) (S.ltail xs)) rview (N n xs) = case S.rview xs of Nothing -> fail "SizedSeq.rview: empty sequence" Just (x,xs) -> return (x, N (n-1) xs) rhead (N _ xs) = S.rhead xs rheadM (N _ xs) = S.rheadM xs rtail (N 0 _) = error "SizedSeq.rtail: empty sequence" rtail (N n xs) = N (n-1) (S.rtail xs) rtailM (N 0 _) = fail "SizedSeq.rtailM: empty sequence" rtailM (N n xs) = return (N (n-1) (S.rtail xs)) null (N n _) = n == 0 size (N n _) = n concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss)) reverse (N n xs) = N n (S.reverse xs) reverseOnto (N m xs) (N n ys) = N (m+n) (S.reverseOnto xs ys) fromList = fromSeq . S.fromList toList (N _ xs) = S.toList xs map f (N n xs) = N n (S.map f xs) concatMap = concatMapUsingFoldr -- only function that uses a default fold f e (N _ xs) = S.fold f e xs fold' f e (N _ xs) = S.fold' f e xs fold1 f (N _ xs) = S.fold1 f xs fold1' f (N _ xs) = S.fold1' f xs foldr f e (N _ xs) = S.foldr f e xs foldr' f e (N _ xs) = S.foldr' f e xs foldl f e (N _ xs) = S.foldl f e xs foldl' f e (N _ xs) = S.foldl' f e xs foldr1 f (N _ xs) = S.foldr1 f xs foldr1' f (N _ xs) = S.foldr1' f xs foldl1 f (N _ xs) = S.foldl1 f xs foldl1' f (N _ xs) = S.foldl1' f xs reducer f e (N _ xs) = S.reducer f e xs reducer' f e (N _ xs) = S.reducer' f e xs reducel f e (N _ xs) = S.reducel f e xs reducel' f e (N _ xs) = S.reducel' f e xs reduce1 f (N _ xs) = S.reduce1 f xs reduce1' f (N _ xs) = S.reduce1' f xs copy n x | n <= 0 = empty | otherwise = N n (S.copy n x) inBounds i (N n _) = (i >= 0) && (i < n) lookup i (N _ xs) = S.lookup i xs lookupM i (N _ xs) = S.lookupM i xs lookupWithDefault d i (N _ xs) = S.lookupWithDefault d i xs update i x (N n xs) = N n (S.update i x xs) adjust f i (N n xs) = N n (S.adjust f i xs) mapWithIndex f (N n xs) = N n (S.mapWithIndex f xs) foldrWithIndex f e (N _ xs) = S.foldrWithIndex f e xs foldrWithIndex' f e (N _ xs) = S.foldrWithIndex' f e xs foldlWithIndex f e (N _ xs) = S.foldlWithIndex f e xs foldlWithIndex' f e (N _ xs) = S.foldlWithIndex' f e xs take i original@(N n xs) | i <= 0 = empty | i >= n = original | otherwise = N i (S.take i xs) drop i original@(N n xs) | i <= 0 = original | i >= n = empty | otherwise = N (n-i) (S.drop i xs) splitAt i original@(N n xs) | i <= 0 = (empty, original) | i >= n = (original, empty) | otherwise = let (ys,zs) = S.splitAt i xs in (N i ys, N (n-i) zs) subseq i len original@(N n xs) | i <= 0 = take len original | i >= n || len <= 0 = empty | i+len >= n = N (n-i) (S.drop i xs) | otherwise = N len (S.subseq i len xs) filter p = fromSeq . S.filter p . toSeq partition p (N n xs) = (N m ys, N (n-m) zs) where (ys,zs) = S.partition p xs m = S.size ys takeWhile p = fromSeq . S.takeWhile p . toSeq dropWhile p = fromSeq . S.dropWhile p . toSeq splitWhile p (N n xs) = (N m ys, N (n-m) zs) where (ys,zs) = S.splitWhile p xs m = S.size ys zip (N m xs) (N n ys) = N (min m n) (S.zip xs ys) zip3 (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zip3 xs ys zs) zipWith f (N m xs) (N n ys) = N (min m n) (S.zipWith f xs ys) zipWith3 f (N l xs) (N m ys) (N n zs) = N (min l (min m n)) (S.zipWith3 f xs ys zs) unzip (N n xys) = (N n xs, N n ys) where (xs,ys) = S.unzip xys unzip3 (N n xyzs) = (N n xs, N n ys, N n zs) where (xs,ys,zs) = S.unzip3 xyzs unzipWith f g (N n xys) = (N n xs, N n ys) where (xs,ys) = S.unzipWith f g xys unzipWith3 f g h (N n xyzs) = (N n xs, N n ys, N n zs) where (xs,ys,zs) = S.unzipWith3 f g h xyzs strict s@(N _ s') = S.strict s' `seq` s strictWith f s@(N _ s') = S.strictWith f s' `seq` s structuralInvariant (N i s) = i == S.size s -- instances instance S.Sequence s => S.Sequence (Sized s) where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName = instanceName} instance S.Sequence s => Functor (Sized s) where fmap = map instance S.Sequence s => 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/BinaryRandList.hs0000644000000000000000000003655213223626550020745 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.BinaryRandList -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Binary Random-Access lists. All functions have the standard running -- times from "Data.Edison.Seq" except the following: -- -- * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop @O( log n )@ -- -- * copy, inBounds @O( i )@ -- -- * append, reverseOnto @O( n1 + log n2 )@ -- -- * take, splitAt @O( i + log n )@ -- -- * subseq @O( log n + len )@ -- -- * zip @O( min( n1, n2 ) + log max( n1, n2 ) )@ -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. -- Section 10.1.2. module Data.Edison.Seq.BinaryRandList ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Control.Applicative as App import Control.Monad.Identity import Data.Maybe 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 Test.QuickCheck -- signatures for exported functions moduleName :: String empty :: Seq a singleton :: a -> Seq a lcons :: a -> Seq a -> Seq a rcons :: a -> Seq a -> Seq a append :: Seq a -> Seq a -> Seq a lview :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.BinaryRandList" data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a)) deriving (Eq) -- not exported, rewrite as bit ops? --even n = (n `mod` 2) == 0 --odd n = (n `mod` 2) <> 0 half :: (Integral a) => a -> a half n = n `div` 2 mkEven :: Seq (a, a) -> Seq a mkEven E = E mkEven ps = Even ps empty = E singleton x = Odd x E lcons x E = Odd x E lcons x (Even ps) = Odd x ps lcons x (Odd y ps) = Even (lcons (x,y) ps) append xs E = xs append xs ys@(Even pys) = case xs of E -> ys Even pxs -> Even (append pxs pys) Odd x pxs -> Odd x (append pxs pys) append xs ys@(Odd _ _) = foldr lcons ys xs copy n x | n <= 0 = E | otherwise = cp n x where cp :: Int -> a -> Seq a cp n x | odd n = Odd x (cp (half n) (x,x)) | n == 0 = E | otherwise = Even (cp (half n) (x,x)) lview E = fail "BinaryRandList.lview: empty sequence" lview (Even ps) = case lview ps of Just ((x,y), ps') -> return (x, Odd y ps') Nothing -> error "BinaryRandList.lview: bug!" lview (Odd x ps) = return (x, mkEven ps) lhead E = error "BinaryRandList.lhead: empty sequence" lhead (Even ps) = fst (lhead ps) lhead (Odd x _) = x lheadM E = fail "BinaryRandList.lheadM: empty sequence" lheadM (Even ps) = return (fst (lhead ps)) lheadM (Odd x _) = return (x) ltail E = error "BinaryRandList.ltail: empty sequence" ltail (Even ps) = case lview ps of Just ((_,y), ps') -> Odd y ps' Nothing -> error "BinaryRandList.ltail: bug!" ltail (Odd _ ps) = mkEven ps ltailM E = fail "BinaryRandList.ltailM: empty sequence" ltailM (Even ps) = case lview ps of Just ((_,y), ps') -> return (Odd y ps') Nothing -> error "BinaryRandList.ltailM: bug!" ltailM (Odd _ ps) = return (mkEven ps) rhead E = error "BinaryRandList.rhead: empty sequence" rhead (Even ps) = snd (rhead ps) rhead (Odd x E) = x rhead (Odd _ ps) = snd (rhead ps) rheadM E = fail "BinaryRandList.rheadM: empty sequence" rheadM (Even ps) = return (snd (rhead ps)) rheadM (Odd x E) = return x rheadM (Odd _ ps) = return (snd (rhead ps)) null E = True null _ = False size E = 0 size (Even ps) = 2 * size ps size (Odd _ ps) = 1 + 2 * size ps map _ E = E map f (Even ps) = Even (map (\(x,y) -> (f x,f y)) ps) map f (Odd x ps) = Odd (f x) (map (\(y,z) -> (f y,f z)) ps) fold = foldr fold' = foldr' fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr _ e E = e foldr f e (Even ps) = foldr (\(x,y) e -> f x (f y e)) e ps foldr f e (Odd x ps) = f x (foldr (\(x,y) e -> f x (f y e)) e ps) foldr' _ e E = e foldr' f e (Even ps) = foldr' (\(x,y) e -> f x $! f y $! e) e ps foldr' f e (Odd x ps) = f x $! (foldr' (\(x,y) e -> f x $! f y $! e) e ps) foldl _ e E = e foldl f e (Even ps) = foldl (\e (x,y) -> f (f e x) y) e ps foldl f e (Odd x ps) = foldl (\e (x,y) -> f (f e x) y) (f e x) ps foldl' _ e E = e foldl' f e (Even ps) = foldl' (\e (x,y) -> f (f e x) y) e ps foldl' f e (Odd x ps) = e `seq` foldl' (\e (x,y) -> e `seq` (\z -> f z y) $! (f e x)) (f e x) ps reduce1 _ E = error "BinaryRandList.reduce1: empty seq" reduce1 f (Even ps) = reduce1 f (map (uncurry f) ps) reduce1 _ (Odd x E) = x reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps)) reduce1' _ E = error "BinaryRandList.reduce1': empty seq" reduce1' f (Even ps) = reduce1' f (map (uncurry f) ps) reduce1' _ (Odd x E) = x reduce1' f (Odd x ps) = (f $! x) $! (reduce1' f (map (uncurry f) ps)) inBounds i xs = (i >= 0) && inb xs i where inb :: Seq a -> Int -> Bool inb E _ = False inb (Even ps) i = inb ps (half i) inb (Odd _ ps) i = (i == 0) || inb ps (half (i-1)) lookup i xs = runIdentity (lookupM i xs) lookupM i xs | i < 0 = fail "BinaryRandList.lookup: bad subscript" | otherwise = lookFun nothing xs i return where nothing = fail "BinaryRandList.lookup: not found" lookupWithDefault d i xs | i < 0 = d | otherwise = lookFun d xs i id -- not exported lookFun :: b -> Seq a -> Int -> (a -> b) -> b lookFun d E _ _ = d lookFun d (Even ps) i f | even i = lookFun d ps (half i) (f . fst) | otherwise = lookFun d ps (half i) (f . snd) lookFun d (Odd x ps) i f | odd i = lookFun d ps (half (i-1)) (f . fst) | i == 0 = f x | otherwise = lookFun d ps (half (i-1)) (f . snd) adjust f i xs | i < 0 = xs | otherwise = adj f i xs where adj :: (a -> a) -> Int -> Seq a -> Seq a adj _ _ E = E adj f i (Even ps) | even i = Even (adj (mapFst f) (half i) ps) | otherwise = Even (adj (mapSnd f) (half i) ps) adj f i (Odd x ps) | odd i = Odd x (adj (mapFst f) (half (i-1)) ps) | i == 0 = Odd (f x) ps | otherwise = Odd x (adj (mapSnd f) (half (i-1)) ps) -- not exported mapFst :: (t -> t2) -> (t, t1) -> (t2, t1) mapFst f (x,y) = (f x,y) mapSnd :: (t1 -> t2) -> (t, t1) -> (t, t2) mapSnd f (x,y) = (x,f y) take n xs = if n <= 0 then E else tak n xs where tak :: Int -> Seq a -> Seq a tak 0 _ = E tak _ E = E tak i (Even ps) | even i = Even (tak (half i) ps) tak i (Odd x ps) | odd i = Odd x (tak (half (i-1)) ps) tak i xs = takeUsingLists i xs -- drop is O(log^2 n) instead of O(log n)?? drop n xs = if n <= 0 then xs else drp n xs where drp :: Int -> Seq a -> Seq a drp 0 xs = xs drp _ E = E drp i (Even ps) | even i = mkEven (drp (half i) ps) | otherwise = fromMaybe empty (ltailM (mkEven (drp (half i) ps))) drp i (Odd _ ps) | odd i = mkEven (drp (half (i-1)) ps) | otherwise = fromMaybe empty (ltailM (mkEven (drp (half (i-1)) ps))) strict l@E = l strict l@(Even l') = strict l' `seq` l strict l@(Odd _ l') = strict l' `seq` l strictWith _ l@E = l strictWith f l@(Even l') = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l strictWith f l@(Odd x _') = f x `seq` strictWith (\ (x,y) -> f x `seq` f y) `seq` l -- structural invariants are enforced by the type system structuralInvariant = const True -- the remaining functions all use defaults rcons = rconsUsingFoldr rview = rviewDefault rtail = rtailUsingLview rtailM = rtailMUsingLview concat = concatUsingFoldr reverse = reverseUsingReverseOnto reverseOnto = reverseOntoUsingFoldl fromList = fromListUsingCons toList = toListUsingFoldr concatMap = concatMapUsingFoldr foldr1 = foldr1UsingLview foldr1' = foldr1'UsingLview foldl1 = foldl1UsingFoldl foldl1' = foldl1'UsingFoldl' reducer = reducerUsingReduce1 reducel = reducelUsingReduce1 reducer' = reducer'UsingReduce1' reducel' = reducel'UsingReduce1' update = updateUsingAdjust mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldlWithIndex = foldlWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex' = foldlWithIndex'UsingLists splitAt = splitAtDefault filter = filterUsingFoldr partition = partitionUsingFoldr subseq = subseqDefault takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview -- for zips, could optimize by calculating which one is shorter and -- retaining its shape zip = zipUsingLists zip3 = zip3UsingLists zipWith = zipWithUsingLists zipWith3 = zipWith3UsingLists unzip = unzipUsingLists unzip3 = unzip3UsingLists unzipWith = unzipWithUsingLists unzipWith3 = unzipWith3UsingLists -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/Defaults.hs0000644000000000000000000004161213223626550017620 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.Defaults -- Copyright : Copyright (c) 1998, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : internal (unstable) -- Portability : GHC, Hugs (MPTC and FD) -- -- This module provides default implementations of many of -- the sequence operations. It is used to fill in implementations -- and is not intended for end users. module Data.Edison.Seq.Defaults where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import Control.Monad.Identity import Data.Char (isSpace) import Data.Edison.Seq import qualified Data.Edison.Seq.ListSeq as L rconsUsingAppend :: Sequence s => a -> s a -> s a rconsUsingAppend x s = append s (singleton x) rconsUsingFoldr :: Sequence s => a -> s a -> s a rconsUsingFoldr x s = foldr lcons (singleton x) s appendUsingFoldr :: Sequence s => s a -> s a -> s a appendUsingFoldr s t | null t = s | otherwise = foldr lcons t s rviewDefault :: (Monad m, Sequence s) => s a -> m (a, s a) rviewDefault xs | null xs = fail $ instanceName xs ++ ".rview: empty sequence" | otherwise = return (rhead xs, rtail xs) rtailUsingLview :: (Sequence s) => s a -> s a rtailUsingLview xs = case lview xs of Nothing -> error $ instanceName xs ++ ".rtail: empty sequence" Just (x, xs) -> rt x xs where rt x xs = case lview xs of Nothing -> empty Just (y, ys) -> lcons x (rt y ys) rtailMUsingLview :: (Monad m,Sequence s) => s a -> m (s a) rtailMUsingLview xs = case lview xs of Nothing -> fail $ instanceName xs ++ ".rtailM: empty sequence" Just (x, xs) -> return (rt x xs) where rt x xs = case lview xs of Nothing -> empty Just (y, ys) -> lcons x (rt y ys) concatUsingFoldr :: Sequence s => s (s a) -> s a concatUsingFoldr = foldr append empty reverseUsingReverseOnto :: Sequence s => s a -> s a reverseUsingReverseOnto s = reverseOnto s empty reverseUsingLists :: Sequence s => s a -> s a reverseUsingLists = fromList . L.reverse . toList reverseOntoUsingFoldl :: Sequence s => s a -> s a -> s a reverseOntoUsingFoldl xs ys = foldl (flip lcons) ys xs reverseOntoUsingReverse :: Sequence s => s a -> s a -> s a reverseOntoUsingReverse = append . reverse fromListUsingCons :: Sequence s => [a] -> s a fromListUsingCons = L.foldr lcons empty toListUsingFoldr :: Sequence s => s a -> [a] toListUsingFoldr = foldr (:) [] mapUsingFoldr :: Sequence s => (a -> b) -> s a -> s b mapUsingFoldr f = foldr (lcons . f) empty concatMapUsingFoldr :: Sequence s => (a -> s b) -> s a -> s b concatMapUsingFoldr f = foldr (append . f) empty foldrUsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b foldrUsingLists f e xs = L.foldr f e (toList xs) foldr'UsingLists :: Sequence s => (a -> b -> b) -> b -> s a -> b foldr'UsingLists f e xs = L.foldr' f e (toList xs) foldlUsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b foldlUsingLists f e xs = L.foldl f e (toList xs) foldl'UsingLists :: Sequence s => (b -> a -> b) -> b -> s a -> b foldl'UsingLists f e xs = L.foldl' f e (toList xs) foldr1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldr1UsingLists f xs = L.foldr1 f (toList xs) foldr1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldr1'UsingLists f xs = L.foldr1' f (toList xs) foldl1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldl1UsingLists f xs = L.foldl1 f (toList xs) foldl1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a foldl1'UsingLists f xs = L.foldl1' f (toList xs) fold1UsingFold :: Sequence s => (a -> a -> a) -> s a -> a fold1UsingFold f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".fold1: empty sequence" Just (x, xs) -> fold f x xs fold1'UsingFold' :: Sequence s => (a -> a -> a) -> s a -> a fold1'UsingFold' f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".fold1': empty sequence" Just (x, xs) -> fold' f x xs foldr1UsingLview :: Sequence s => (a -> a -> a) -> s a -> a foldr1UsingLview f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldr1: empty sequence" Just (x, xs) -> fr1 x xs where fr1 x xs = case lview xs of Nothing -> x Just (y,ys) -> f x (fr1 y ys) foldr1'UsingLview :: Sequence s => (a -> a -> a) -> s a -> a foldr1'UsingLview f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldr1': empty sequence" Just (x,xs) -> fr1 x xs where fr1 x xs = case lview xs of Nothing -> x Just (y,ys) -> f x $! (fr1 y ys) foldl1UsingFoldl :: Sequence s => (a -> a -> a) -> s a -> a foldl1UsingFoldl f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldl1: empty sequence" Just (x,xs) -> foldl f x xs foldl1'UsingFoldl' :: Sequence s => (a -> a -> a) -> s a -> a foldl1'UsingFoldl' f xs = case lview xs of Nothing -> error $ instanceName xs ++ ".foldl1': empty sequence" Just (x,xs) -> foldl' f x xs reducerUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a reducerUsingReduce1 f e s | null s = e | otherwise = f (reduce1 f s) e reducer'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a reducer'UsingReduce1' f e s | null s = e | otherwise = f (reduce1' f s) e reducelUsingReduce1 :: Sequence s => (a -> a -> a) -> a -> s a -> a reducelUsingReduce1 f e s | null s = e | otherwise = f e (reduce1 f s) reducel'UsingReduce1' :: Sequence s => (a -> a -> a) -> a -> s a -> a reducel'UsingReduce1' f e s | null s = e | otherwise = f e (reduce1' f s) reduce1UsingLists :: Sequence s => (a -> a -> a) -> s a -> a reduce1UsingLists f s = L.reduce1 f (toList s) reduce1'UsingLists :: Sequence s => (a -> a -> a) -> s a -> a reduce1'UsingLists f s = L.reduce1' f (toList s) copyUsingLists :: Sequence s => Int -> a -> s a copyUsingLists n x = fromList (L.copy n x) inBoundsUsingDrop :: Sequence s => Int -> s a -> Bool inBoundsUsingDrop i s = i >= 0 && not (null (drop i s)) inBoundsUsingLookupM :: Sequence s => Int -> s a -> Bool inBoundsUsingLookupM i s = case lookupM i s of Just _ -> True Nothing -> False inBoundsUsingSize :: Sequence s => Int -> s a -> Bool inBoundsUsingSize i s = i >= 0 && i < size s lookupUsingLookupM :: Sequence s => Int -> s a -> a lookupUsingLookupM i s = runIdentity (lookupM i s) lookupUsingDrop :: Sequence s => Int -> s a -> a lookupUsingDrop i s | i < 0 || null s' = error $ instanceName s ++ ".lookup: bad subscript" | otherwise = lhead s' where s' = drop i s lookupWithDefaultUsingLookupM :: Sequence s => a -> Int -> s a -> a lookupWithDefaultUsingLookupM d i s = case lookupM i s of Nothing -> d Just x -> x lookupWithDefaultUsingDrop :: Sequence s => a -> Int -> s a -> a lookupWithDefaultUsingDrop d i s | i < 0 || null s' = d | otherwise = lhead s' where s' = drop i s lookupMUsingDrop :: (Monad m, Sequence s) => Int -> s a -> m a lookupMUsingDrop i s -- XXX better error message! | i < 0 || null s' = fail $ instanceName s ++ ".lookupMUsingDrop: empty sequence" | otherwise = return (lhead s') where s' = drop i s filterUsingLview :: Sequence s => (a -> Bool) -> s a -> s a filterUsingLview p xs = case lview xs of Nothing -> empty Just (x,xs) -> if p x then lcons x (filter p xs) else filter p xs filterUsingLists :: Sequence s => (a -> Bool) -> s a -> s a filterUsingLists p xs = fromList (L.filter p (toList xs)) filterUsingFoldr :: Sequence s => (a -> Bool) -> s a -> s a filterUsingFoldr p = foldr pcons empty where pcons x xs = if p x then lcons x xs else xs partitionUsingLists :: Sequence s => (a -> Bool) -> s a -> (s a, s a) partitionUsingLists p xs = let (ys,zs) = L.partition p (toList xs) in (fromList ys, fromList zs) partitionUsingFoldr :: Sequence s => (a -> Bool) -> s a -> (s a, s a) partitionUsingFoldr p = foldr pcons (empty, empty) where pcons x (xs, xs') = if p x then (lcons x xs, xs') else (xs, lcons x xs') updateUsingAdjust :: Sequence s => Int -> a -> s a -> s a updateUsingAdjust i y = adjust (const y) i updateUsingSplitAt :: Sequence s => Int -> a -> s a -> s a updateUsingSplitAt i x xs | i < 0 = xs | otherwise = let (ys,zs) = splitAt i xs in if null zs then xs else append ys (lcons x (ltail zs)) adjustUsingLists :: Sequence s => (a -> a) -> Int -> s a -> s a adjustUsingLists f i xs = fromList (L.adjust f i (toList xs)) adjustUsingSplitAt :: Sequence s => (a -> a) -> Int -> s a -> s a adjustUsingSplitAt f i xs | i < 0 = xs | otherwise = let (ys,zs) = splitAt i xs in case lview zs of Nothing -> xs Just (z,zs') -> append ys (lcons (f z) zs') {- insertAtUsingLists :: Sequence s => Int -> a -> s a -> s a insertAtUsingLists i x xs = fromList (L.insertAt i x (toList xs)) insertAtUsingSplitAt :: Sequence s => Int -> a -> s a -> s a insertAtUsingSplitAt i x xs | (xs_before, xs_after) <- splitAt i xs = append xs_before (lcons x xs_after) deleteAtUsingLists :: Sequence s => Int -> s a -> s a deleteAtUsingLists i xs = fromList (L.deleteAt i (toList xs)) deleteAtUsingSplitAt :: Sequence s => Int -> s a -> s a deleteAtUsingSplitAt i xs | (xs_before, xs_after) <- splitAt i xs = append xs_before (ltail xs_after) -} mapWithIndexUsingLists :: Sequence s => (Int -> a -> b) -> s a -> s b mapWithIndexUsingLists f xs = fromList (L.mapWithIndex f (toList xs)) foldrWithIndexUsingLists :: Sequence s => (Int -> a -> b -> b) -> b -> s a -> b foldrWithIndexUsingLists f e xs = L.foldrWithIndex f e (toList xs) foldrWithIndex'UsingLists :: Sequence s => (Int -> a -> b -> b) -> b -> s a -> b foldrWithIndex'UsingLists f e xs = L.foldrWithIndex' f e (toList xs) foldlWithIndexUsingLists :: Sequence s => (b -> Int -> a -> b) -> b -> s a -> b foldlWithIndexUsingLists f e xs = L.foldlWithIndex f e (toList xs) foldlWithIndex'UsingLists :: Sequence s => (b -> Int -> a -> b) -> b -> s a -> b foldlWithIndex'UsingLists f e xs = L.foldlWithIndex' f e (toList xs) takeUsingLists :: Sequence s => Int -> s a -> s a takeUsingLists i s = fromList (L.take i (toList s)) takeUsingLview :: Sequence s => Int -> s a -> s a takeUsingLview i xs | i <= 0 = empty | otherwise = case lview xs of Nothing -> empty Just (x,xs') -> lcons x (take (i-1) xs') dropUsingLists :: Sequence s => Int -> s a -> s a dropUsingLists i s = fromList (L.drop i (toList s)) dropUsingLtail :: Sequence s => Int -> s a -> s a dropUsingLtail i xs | i <= 0 || null xs = xs | otherwise = dropUsingLtail (i-1) (ltail xs) splitAtDefault :: Sequence s => Int -> s a -> (s a, s a) splitAtDefault i s = (take i s, drop i s) splitAtUsingLview :: Sequence s => Int -> s a -> (s a, s a) splitAtUsingLview i xs | i <= 0 = (empty,xs) | otherwise = case lview xs of Nothing -> (empty,empty) Just (x,xs') -> (lcons x ys,zs) where (ys,zs) = splitAtUsingLview (i-1) xs' subseqDefault :: Sequence s => Int -> Int -> s a -> s a subseqDefault i len xs = take len (drop i xs) takeWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a takeWhileUsingLview p xs = case lview xs of Just (x,xs') | p x -> lcons x (takeWhileUsingLview p xs') _ -> empty dropWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> s a dropWhileUsingLview p xs = case lview xs of Just (x,xs') | p x -> dropWhileUsingLview p xs' _ -> xs splitWhileUsingLview :: Sequence s => (a -> Bool) -> s a -> (s a, s a) splitWhileUsingLview p xs = case lview xs of Just (x,xs') | p x -> let (front, back) = splitWhileUsingLview p xs' in (lcons x front, back) _ -> (empty, xs) zipUsingLview :: Sequence s => s a -> s b -> s (a,b) zipUsingLview xs ys = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> lcons (x,y) (zipUsingLview xs' ys') zip3UsingLview :: Sequence s => s a -> s b -> s c -> s (a,b,c) zip3UsingLview xs ys zs = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> case lview zs of Nothing -> empty Just (z,zs') -> lcons (x,y,z) (zip3UsingLview xs' ys' zs') zipWithUsingLview :: Sequence s => (a -> b -> c) -> s a -> s b -> s c zipWithUsingLview f xs ys = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> lcons (f x y) (zipWithUsingLview f xs' ys') zipWith3UsingLview :: Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d zipWith3UsingLview f xs ys zs = case lview xs of Nothing -> empty Just (x,xs') -> case lview ys of Nothing -> empty Just (y,ys') -> case lview zs of Nothing -> empty Just (z,zs') -> lcons (f x y z) (zipWith3UsingLview f xs' ys' zs') zipUsingLists :: Sequence s => s a -> s b -> s (a,b) zipUsingLists xs ys = fromList (L.zip (toList xs) (toList ys)) zip3UsingLists :: Sequence s => s a -> s b -> s c -> s (a,b,c) zip3UsingLists xs ys zs = fromList (L.zip3 (toList xs) (toList ys) (toList zs)) zipWithUsingLists :: Sequence s => (a -> b -> c) -> s a -> s b -> s c zipWithUsingLists f xs ys = fromList (L.zipWith f (toList xs) (toList ys)) zipWith3UsingLists :: Sequence s => (a -> b -> c -> d) -> s a -> s b -> s c -> s d zipWith3UsingLists f xs ys zs = fromList (L.zipWith3 f (toList xs) (toList ys) (toList zs)) unzipUsingLists :: Sequence s => s (a,b) -> (s a, s b) unzipUsingLists xys = case L.unzip (toList xys) of (xs, ys) -> (fromList xs, fromList ys) unzipUsingFoldr :: Sequence s => s (a,b) -> (s a, s b) unzipUsingFoldr = foldr pcons (empty,empty) where pcons (x,y) (xs,ys) = (lcons x xs, lcons y ys) unzip3UsingLists :: Sequence s => s (a,b,c) -> (s a, s b, s c) unzip3UsingLists xyzs = case L.unzip3 (toList xyzs) of (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs) unzip3UsingFoldr :: Sequence s => s (a,b,c) -> (s a, s b, s c) unzip3UsingFoldr = foldr tcons (empty,empty,empty) where tcons (x,y,z) (xs,ys,zs) = (lcons x xs, lcons y ys, lcons z zs) unzipWithUsingLists :: Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c) unzipWithUsingLists f g xys = case L.unzipWith f g (toList xys) of (xs, ys) -> (fromList xs, fromList ys) unzipWithUsingFoldr :: Sequence s => (a -> b) -> (a -> c) -> s a -> (s b, s c) unzipWithUsingFoldr f g = foldr pcons (empty,empty) where pcons e (xs,ys) = (lcons (f e) xs, lcons (g e) ys) unzipWith3UsingLists :: Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d) unzipWith3UsingLists f g h xyzs = case L.unzipWith3 f g h (toList xyzs) of (xs, ys, zs) -> (fromList xs, fromList ys, fromList zs) unzipWith3UsingFoldr :: Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> s a -> (s b, s c, s d) unzipWith3UsingFoldr f g h = foldr tcons (empty,empty,empty) where tcons e (xs,ys,zs) = (lcons (f e) xs, lcons (g e) ys, lcons (h e) zs) showsPrecUsingToList :: (Show a,Sequence s) => Int -> s a -> ShowS showsPrecUsingToList i xs rest | i == 0 = concat [ instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) rest | otherwise = concat ["(",instanceName xs,".fromList "] ++ showsPrec 10 (toList xs) (')':rest) readsPrecUsingFromList :: (Read a,Sequence s) => Int -> ReadS (s a) readsPrecUsingFromList _ xs = let result = maybeParens p xs p xs = tokenMatch ((instanceName x)++".fromList") xs >>= readsPrec 10 >>= \(l,rest) -> return (fromList l,rest) -- play games with the typechecker so we don't have to use -- extensions for scoped type variables ~[(x,_)] = result in result defaultCompare :: (Ord a, Sequence s) => s a -> s a -> Ordering defaultCompare a b = case (lview a, lview b) of (Nothing, Nothing) -> EQ (Nothing, _ ) -> LT (_ , Nothing) -> GT (Just (x,xs), Just (y,ys)) -> case compare x y of EQ -> defaultCompare xs ys c -> c dropMatch :: (Eq a,MonadPlus m) => [a] -> [a] -> m [a] dropMatch [] ys = return ys dropMatch (x:xs) (y:ys) | x == y = dropMatch xs ys | otherwise = mzero dropMatch _ _ = mzero tokenMatch :: MonadPlus m => String -> String -> m String tokenMatch token str = dropMatch token (munch str) >>= return . munch where munch = dropWhile isSpace readSParens :: ReadS a -> ReadS a readSParens p xs = return xs >>= tokenMatch "(" >>= p >>= \(x,xs') -> return xs' >>= tokenMatch ")" >>= \rest -> return (x,rest) maybeParens :: ReadS a -> ReadS a maybeParens p xs = readSParens p xs `mplus` p xs EdisonCore-1.3.2.1/src/Data/Edison/Seq/BraunSeq.hs0000644000000000000000000004535313223626550017577 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.BraunSeq -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- One-sided Braun sequences. All running times are as listed in -- "Data.Edison.Seq" except the following: -- -- * lview, lcons, ltail* @O( log n )@ -- -- * rcons, rview, rhead*, rtail*, size @O( log^2 n )@ -- -- * copy, inBounds, lookup*, update, adjust @O( log i )@ -- -- * append @O( n1 log n2 )@ -- -- * concat @O( n + m log m )@ -- -- * drop, splitAt @O( i log n )@ -- -- * subseq @O( i log n + len )@ -- -- * reverseOnto @O( n1 log n2 )@ -- -- * concatMap, (>>=) @O( n * t + m log m )@, where @n@ is the length of the input sequence -- @m@ is the length of the output sequence and @t@ -- is the running time of @f@ -- -- By keeping track of the size, we could get rcons, rview, rhead*, and rtail* -- down to @O(log n)@ as well; furthermore, size would be @O( 1 )@. -- -- /References:/ -- -- * Rob Hoogerwoord. \"A symmetric set of efficient list operations\". -- /Journal of Functional Programming/, 2(4):505--513, 1992. -- -- * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\". -- /Mathematics of Program Construction/ (MPC'92), pages 191-207. -- -- * Chris Okasaki. \"Three algorithms on Braun Trees\". -- /Journal of Function Programming/ 7(6):661-666. Novemebr 1997. module Data.Edison.Seq.BraunSeq ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Control.Applicative as App import Control.Monad.Identity import Data.Maybe import Data.Monoid import Data.Semigroup as SG import Test.QuickCheck import qualified Data.Edison.Seq as S ( Sequence(..) ) import Data.Edison.Seq.Defaults import qualified Data.Edison.Seq.ListSeq as L -- signatures for exported functions moduleName :: String empty :: Seq a singleton :: a -> Seq a lcons :: a -> Seq a -> Seq a rcons :: a -> Seq a -> Seq a append :: Seq a -> Seq a -> Seq a lview :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.BraunSeq" data Seq a = E | B a (Seq a) (Seq a) deriving (Eq) half :: Int -> Int half n = n `quot` 2 -- use a shift? empty = E singleton x = B x E E lcons x E = singleton x lcons x (B y a b) = B x (lcons y b) a rcons y ys = insAt (size ys) ys where insAt 0 _ = singleton y insAt i (B x a b) | odd i = B x (insAt (half i) a) b | otherwise = B x a (insAt (half i - 1) b) insAt _ _ = error "BraunSeq.rcons: bug. Impossible case!" append xs E = xs append xs ys = app (size xs) xs ys where app 0 _ ys = ys app _ xs E = xs app n (B x a b) (B y c d) | odd n = B x (app m a (lcons y d)) (app m b c) | otherwise = B x (app m a c) (app (m-1) b (lcons y d)) where m = half n app _ _ _ = error "BraunSeq.append: bug!" -- how does it compare to converting to/from lists? lview E = fail "BraunSeq.lview: empty sequence" lview (B x a b) = return (x, combine a b) -- not exported combine :: Seq a -> Seq a -> Seq a combine E _ = E combine (B x a b) c = B x c (combine a b) lhead E = error "BraunSeq.lhead: empty sequence" lhead (B x _ _) = x lheadM E = fail "BraunSeq.lheadM: empty sequence" lheadM (B x _ _) = return x ltail E = error "BraunSeq.ltail: empty sequence" ltail (B _ a b) = combine a b ltailM E = fail "BraunSeq.ltailM: empty sequence" ltailM (B _ a b) = return (combine a b) -- not exported -- precondition: i >= 0 delAt :: Int -> Seq a -> Seq a delAt 0 _ = E delAt i (B x a b) | odd i = B x (delAt (half i) a) b | otherwise = B x a (delAt (half i - 1) b) delAt _ _ = error "BraunSeq.delAt: bug. Impossible case!" rview E = fail "BraunSeq.rview: empty sequence" rview xs = return (lookup m xs, delAt m xs) where m = size xs - 1 rhead E = error "BraunSeq.rhead: empty sequence" rhead xs = lookup (size xs - 1) xs rheadM E = fail "BraunSeq.rheadM: empty sequence" rheadM xs = return (lookup (size xs - 1) xs) rtail E = error "BraunSeq.rtail: empty sequence" rtail xs = delAt (size xs - 1) xs rtailM E = fail "BraunSeq.rtailM: empty sequence" rtailM xs = return (delAt (size xs - 1) xs) null E = True null _ = False size E = 0 size (B _ a b) = 1 + n + n + diff n a where n = size b diff 0 E = 0 diff 0 (B _ _ _) = 1 diff i (B _ a b) | odd i = diff (half i) a | otherwise = diff (half i - 1) b diff _ _ = error "BraunSeq.size: bug. Impossible case in diff!" reverse xs = rev00 (size xs) xs where rev00 n xs | n <= 1 = xs rev00 n (B x a b) | odd n = let a' = rev00 m a (x',b') = rev11 m x b in B x' a' b' | otherwise = let (x',a') = rev01 m a b' = rev10 (m-1) x b in B x' b' a' where m = half n rev00 _ _ = error "BraunSeq.reverse: bug!" rev11 _ x E = (x,E) rev11 n x (B y a b) | odd n = let (x',a') = rev11 m x a (y',b') = rev11 m y b in (y', B x' b' a') | otherwise = let (x',a') = rev11 m x a (y',b') = rev11 (m-1) y b in (x', B y' a' b') where m = half n rev01 _ E = error "BraunSeq.reverse: bug!" rev01 n (B x a b) | n == 1 = (x, E) | odd n = let (y',a') = rev01 m a (x',b') = rev11 m x b in (x', B y' b' a') | otherwise = let (y',a') = rev01 m a (x',b') = rev11 (m-1) x b in (y', B x' a' b') where m = half n rev10 _ x E = B x E E rev10 n x (B y a b) | odd n = let a' = rev10 m x a (y',b') = rev11 m y b in B y' a' b' | otherwise = let (x',a') = rev11 m x a b' = rev10 (m-1) y b in B x' b' a' where m = half n fromList = L.lhead . L.foldr build [E] . rows 1 where rows _ [] = [] rows k xs = (k, ys) : rows (k+k) zs where (ys,zs) = L.splitAt k xs build (k,xs) ts = zipWithB xs ts1 ts2 where (ts1, ts2) = L.splitAt k ts zipWithB [] _ _ = [] zipWithB (x:xs) [] _ = singleton x : L.map singleton xs zipWithB (x:xs) (t:ts) [] = B x t E : zipWithB xs ts [] zipWithB (x:xs) (t1:ts1) (t2:ts2) = B x t1 t2 : zipWithB xs ts1 ts2 toList E = [] toList t = tol [t] where tol [] = [] tol ts = xs ++ tol (ts1 ++ ts2) where xs = L.map root ts (ts1,ts2) = children ts children [] = ([],[]) children (B _ E _ : _) = ([],[]) children (B _ a E : ts) = (a : leftChildren ts, []) children (B _ a b : ts) = (a : ts1, b : ts2) where (ts1, ts2) = children ts children _ = error "BraunSeq.toList: bug!" leftChildren [] = [] leftChildren (B _ E _ : _) = [] leftChildren (B _ a _ : ts) = a : leftChildren ts leftChildren _ = error "BraunSeq.toList: bug!" root (B x _ _) = x root _ = error "BraunSeq.toList: bug!" (B _ a _) = a -- (left _) = error "BraunSeq.toList: bug!" map _ E = E map f (B x a b) = B (f x) (map f a) (map f b) copy n x = if n <= 0 then empty else fst (copy2 n) where copy2 n | odd n = (B x a a, B x b a) | n == 0 = (E, singleton x) | otherwise = (B x b a, B x b b) where (a, b) = copy2 (half (n-1)) inBounds i xs = (i >= 0) && inb xs i where inb E _ = False inb (B _ a b) i | odd i = inb a (half i) | i == 0 = True | otherwise = inb b (half i - 1) lookup i xs = runIdentity (lookupM i xs) lookupM i xs | i < 0 = fail "BraunSeq.lookupM: bad subscript" | otherwise = look xs i where look E _ = nothing look (B x a b) i | odd i = look a (half i) | i == 0 = return x | otherwise = look b (half i - 1) nothing = fail "BraunSeq.lookupM: not found" lookupWithDefault d i xs = if i < 0 then d else look xs i where look E _ = d look (B x a b) i | odd i = look a (half i) | i == 0 = x | otherwise = look b (half i - 1) update i y xs = if i < 0 then xs else upd i xs where upd _ E = E upd i (B x a b) | odd i = B x (upd (half i) a) b | i == 0 = B y a b | otherwise = B x a (upd (half i - 1) b) adjust f i xs = if i < 0 then xs else adj i xs where adj _ E = E adj i (B x a b) | odd i = B x (adj (half i) a) b | i == 0 = B (f x) a b | otherwise = B x a (adj (half i - 1) b) mapWithIndex f xs = mwi 0 1 xs where mwi _ _ E = E mwi i d (B x a b) = B (f i x) (mwi (i+d) dd a) (mwi (i+dd) dd b) where dd = d+d take n xs = if n <= 0 then E else ta n xs where ta _ E = E ta n (B x a b) | odd n = B x (ta m a) (ta m b) | n == 0 = E | otherwise = B x (ta m a) (ta (m-1) b) where m = half n drop n xs = if n <= 0 then xs else dr n xs where dr _ E = E dr n t@(B _ a b) | odd n = combine (dr m a) (dr m b) | n == 0 = t | otherwise = combine (dr (m-1) b) (dr m a) where m = half n zip (B x a b) (B y c d) = B (x,y) (zip a c) (zip b d) zip _ _ = E zip3 (B x a b) (B y c d) (B z e f) = B (x,y,z) (zip3 a c e) (zip3 b d f) zip3 _ _ _ = E zipWith f (B x a b) (B y c d) = B (f x y) (zipWith f a c) (zipWith f b d) zipWith _ _ _ = E zipWith3 fn (B x a b) (B y c d) (B z e f) = B (fn x y z) (zipWith3 fn a c e) (zipWith3 fn b d f) zipWith3 _ _ _ _ = E unzip E = (E, E) unzip (B (x,y) a b) = (B x a1 b1, B y a2 b2) where (a1,a2) = unzip a (b1,b2) = unzip b unzip3 E = (E, E, E) unzip3 (B (x,y,z) a b) = (B x a1 b1, B y a2 b2, B z a3 b3) where (a1,a2,a3) = unzip3 a (b1,b2,b3) = unzip3 b unzipWith _ _ E = (E, E) unzipWith f g (B x a b) = (B (f x) a1 b1, B (g x) a2 b2) where (a1,a2) = unzipWith f g a (b1,b2) = unzipWith f g b unzipWith3 _ _ _ E = (E, E, E) unzipWith3 f g h (B x a b) = (B (f x) a1 b1, B (g x) a2 b2, B (h x) a3 b3) where (a1,a2,a3) = unzipWith3 f g h a (b1,b2,b3) = unzipWith3 f g h b strict s@E = s strict s@(B _ l r) = strict l `seq` strict r `seq` s strictWith _ s@E = s strictWith f s@(B x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s -- invariants: -- * Left subtree is exactily the same size as the right -- subtree, or one element larger -- structuralInvariant :: Seq a -> Bool structuralInvariant E = True structuralInvariant (B _ l r) = isJust (check l r) where check :: Seq a -> Seq a -> Maybe Int check E E = Just 1 check (B _ E E) E = Just 2 check (B _ l1 l2) (B _ r1 r2) = do x <- check l1 l2 y <- check r1 r2 if (x == y) || (x == y + 1) then return (x+y+1) else fail "unbalanced tree" check _ _ = fail "unbalanced tree" -- the remaining functions all use defaults concat = concatUsingFoldr reverseOnto = reverseOntoUsingReverse concatMap = concatMapUsingFoldr fold = foldrUsingLists fold' f = foldl'UsingLists (flip f) fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr = foldrUsingLists foldr' = foldr'UsingLists foldl = foldlUsingLists foldl' = foldl'UsingLists foldr1 = foldr1UsingLists foldr1' = foldr1'UsingLists foldl1 = foldl1UsingLists foldl1' = foldl1UsingLists reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' reduce1 = reduce1UsingLists reduce1' = reduce1'UsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists splitAt = splitAtDefault subseq = subseqDefault filter = filterUsingLists partition = partitionUsingLists takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/MyersStack.hs0000644000000000000000000003446313223626550020144 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.MyersStack -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Meyers Stacks. All operations are as listed in "Data.Edison.Seq" except -- the following: -- -- * lookup, inBounds, drop @O( min(i, log n) )@ -- -- * rhead*, size @O( log n )@ -- -- * subseq @O( min (i, log n) + len )@ -- -- /References:/ -- -- * Eugene Myers. \"An applicative random-access stack\". /Information -- Processing Letters/, 17(5):241-248, December 1983. module Data.Edison.Seq.MyersStack ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Control.Applicative as App import qualified Data.Edison.Seq as S ( Sequence(..) ) import Data.Edison.Seq.Defaults import Control.Monad.Identity 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 :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.MyersStack" data Seq a = E | C !Int a (Seq a) (Seq a) -- what about strictness flags on tail and jump-tail? -- auxiliary function jump :: Seq t -> Seq t jump (C _ _ _ (C _ _ _ xs')) = xs' jump _ = error "MyersStack.jump: bug!" empty = E singleton x = C 1 x E E lcons x xs@(C i _ _ (C j _ _ xs')) | i == j = C (1 + i + j) x xs xs' lcons x xs = C 1 x xs xs lview E = fail "MyersStack.lview: empty sequence" lview (C _ x xs _) = return (x, xs) lhead E = error "MyersStack.lhead: empty sequence" lhead (C _ x _ _) = x lheadM E = fail "MyersStack.lheadM: empty sequence" lheadM (C _ x _ _) = return x ltail E = error "MyersStack.ltail: empty sequence" ltail (C _ _ xs _) = xs ltailM E = fail "MyersStack.ltailM: empty sequence" ltailM (C _ _ xs _) = return xs rview E = fail "MyersStack.rview: empty sequence" rview xs = return (rhead xs, rtail xs) rhead E = error "MyersStack.rhead: empty sequence" rhead (C _ x xs xs') = rh x xs xs' where rh _ _ (C _ y ys ys') = rh y ys ys' rh _ (C _ y ys ys') E = rh y ys ys' rh x E E = x rheadM E = fail "MyersStack.rheadM: empty sequence" rheadM (C _ x xs xs') = return (rh x xs xs') where rh _ _ (C _ y ys ys') = rh y ys ys' rh _ (C _ y ys ys') E = rh y ys ys' rh x E E = x rtail E = error "MyersStack.rtail: empty sequence" rtail (C _ x xs _) = rt x xs where rt _ E = E rt y (C _ x xs _) = lcons y (rt x xs) rtailM E = fail "MyersStack.rtailM: empty sequence" rtailM (C _ x xs _) = return (rt x xs) where rt _ E = E rt y (C _ x xs _) = lcons y (rt x xs) null E = True null _ = False size xs = go xs where go E = (0::Int) go (C j _ _ xs') = j + size xs' reverseOnto E ys = ys reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys) map _ E = E map f (C j x xs _') | j == 1 = C j (f x) ys ys | otherwise = C j (f x) ys (jump ys) where ys = map f xs fold = foldr fold' f = foldl' (flip f) fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr _ e E = e foldr f e (C _ x xs _) = f x (foldr f e xs) foldr' _ e E = e foldr' f e (C _ x xs _) = f x $! (foldr' f e xs) foldl _ e E = e foldl f e (C _ x xs _) = foldl f (f e x) xs foldl' _ e E = e foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs foldr1 _ E = error "MyersStack.foldr1: empty sequence" foldr1 f (C _ x xs _) = fr x xs where fr y E = y fr y (C _ x xs _) = f y (fr x xs) foldr1' _ E = error "MyersStack.foldr1': empty sequence" foldr1' f (C _ x xs _) = fr x xs where fr y E = y fr y (C _ x xs _) = f y $! (fr x xs) foldl1 _ E = error "MyersStack.foldl1: empty sequence" foldl1 f (C _ x xs _) = foldl f x xs foldl1' _ E = error "MyersStack.foldl1': empty sequence" foldl1' f (C _ x xs _ ) = foldl' f x xs inBounds i xs = inb xs i where inb E _ = False inb (C j _ _ xs') i | i < j = (i >= 0) | otherwise = inb xs' (i - j) lookup i xs = runIdentity (lookupM i xs) lookupM i xs = look xs i where look E _ = fail "MyersStack.lookup: bad subscript" look (C j x xs xs') i | i >= j = look xs' (i - j) | i > 0 = look xs (i - 1) | i == 0 = return x | otherwise = nothing nothing = fail "MyersStack.lookup: not found" lookupWithDefault d i xs = look xs i where look E _ = d look (C j x xs xs') i | i >= j = look xs' (i - j) | i > 0 = look xs (i - 1) | i == 0 = x | otherwise = d update i y xs = upd i xs where upd _ E = E upd 0 (C j _ xs xs') = C j y xs xs' upd i (C j x xs _) | j == 1 = C j x ys ys | otherwise = C j x ys (jump ys) where ys = upd (i - 1) xs adjust f i xs = adj i xs where adj _ E = E adj 0 (C j x xs xs') = C j (f x) xs xs' adj i (C j x xs _) | j == 1 = C j x ys ys | otherwise = C j x ys (jump ys) where ys = adj (i - (1::Int)) xs drop n xs = drp n xs where drp n xs | n <= 0 = xs drp _ E = E drp n (C j _ xs xs') | n < j = drp (n - 1) xs | otherwise = drp (n - j) xs' unzip E = (E, E) unzip (C j (x,y) ps _') | j == 1 = (C j x xs xs, C j y ys ys) | otherwise = (C j x xs (jump xs), C j y ys (jump ys)) where (xs,ys) = unzip ps unzip3 E = (E, E, E) unzip3 (C j (x,y,z) ts _') | j == 1 = (C j x xs xs, C j y ys ys, C j z zs zs) | otherwise = (C j x xs (jump xs), C j y ys (jump ys), C j z zs (jump zs)) where (xs,ys,zs) = unzip3 ts unzipWith _ _ E = (E, E) unzipWith f g (C j x xs _) | j == 1 = (C j (f x) as as, C j (g x) bs bs) | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs)) where (as,bs) = unzipWith f g xs unzipWith3 _ _ _ E = (E, E, E) unzipWith3 f g h (C j x xs _) | j == 1 = (C j (f x) as as, C j (g x) bs bs, C j (h x) cs cs) | otherwise = (C j (f x) as (jump as), C j (g x) bs (jump bs), C j (h x) cs (jump cs)) where (as,bs,cs) = unzipWith3 f g h xs strict s@E = s strict s@(C _ _ xs _) = strict xs `seq` s strictWith _ s@E = s strictWith f s@(C _ x xs _) = f x `seq` strictWith f xs `seq` s -- the remaining functions all use defaults rcons = rconsUsingFoldr append = appendUsingFoldr concat = concatUsingFoldr reverse = reverseUsingReverseOnto fromList = fromListUsingCons toList = toListUsingFoldr concatMap = concatMapUsingFoldr reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' reduce1 = reduce1UsingLists reduce1' = reduce1'UsingLists copy = copyUsingLists mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists take = takeUsingLists splitAt = splitAtDefault filter = filterUsingFoldr partition = partitionUsingFoldr subseq = subseqDefault takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview -- for zips, could optimize by calculating which one is shorter and -- retaining its shape zip = zipUsingLists zip3 = zip3UsingLists zipWith = zipWithUsingLists zipWith3 = zipWith3UsingLists -- FIXME what are the structural invariants? structuralInvariant = const True -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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 -} EdisonCore-1.3.2.1/src/Data/Edison/Seq/SimpleQueue.hs0000644000000000000000000003212413223626550020305 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.SimpleQueue -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Simple Queues. All operations have running times as listed in -- "Data.Edison.Seq" except for the following: -- -- * rcons, fromList @O( 1 )@ -- -- * lview, ltail* @O( 1 )@ if single threaded, @O( n )@ otherwise -- -- * inBounds, lookup, update, drop, splitAt @O( n )@ -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. -- Section 5.2. -- -- * F. Warren Burton. \"An efficient functional implementation of FIFO queues\". -- /Information Processing Letters/, 14(5):205-206, July 1982. module Data.Edison.Seq.SimpleQueue ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldlWithIndex,foldrWithIndex',foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified 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 Test.QuickCheck -- signatures for exported functions moduleName :: String empty :: Seq a singleton :: a -> Seq a lcons :: a -> Seq a -> Seq a rcons :: a -> Seq a -> Seq a append :: Seq a -> Seq a -> Seq a lview :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.SimpleQueue" data Seq a = Q [a] [a] -- invariant: front empty only if rear also empty -- not exported makeQ :: [a] -> [a] -> Seq a makeQ [] ys = Q (L.reverse ys) [] makeQ xs ys = Q xs ys empty = Q [] [] singleton x = Q [x] [] lcons x (Q xs ys) = Q (x:xs) ys rcons y (Q [] _) = Q [y] [] rcons y (Q xs ys) = Q xs (y:ys) append (Q xs1 ys1) (Q xs2 ys2) = Q (xs1 ++ L.reverseOnto ys1 xs2) ys2 lview (Q [] _) = fail "SimpleQueue.lview: empty sequence" lview (Q [x] ys) = return (x, Q (L.reverse ys) []) lview (Q (x:xs) ys) = return (x, Q xs ys) lhead (Q [] _) = error "SimpleQueue.lhead: empty sequence" lhead (Q (x:_) _) = x lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence" lheadM (Q (x:_) _) = return x ltail (Q [_] ys) = Q (L.reverse ys) [] ltail (Q (_:xs) ys) = Q xs ys ltail (Q [] _) = error "SimpleQueue.ltail: empty sequence" ltailM (Q [_] ys) = return (Q (L.reverse ys) []) ltailM (Q (_:xs) ys) = return (Q xs ys) ltailM (Q [] _) = fail "SimpleQueue.ltailM: empty sequence" rview (Q xs (y:ys)) = return (y, Q xs ys) rview (Q xs []) = case L.rview xs of Nothing -> fail "SimpleQueue.rview: empty sequence" Just (x,xs') -> return (x, Q xs' []) rhead (Q _ (y:_)) = y rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence" rhead (Q xs []) = L.rhead xs rheadM (Q _ (y:_)) = return y rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence" rheadM (Q xs []) = return (L.rhead xs) rtail (Q xs (_:ys)) = Q xs ys rtail (Q [] []) = error "SimpleQueue.rtail: empty sequence" rtail (Q xs []) = Q (L.rtail xs) [] rtailM (Q xs (_:ys)) = return (Q xs ys) rtailM (Q [] []) = fail "SimpleQueue.rtailM: empty sequence" rtailM (Q xs []) = return (Q (L.rtail xs) []) null (Q [] _) = True null _ = False size (Q xs ys) = length xs + length ys reverse (Q xs []) = Q (L.reverse xs) [] reverse (Q xs ys) = Q ys xs reverseOnto (Q xs1 ys1) (Q xs2 ys2) = Q (ys1 ++ L.reverseOnto xs1 xs2) ys2 fromList xs = Q xs [] toList (Q xs []) = xs toList (Q xs ys) = xs ++ L.reverse ys map f (Q xs ys) = Q (L.map f xs) (L.map f ys) -- local fn on lists revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1 revfoldr _ e [] = e revfoldr f e (x:xs) = revfoldr f (f x e) xs revfoldr' :: (t -> a -> a) -> a -> [t] -> a revfoldr' _ e [] = e revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs -- local fn on lists revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t revfoldl _ e [] = e revfoldl f e (x:xs) = f (revfoldl f e xs) x revfoldl' :: (a -> t -> a) -> a -> [t] -> a revfoldl' _ e [] = e revfoldl' f e (x:xs) = e `seq` f (revfoldl' f e xs) x fold f e (Q xs ys) = L.foldr f (L.foldr f e ys) xs fold' f e (Q xs ys) = L.foldl' (flip f) (L.foldl' (flip f) e ys) xs fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr f e (Q xs ys) = L.foldr f (revfoldr f e ys) xs foldr' f e (Q xs ys) = L.foldr' f (revfoldr' f e ys) xs foldl f e (Q xs ys) = revfoldl f (L.foldl f e xs) ys foldl' f e (Q xs ys) = revfoldl' f (L.foldl' f e xs) ys foldr1 f (Q xs (y:ys)) = L.foldr f (revfoldr f y ys) xs foldr1 _ (Q [] []) = error "SimpleQueue.foldr1: empty sequence" foldr1 f (Q xs []) = L.foldr1 f xs foldr1' f (Q xs (y:ys)) = L.foldr' f (revfoldr' f y ys) xs foldr1' _ (Q [] []) = error "SimpleQueye.foldr1': empty sequence" foldr1' f (Q xs []) = L.foldr1' f xs foldl1 f (Q (x:xs) ys) = revfoldl f (L.foldl f x xs) ys foldl1 _ (Q [] _) = error "SimpleQueue.foldl1: empty sequence" foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys foldl1' _ (Q [] _) = error "SimpleQueue.foldl1': empty sequence" filter p (Q xs ys) = makeQ (L.filter p xs) (L.filter p ys) partition p (Q xs ys) = (makeQ xsT ysT, makeQ xsF ysF) where (xsT,xsF) = L.partition p xs (ysT,ysF) = L.partition p ys strict s@(Q xs ys) = L.strict xs `seq` L.strict ys `seq` s strictWith f s@(Q xs ys) = L.strictWith f xs `seq` L.strictWith f ys `seq` s -- the remaining functions all use defaults concat = concatUsingFoldr concatMap = concatMapUsingFoldr reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' reduce1 = reduce1UsingLists reduce1' = reduce1'UsingLists copy = copyUsingLists inBounds = inBoundsUsingLookupM lookup = lookupUsingLookupM lookupM = lookupMUsingDrop lookupWithDefault = lookupWithDefaultUsingLookupM update = updateUsingAdjust adjust = adjustUsingLists mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists take = takeUsingLists drop = dropUsingLists splitAt = splitAtDefault subseq = subseqDefault takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview zip = zipUsingLists zip3 = zip3UsingLists zipWith = zipWithUsingLists zipWith3 = zipWith3UsingLists unzip = unzipUsingLists unzip3 = unzip3UsingLists unzipWith = unzipWithUsingLists unzipWith3 = unzipWith3UsingLists -- invariant: -- * front empty only if rear also empty structuralInvariant (Q x y) = not (L.null x) || L.null y -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/JoinList.hs0000644000000000000000000003346613223626550017614 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.JoinList -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Join lists. All running times are as listed in "Data.Edison.Seq" except -- for the following: -- -- * rcons, append @O( 1 )@ -- -- * ltail*, lview @O( 1 )@ when used single-threaded, @O( n )@ otherwise -- -- * lhead* @O( n )@ -- -- * inBounds, lookup @O( n )@ -- -- * copy @O( log i )@ -- -- * concat @O( n1 )@ -- -- * concatMap, (>>=) @O( n * t )@, where @n@ is the length of the input sequence and -- @t@ is the running time of @f@ module Data.Edison.Seq.JoinList ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldlWithIndex, take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified Data.Edison.Seq as S ( Sequence(..) ) import qualified Control.Applicative as App import Data.Edison.Seq.Defaults 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 :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.JoinList" data Seq a = E | L a | A (Seq a) (Seq a) -- invariant: E never a child of A half :: Int -> Int half n = n `div` 2 empty = E singleton = L lcons x E = L x lcons x xs = A (L x) xs rcons x E = L x rcons x xs = A xs (L x) append E ys = ys append xs E = xs append xs ys = A xs ys -- path reversal on lview/ltail lview E = fail "JoinList.lview: empty sequence" lview (L x) = return (x, E) lview (A xs ys) = lvw xs ys where lvw E _ = error "JoinList.lvw: bug" lvw (L x) zs = return (x, zs) lvw (A xs ys) zs = lvw xs (A ys zs) lhead E = error "JoinList.lhead: empty sequence" lhead (L x) = x lhead (A xs _) = lhead xs lheadM E = fail "JoinList.lheadM: empty sequence" lheadM (L x) = return x lheadM (A xs _) = lheadM xs ltail E = error "JoinList.ltail: empty sequence" ltail (L _) = E ltail (A xs ys) = ltl xs ys where ltl E _ = error "JoinList.ltl: bug" ltl (L _) zs = zs ltl (A xs ys) zs = ltl xs (A ys zs) ltailM E = fail "JoinList.ltailM: empty sequence" ltailM (L _) = return E ltailM (A xs ys) = return (ltl xs ys) where ltl E _ = error "JoinList.ltl: bug" ltl (L _) zs = zs ltl (A xs ys) zs = ltl xs (A ys zs) -- Don't want to do plain path reversal on rview/rtail because of expectation -- that left accesses are more common, so we would prefer to keep the left -- spine short. rview E = fail "JoinLis.rview: empty sequence" rview (L x) = return (x, E) rview (A xs ys) = rvw xs ys where rvw xs (A ys (A zs s)) = rvw (A xs (A ys zs)) s rvw xs (A ys (L x)) = return (x, A xs ys) rvw xs (L x) = return (x, xs) rvw _ _ = error "JoinList.rvw: bug" rhead E = error "JoinList.rhead: empty sequence" rhead (L x) = x rhead (A _ ys) = rhead ys rheadM E = fail "JoinList.rheadM: empty sequence" rheadM (L x) = return x rheadM (A _ ys) = rheadM ys rtail E = error "JoinList.rtail: empty sequence" rtail (L _) = E rtail (A xs ys) = rtl xs ys where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s) rtl xs (A ys (L _)) = A xs ys rtl xs (L _) = xs rtl _ _ = error "JoinList.rtl: bug" rtailM E = fail "JoinList.rtailM: empty sequence" rtailM (L _) = return E rtailM (A xs ys) = return (rtl xs ys) where rtl xs (A ys (A zs s)) = A (A xs ys) (rtl zs s) rtl xs (A ys (L _)) = A xs ys rtl xs (L _) = xs rtl _ _ = error "JoinList.rtl: bug" null E = True null _ = False size xs = sz xs (0::Int) where sz E n = n sz (L _) n = n + (1::Int) sz (A xs ys) n = sz xs (sz ys n) reverse (A xs ys) = A (reverse ys) (reverse xs) reverse xs = xs -- L x or E toList xs = tol xs [] where tol E rest = rest tol (L x) rest = x:rest tol (A xs ys) rest = tol xs (tol ys rest) map _ E = E map f (L x) = L (f x) map f (A xs ys) = A (map f xs) (map f ys) fold = foldr fold' = foldr' fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr _ e E = e foldr f e (L x) = f x e foldr f e (A xs ys) = foldr f (foldr f e ys) xs foldr' _ e E = e foldr' f e (L x) = f x $! e foldr' f e (A xs ys) = (foldr' f $! (foldr' f e ys)) xs foldl _ e E = e foldl f e (L x) = f e x foldl f e (A xs ys) = foldl f (foldl f e xs) ys foldl' _ e E = e foldl' f e (L x) = e `seq` f e x foldl' f e (A xs ys) = e `seq` foldl' f (foldl' f e xs) ys foldr1 _ E = error "JoinList.foldr1: empty sequence" foldr1 _ (L x) = x foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs foldr1' _ E = error "JoinLis.foldr1': empty sequence" foldr1' _ (L x) = x foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs foldl1 _ E = error "JoinList.foldl1: empty sequence" foldl1 _ (L x) = x foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys foldl1' _ E = error "JoinList.foldl1': empty sequence" foldl1' _ (L x) = x foldl1' f (A xs ys) = foldl' f (foldl1' f xs) ys copy n x | n <= 0 = E | otherwise = cpy n x where cpy n x -- n > 0 | even n = let xs = cpy (half n) x in A xs xs | n == 1 = L x | otherwise = let xs = cpy (half n) x in A (L x) (A xs xs) strict s@E = s strict s@(L _) = s strict s@(A l r) = strict l `seq` strict r `seq` s strictWith _ s@E = s strictWith f s@(L x) = f x `seq` s strictWith f s@(A l _) = strictWith f l `seq` strictWith f l `seq` s -- invariants: -- * 'E' is never a child of 'A' structuralInvariant E = True structuralInvariant s = check s where check E = False check (L _) = True check (A s1 s2) = check s1 && check s2 concat = concatUsingFoldr reverseOnto = reverseOntoUsingReverse fromList = fromListUsingCons concatMap = concatMapUsingFoldr reducer = reducerUsingReduce1 reducer' = reducer'UsingReduce1' reducel = reducelUsingReduce1 reducel' = reducel'UsingReduce1' reduce1 = reduce1UsingLists reduce1' = reduce1'UsingLists inBounds = inBoundsUsingDrop lookup = lookupUsingDrop lookupM = lookupMUsingDrop lookupWithDefault = lookupWithDefaultUsingDrop update = updateUsingSplitAt adjust = adjustUsingSplitAt mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists take = takeUsingLview drop = dropUsingLtail splitAt = splitAtUsingLview subseq = subseqDefault filter = filterUsingLview partition = partitionUsingFoldr takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview zip = zipUsingLview zip3 = zip3UsingLview zipWith = zipWithUsingLview zipWith3 = zipWith3UsingLview unzip = unzipUsingFoldr unzip3 = unzip3UsingFoldr unzipWith = unzipWithUsingFoldr unzipWith3 = unzipWith3UsingFoldr -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/BankersQueue.hs0000644000000000000000000003561213223626550020446 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.BankersQueue -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- This module implements Banker's Queues. It has the standard running -- times from "Data.Edison.Seq" except for the following: -- -- * rcons, size, inBounds @O( 1 )@ -- -- /References:/ -- -- * Chris Okasaki, /Purely Functional Data Structures/, -- 1998, sections 6.3.2 and 8.4.1. -- -- * Chris Okasaki, \"Simple and efficient purely functional -- queues and deques\", /Journal of Function Programming/ -- 5(4):583-592, October 1995. module Data.Edison.Seq.BankersQueue ( -- * Sequence Type Seq, -- instance of Sequence, Functor, Monad, MonadPlus -- * Sequence operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified 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.Identity import Test.QuickCheck -- signatures for exported functions moduleName :: String empty :: Seq a singleton :: a -> Seq a lcons :: a -> Seq a -> Seq a rcons :: a -> Seq a -> Seq a append :: Seq a -> Seq a -> Seq a lview :: (Monad m) => Seq a -> m (a, Seq a) lhead :: Seq a -> a lheadM :: (Monad m) => Seq a -> m a ltail :: Seq a -> Seq a ltailM :: (Monad m) => Seq a -> m (Seq a) rview :: (Monad m) => Seq a -> m (a, Seq a) rhead :: Seq a -> a rheadM :: (Monad m) => Seq a -> m a rtail :: Seq a -> Seq a rtailM :: (Monad m) => Seq a -> m (Seq a) null :: Seq a -> Bool size :: Seq a -> Int concat :: Seq (Seq a) -> Seq a reverse :: Seq a -> Seq a reverseOnto :: Seq a -> Seq a -> Seq a fromList :: [a] -> Seq a toList :: Seq a -> [a] map :: (a -> b) -> Seq a -> Seq b concatMap :: (a -> Seq b) -> Seq a -> Seq b fold :: (a -> b -> b) -> b -> Seq a -> b fold' :: (a -> b -> b) -> b -> Seq a -> b fold1 :: (a -> a -> a) -> Seq a -> a fold1' :: (a -> a -> a) -> Seq a -> a foldr :: (a -> b -> b) -> b -> Seq a -> b foldl :: (b -> a -> b) -> b -> Seq a -> b foldr1 :: (a -> a -> a) -> Seq a -> a foldl1 :: (a -> a -> a) -> Seq a -> a reducer :: (a -> a -> a) -> a -> Seq a -> a reducel :: (a -> a -> a) -> a -> Seq a -> a reduce1 :: (a -> a -> a) -> Seq a -> a foldr' :: (a -> b -> b) -> b -> Seq a -> b foldl' :: (b -> a -> b) -> b -> Seq a -> b foldr1' :: (a -> a -> a) -> Seq a -> a foldl1' :: (a -> a -> a) -> Seq a -> a reducer' :: (a -> a -> a) -> a -> Seq a -> a reducel' :: (a -> a -> a) -> a -> Seq a -> a reduce1' :: (a -> a -> a) -> Seq a -> a copy :: Int -> a -> Seq a inBounds :: Int -> Seq a -> Bool lookup :: Int -> Seq a -> a lookupM :: (Monad m) => Int -> Seq a -> m a lookupWithDefault :: a -> Int -> Seq a -> a update :: Int -> a -> Seq a -> Seq a adjust :: (a -> a) -> Int -> Seq a -> Seq a mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b take :: Int -> Seq a -> Seq a drop :: Int -> Seq a -> Seq a splitAt :: Int -> Seq a -> (Seq a, Seq a) subseq :: Int -> Int -> Seq a -> Seq a filter :: (a -> Bool) -> Seq a -> Seq a partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) takeWhile :: (a -> Bool) -> Seq a -> Seq a dropWhile :: (a -> Bool) -> Seq a -> Seq a splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) zip :: Seq a -> Seq b -> Seq (a,b) zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d unzip :: Seq (a,b) -> (Seq a, Seq b) unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) strict :: Seq a -> Seq a strictWith :: (a -> b) -> Seq a -> Seq a structuralInvariant :: Seq a -> Bool moduleName = "Data.Edison.Seq.BankersQueue" data Seq a = Q !Int [a] [a] !Int -- invariant: front at least as long as rear structuralInvariant (Q x f r y) = length f == x && length r == y && x >= y -- not exported makeQ :: Int -> [a] -> [a] -> Int -> Seq a makeQ i xs ys j | j > i = Q (i + j) (xs ++ L.reverse ys) [] 0 | otherwise = Q i xs ys j empty = Q 0 [] [] 0 singleton x = Q 1 [x] [] 0 lcons x (Q i xs ys j) = Q (i+1) (x:xs) ys j rcons y (Q i xs ys j) = makeQ i xs (y:ys) (j+1) append (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) = Q (i1 + j1 + i2) (xs1 ++ L.reverseOnto ys1 xs2) ys2 j2 lview (Q _ [] _ _) = fail "BankersQueue.lview: empty sequence" lview (Q i (x:xs) ys j) = return (x, makeQ (i-1) xs ys j) lhead (Q _ [] _ _) = error "BankersQueue.lhead: empty sequence" lhead (Q _ (x:_) _ _) = x lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence" lheadM (Q _ (x:_) _ _) = return x ltail (Q i (_:xs) ys j) = makeQ (i-1) xs ys j ltail _ = error "BankersQueue.ltail: empty sequence" ltailM (Q i (_:xs) ys j) = return (makeQ (i-1) xs ys j) ltailM _ = fail "BankersQueue.ltail: empty sequence" rview (Q i xs (y:ys) j) = return (y, Q i xs ys (j-1)) rview (Q i xs [] _) = case L.rview xs of Nothing -> fail "BankersQueue.rview: empty sequence" Just (x,xs') -> return (x, Q (i-1) xs' [] 0) rhead (Q _ _ (y:_) _) = y rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence" rhead (Q _ xs [] _) = L.rhead xs rheadM (Q _ _ (y:_) _) = return y rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence" rheadM (Q _ xs [] _) = return (L.rhead xs) rtail (Q i xs (_:ys) j) = Q i xs ys (j-1) rtail (Q _ [] [] _) = error "BankersQueue.rtail: empty sequence" rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0 rtailM (Q i xs (_:ys) j) = return (Q i xs ys (j-1)) rtailM (Q _ [] [] _) = fail "BankersQueue.rtailM: empty sequence" rtailM (Q i xs [] _) = return (Q (i-1) (L.rtail xs) [] 0) null (Q i _ _ _) = (i == 0) size (Q i _ _ j) = i + j reverse (Q i xs ys j) = makeQ j ys xs i reverseOnto (Q i1 xs1 ys1 j1) (Q i2 xs2 ys2 j2) = Q (i1 + j1 + i2) (ys1 ++ L.reverseOnto xs1 xs2) ys2 j2 fromList xs = Q (length xs) xs [] 0 toList (Q _ xs ys j) | j == 0 = xs | otherwise = xs ++ L.reverse ys map f (Q i xs ys j) = Q i (L.map f xs) (L.map f ys) j -- local fn on lists revfoldr :: (t -> t1 -> t1) -> t1 -> [t] -> t1 revfoldr _ e [] = e revfoldr f e (x:xs) = revfoldr f (f x e) xs revfoldr' :: (t -> a -> a) -> a -> [t] -> a revfoldr' _ e [] = e revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs -- local fn on lists revfoldl :: (t -> t1 -> t) -> t -> [t1] -> t revfoldl _ e [] = e revfoldl f e (x:xs) = f (revfoldl f e xs) x revfoldl' :: (b -> t -> b) -> b -> [t] -> b revfoldl' _ e [] = e revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs) fold f e (Q _ xs ys _) = L.foldr f (L.foldr f e ys) xs fold' f e (Q _ xs ys _) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs fold1 = fold1UsingFold fold1' = fold1'UsingFold' foldr f e (Q _ xs ys _) = L.foldr f (revfoldr f e ys) xs foldr' f e (Q _ xs ys _) = L.foldr' f (revfoldr' f e ys) xs foldl f e (Q _ xs ys _) = revfoldl f (L.foldl f e xs) ys foldl' f e (Q _ xs ys _) = revfoldl' f (L.foldl' f e xs) ys foldr1 f (Q _ xs (y:ys) _) = L.foldr f (revfoldr f y ys) xs foldr1 f (Q i xs [] _) | i == 0 = error "BankersQueue.foldr1: empty sequence" | otherwise = L.foldr1 f xs foldr1' f (Q _ xs (y:ys) _) = L.foldr' f (revfoldr' f y ys) xs foldr1' f (Q i xs [] _) | i == 0 = error "BankersQueue.foldr1': empty sequence" | otherwise = L.foldr1' f xs foldl1 f (Q _ (x:xs) ys _) = revfoldl f (L.foldl f x xs) ys foldl1 _ _ = error "BankersQueue.foldl1: empty sequence" foldl1' f (Q _ (x:xs) ys _) = revfoldl' f (L.foldl' f x xs) ys foldl1' _ _ = error "BankersQueue.foldl1': empty sequence" copy n x | n < 0 = empty | otherwise = Q n (L.copy n x) [] 0 -- reduce1: given sizes could do more effective job of dividing evenly! lookup idx q = runIdentity (lookupM idx q) lookupM idx (Q i xs ys j) | idx < i = L.lookupM idx xs | otherwise = L.lookupM (j - (idx - i) - 1) ys lookupWithDefault d idx (Q i xs ys j) | idx < i = L.lookupWithDefault d idx xs | otherwise = L.lookupWithDefault d (j - (idx - i) - 1) ys update idx e q@(Q i xs ys j) | idx < i = if idx < 0 then q else Q i (L.update idx e xs) ys j | otherwise = let k' = j - (idx - i) - 1 in if k' < 0 then q else Q i xs (L.update k' e ys) j adjust f idx q@(Q i xs ys j) | idx < i = if idx < 0 then q else Q i (L.adjust f idx xs) ys j | otherwise = let k' = j - (idx - i) - 1 in if k' < 0 then q else Q i xs (L.adjust f k' ys) j {- could do mapWithIndex :: (Int -> a -> b) -> s a -> s b foldrWithIndex :: (Int -> a -> b -> b) -> b -> s a -> b foldlWithIndex :: (b -> Int -> a -> b) -> b -> s a -> b but don't bother for now -} take len q@(Q i xs ys j) = if len <= i then if len <= 0 then empty else Q len (L.take len xs) [] 0 else let len' = len - i in if len' >= j then q else Q i xs (L.drop (j - len') ys) len' drop len q@(Q i xs ys j) = if len <= i then if len <= 0 then q else makeQ (i - len) (L.drop len xs) ys j else let len' = len - i in if len' >= j then empty else Q (j - len') (L.reverse (L.take (j - len') ys)) [] 0 -- could write more efficient version of reverse (take ...) splitAt idx q@(Q i xs ys j) = if idx <= i then if idx <= 0 then (empty, q) else let (xs',xs'') = L.splitAt idx xs in (Q idx xs' [] 0, makeQ (i - idx) xs'' ys j) else let idx' = idx - i in if idx' >= j then (q, empty) else let (ys', ys'') = L.splitAt (j - idx') ys in (Q i xs ys'' idx', Q (j - idx') (L.reverse ys') [] 0) -- could do splitAt followed by reverse more efficiently... strict l@(Q _ xs ys _) = L.strict xs `seq` L.strict ys `seq` l strictWith f l@(Q _ xs ys _) = L.strictWith f xs `seq` L.strictWith f ys `seq` l -- the remaining functions all use defaults concat = concatUsingFoldr concatMap = concatMapUsingFoldr reducer = reducerUsingReduce1 reducel = reducelUsingReduce1 reduce1 = reduce1UsingLists reducer' = reducer'UsingReduce1' reducel' = reducel'UsingReduce1' reduce1' = reduce1'UsingLists inBounds = inBoundsUsingSize mapWithIndex = mapWithIndexUsingLists foldrWithIndex = foldrWithIndexUsingLists foldrWithIndex' = foldrWithIndex'UsingLists foldlWithIndex = foldlWithIndexUsingLists foldlWithIndex' = foldlWithIndex'UsingLists subseq = subseqDefault filter = filterUsingLists partition = partitionUsingLists takeWhile = takeWhileUsingLview dropWhile = dropWhileUsingLview splitWhile = splitWhileUsingLview zip = zipUsingLists zip3 = zip3UsingLists zipWith = zipWithUsingLists zipWith3 = zipWith3UsingLists unzip = unzipUsingLists unzip3 = unzip3UsingLists unzipWith = unzipWithUsingLists unzipWith3 = unzipWith3UsingLists -- instances instance S.Sequence Seq where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Functor Seq where fmap = map instance 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Seq/RevSeq.hs0000644000000000000000000003774213223626550017267 0ustar0000000000000000-- | -- Module : Data.Edison.Seq.RevSeq -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- This module defines a sequence adaptor @Rev s@. -- If @s@ is a sequence type constructor, then @Rev s@ -- is a sequence type constructor that is identical to @s@, -- except that it is kept in the opposite order. -- Also keeps explicit track of the size of the sequence, -- similar to the @Sized@ adaptor in "Data.Edison.Seq.SizedSeq". -- -- This module is most useful when s is a sequence type -- that offers fast access to the front but slow access -- to the rear, and your application needs the opposite -- (i.e., fast access to the rear but slow access to the -- front). -- -- All time complexities are determined by the underlying -- sequence, except that the complexities for accessing -- the left and right sides of the sequence are exchanged, -- and size becomes @O( 1 )@. module Data.Edison.Seq.RevSeq ( -- * Rev Sequence Type Rev, -- Rev s instance of Sequence, Functor, Monad, MonadPlus -- * Sequence Operations empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, lheadM,ltailM,rheadM,rtailM, null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', reducer,reducer',reducel,reducel',reduce1,reduce1', copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, strict, strictWith, -- * Unit testing structuralInvariant, -- * Documentation moduleName,instanceName, -- * Other supported operations fromSeq,toSeq ) where import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, filter,takeWhile,dropWhile,lookup,take,drop,splitAt, zip,zip3,zipWith,zipWith3,unzip,unzip3,null) import qualified 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 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, Monad m) => Rev s a -> m (a, Rev s a) lhead :: S.Sequence s => Rev s a -> a lheadM :: (S.Sequence s, Monad m) => Rev s a -> m a ltail :: S.Sequence s => Rev s a -> Rev s a ltailM :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a) rview :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a) rhead :: S.Sequence s => Rev s a -> a rheadM :: (S.Sequence s, Monad m) => Rev s a -> m a rtail :: S.Sequence s => Rev s a -> Rev s a rtailM :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a) null :: S.Sequence s => Rev s a -> Bool size :: S.Sequence s => Rev s a -> Int concat :: S.Sequence s => Rev s (Rev s a) -> Rev s a reverse :: S.Sequence s => Rev s a -> Rev s a reverseOnto :: S.Sequence s => Rev s a -> Rev s a -> Rev s a fromList :: S.Sequence s => [a] -> Rev s a toList :: S.Sequence s => Rev s a -> [a] map :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b concatMap :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b fold :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b fold' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b fold1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a fold1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a foldr :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b foldl :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b foldr1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a foldl1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a reducer :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a reducel :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a reduce1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a foldr' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b foldl' :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b foldr1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a foldl1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a reducer' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a reducel' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a reduce1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a copy :: S.Sequence s => Int -> a -> Rev s a inBounds :: S.Sequence s => Int -> Rev s a -> Bool lookup :: S.Sequence s => Int -> Rev s a -> a lookupM :: (S.Sequence s, Monad m) => Int -> Rev s a -> m a lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a update :: S.Sequence s => Int -> a -> Rev s a -> Rev s a adjust :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b take :: S.Sequence s => Int -> Rev s a -> Rev s a drop :: S.Sequence s => Int -> Rev s a -> Rev s a splitAt :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a) subseq :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a filter :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a partition :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a) takeWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a dropWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a splitWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a) zip :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b) zip3 :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c) zipWith :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d unzip :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b) unzip3 :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c) unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c) unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d) strict :: S.Sequence s => Rev s a -> Rev s a strictWith :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a structuralInvariant :: S.Sequence s => Rev s a -> Bool -- bonus functions, not in Sequence signature fromSeq :: S.Sequence s => s a -> Rev s a toSeq :: S.Sequence s => Rev s a -> s a moduleName = "Data.Edison.Seq.RevSeq" instanceName (N _ s) = "RevSeq(" ++ S.instanceName s ++ ")" data Rev s a = N !Int (s a) -- The Int is the size minus one. The "minus one" makes indexing -- calculations easier. fromSeq xs = N (S.size xs - 1) xs toSeq (N _ xs) = xs empty = N (-1) S.empty singleton x = N 0 (S.singleton x) lcons x (N m xs) = N (m+1) (S.rcons x xs) rcons x (N m xs) = N (m+1) (S.lcons x xs) append (N m xs) (N n ys) = N (m+n+1) (S.append ys xs) lview (N m xs) = case S.rview xs of Nothing -> fail "RevSeq.lview: empty sequence" Just (x,xs) -> return (x, N (m-1) xs) lhead (N _ xs) = S.rhead xs lheadM (N _ xs) = S.rheadM xs ltail (N (-1) _) = error "RevSeq.ltail: empty sequence" ltail (N m xs) = N (m-1) (S.rtail xs) ltailM (N (-1) _) = fail "RevSeq.ltailM: empty sequence" ltailM (N m xs) = return (N (m-1) (S.rtail xs)) rview (N m xs) = case S.lview xs of Nothing -> fail "RevSeq.rview: empty sequence" Just (x,xs) -> return (x, N (m-1) xs) rhead (N _ xs) = S.lhead xs rheadM (N _ xs) = S.lheadM xs rtail (N (-1) _) = error "RevSeq.rtail: empty sequence" rtail (N m xs) = N (m-1) (S.ltail xs) rtailM (N (-1) _) = fail "RevSeq.rtailM: empty sequence" rtailM (N m xs) = return (N (m-1) (S.ltail xs)) null (N m _) = m == -1 size (N m _) = m+1 concat (N _ xss) = fromSeq (S.concat (S.map toSeq xss)) reverse (N m xs) = N m (S.reverse xs) reverseOnto (N m xs) (N n ys) = N (m+n+1) (S.append ys (S.reverse xs)) fromList = fromSeq . S.fromList . L.reverse toList (N _ xs) = S.foldl (flip (:)) [] xs map f (N m xs) = N m (S.map f xs) concatMap = concatMapUsingFoldr -- only function that uses a default fold f e (N _ xs) = S.fold f e xs fold' f e (N _ xs) = S.fold' f e xs fold1 f (N _ xs) = S.fold1 f xs fold1' f (N _ xs) = S.fold1' f xs foldr f e (N _ xs) = S.foldl (flip f) e xs foldr' f e (N _ xs) = S.foldl' (flip f) e xs foldl f e (N _ xs) = S.foldr (flip f) e xs foldl' f e (N _ xs) = S.foldr' (flip f) e xs foldr1 f (N _ xs) = S.foldl1 (flip f) xs foldr1' f (N _ xs) = S.foldl1' (flip f) xs foldl1 f (N _ xs) = S.foldr1 (flip f) xs foldl1' f (N _ xs) = S.foldr1' (flip f) xs reducer f e (N _ xs) = S.reducel (flip f) e xs reducer' f e (N _ xs) = S.reducel' (flip f) e xs reducel f e (N _ xs) = S.reducer (flip f) e xs reducel' f e (N _ xs) = S.reducer' (flip f) e xs reduce1 f (N _ xs) = S.reduce1 (flip f) xs reduce1' f (N _ xs) = S.reduce1' (flip f) xs copy n x | n <= 0 = empty | otherwise = N (n-1) (S.copy n x) inBounds i (N m _) = (i >= 0) && (i <= m) lookup i (N m xs) = S.lookup (m-i) xs lookupM i (N m xs) = S.lookupM (m-i) xs lookupWithDefault d i (N m xs) = S.lookupWithDefault d (m-i) xs update i x (N m xs) = N m (S.update (m-i) x xs) adjust f i (N m xs) = N m (S.adjust f (m-i) xs) mapWithIndex f (N m xs) = N m (S.mapWithIndex (f . (m-)) xs) foldrWithIndex f e (N m xs) = S.foldlWithIndex f' e xs where f' xs i x = f (m-i) x xs foldrWithIndex' f e (N m xs) = S.foldlWithIndex' f' e xs where f' xs i x = f (m-i) x xs foldlWithIndex f e (N m xs) = S.foldrWithIndex f' e xs where f' i x xs = f xs (m-i) x foldlWithIndex' f e (N m xs) = S.foldrWithIndex' f' e xs where f' i x xs = f xs (m-i) x take i original@(N m xs) | i <= 0 = empty | i > m = original | otherwise = N (i-1) (S.drop (m-i+1) xs) drop i original@(N m xs) | i <= 0 = original | i > m = empty | otherwise = N (m-i) (S.take (m-i+1) xs) splitAt i original@(N m xs) | i <= 0 = (empty, original) | i > m = (original, empty) | otherwise = let (ys,zs) = S.splitAt (m-i+1) xs in (N (i-1) zs, N (m-i) ys) subseq i len original@(N m xs) | i <= 0 = take len original | i > m || len <= 0 = empty | i+len > m = N (m-i) (S.take (m-i+1) xs) | otherwise = N (len-1) (S.subseq (m-i-len+1) len xs) filter p = fromSeq . S.filter p . toSeq partition p (N m xs) = (N (k-1) ys, N (m-k) zs) where (ys,zs) = S.partition p xs k = S.size ys takeWhile p = fromSeq . S.reverse . S.takeWhile p . S.reverse . toSeq dropWhile p = fromSeq . S.reverse . S.dropWhile p . S.reverse . toSeq splitWhile p (N m xs) = (N (k-1) (S.reverse ys), N (m-k) (S.reverse zs)) where (ys,zs) = S.splitWhile p (S.reverse xs) k = S.size ys zip (N m xs) (N n ys) | m < n = N m (S.zip xs (S.drop (n-m) ys)) | m > n = N n (S.zip (S.drop (m-n) xs) ys) | otherwise = N m (S.zip xs ys) zip3 (N l xs) (N m ys) (N n zs) = N k (S.zip3 xs' ys' zs') where k = min l (min m n) xs' = if l == k then xs else S.drop (l-k) xs ys' = if m == k then ys else S.drop (m-k) ys zs' = if n == k then zs else S.drop (n-k) zs zipWith f (N m xs) (N n ys) | m < n = N m (S.zipWith f xs (S.drop (n-m) ys)) | m > n = N n (S.zipWith f (S.drop (m-n) xs) ys) | otherwise = N m (S.zipWith f xs ys) zipWith3 f (N l xs) (N m ys) (N n zs) = N k (S.zipWith3 f xs' ys' zs') where k = min l (min m n) xs' = if l == k then xs else S.drop (l-k) xs ys' = if m == k then ys else S.drop (m-k) ys zs' = if n == k then zs else S.drop (n-k) zs unzip (N m xys) = (N m xs, N m ys) where (xs,ys) = S.unzip xys unzip3 (N m xyzs) = (N m xs, N m ys, N m zs) where (xs,ys,zs) = S.unzip3 xyzs unzipWith f g (N m xys) = (N m xs, N m ys) where (xs,ys) = S.unzipWith f g xys unzipWith3 f g h (N m xyzs) = (N m xs, N m ys, N m zs) where (xs,ys,zs) = S.unzipWith3 f g h xyzs strict s@(N _ s') = S.strict s' `seq` s strictWith f s@(N _ s') = S.strictWith f s' `seq` s structuralInvariant (N i s) = i == ((S.size s) - 1) -- instances instance S.Sequence s => S.Sequence (Rev s) where {lcons = lcons; rcons = rcons; lview = lview; lhead = lhead; ltail = ltail; lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; rview = rview; rhead = rhead; rtail = rtail; null = null; size = size; concat = concat; reverse = reverse; reverseOnto = reverseOnto; fromList = fromList; toList = toList; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; reducer = reducer; reducer' = reducer'; reducel = reducel; reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; copy = copy; inBounds = inBounds; lookup = lookup; lookupM = lookupM; lookupWithDefault = lookupWithDefault; update = update; adjust = adjust; mapWithIndex = mapWithIndex; foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; take = take; drop = drop; splitAt = splitAt; subseq = subseq; filter = filter; partition = partition; takeWhile = takeWhile; dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; strict = strict; strictWith = strictWith; structuralInvariant = structuralInvariant; instanceName = instanceName} instance S.Sequence s => Functor (Rev s) where fmap = map instance S.Sequence s => 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.<>) EdisonCore-1.3.2.1/src/Data/Edison/Coll/0000755000000000000000000000000013223626550015652 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/Edison/Coll/SkewHeap.hs0000644000000000000000000003460613223626550017726 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.SkewHeap -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Skew heaps. -- -- /References:/ -- -- * Daniel Sleator and Robert Tarjan. \"Self-Adjusting Heaps\". -- /SIAM Journal on Computing/, 15(1):52-69, February 1986. module Data.Edison.Coll.SkewHeap ( -- * Type of skew heaps Heap, -- instance of Coll/CollX, OrdColl/OrdCollX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', fold1, fold1', filter, partition, strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq, unsafeMapMonotonic, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Data.Edison.Coll as C import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.Monoid import Data.Semigroup as SG import Control.Monad import Test.QuickCheck moduleName :: String moduleName = "Data.Edison.Coll.SkewHeap" data Heap a = E | T a (Heap a) (Heap a) -- invariants: -- * Heap order structuralInvariant :: Ord a => Heap a -> Bool structuralInvariant E = True structuralInvariant t@(T x _ _) = isMin x t where isMin _ E = True isMin x (T y l r) = x <= y && isMin y l && isMin y r {- For delete,deleteAll,filter,partition: could compute fringe and reduce rather that rebuilding with union at every deleted node -} empty :: Ord a => Heap a empty = E singleton :: Ord a => a -> Heap a singleton x = T x E E insert :: Ord a => a -> Heap a -> Heap a insert x E = T x E E insert x h@(T y a b) | x <= y = T x h E | otherwise = T y (insert x b) a union :: Ord a => Heap a -> Heap a -> Heap a union E h = h union h@(T x a b) h' = union' h x a b h' where union' h _ _ _ E = h union' hx x a b hy@(T y c d) | x <= y = T x (union' hy y c d b) a | otherwise = T y (union' hx x a b d) c delete :: Ord a => a -> Heap a -> Heap a delete x h = case del h of Just h' -> h' Nothing -> h where del (T y a b) = case compare x y of LT -> Nothing EQ -> Just (union a b) GT -> case del b of Just b' -> Just (T y a b') Nothing -> case del a of Just a' -> Just (T y a' b) Nothing -> Nothing del E = Nothing deleteAll :: Ord a => a -> Heap a -> Heap a deleteAll x h@(T y a b) = case compare x y of LT -> h EQ -> union (deleteAll x a) (deleteAll x b) GT -> T y (deleteAll x a) (deleteAll x b) deleteAll _ E = E null :: Ord a => Heap a -> Bool null E = True null _ = False size :: Ord a => Heap a -> Int size h = sz h 0 where sz E i = i sz (T _ a b) i = sz a (sz b (i + 1)) member :: Ord a => a -> Heap a -> Bool member _ E = False member x (T y a b) = case compare x y of LT -> False EQ -> True GT -> member x b || member x a count :: Ord a => a -> Heap a -> Int count _ E = 0 count x (T y a b) = case compare x y of LT -> 0 EQ -> 1 + count x b + count x a GT -> count x b + count x a toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a toSeq h = tol h S.empty where tol E rest = rest tol (T x a b) rest = S.lcons x (tol b (tol a rest)) lookupM :: (Ord a, Monad m) => a -> Heap a -> m a lookupM _ E = fail "SkewHeap.lookupM: XXX" lookupM x (T y a b) = case compare x y of LT -> fail "SkewHeap.lookupM: XXX" EQ -> return y GT -> case lookupM x b `mplus` lookupM x a of Nothing -> fail "SkewHeap.lookupM: XXX" Just x -> return x lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a lookupAll x h = look h S.empty where look E ys = ys look (T y a b) ys = case compare x y of LT -> ys EQ -> S.lcons y (look b (look a ys)) GT -> look b (look a ys) fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b fold _ e E = e fold f e (T x a b) = f x (fold f (fold f e a) b) fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b fold' _ e E = e fold' f e (T x a b) = e `seq` f x $! (fold' f (fold' f e a) b) fold1 :: Ord a => (a -> a -> a) -> Heap a -> a fold1 _ E = error "SkewHeap.fold1: empty collection" fold1 f (T x a b) = fold f (fold f x a) b fold1' :: Ord a => (a -> a -> a) -> Heap a -> a fold1' _ E = error "SkewHeap.fold1': empty collection" fold1' f (T x a b) = fold' f (fold' f x a) b filter :: Ord a => (a -> Bool) -> Heap a -> Heap a filter _ E = E filter p (T x a b) | p x = T x (filter p a) (filter p b) | otherwise = union (filter p a) (filter p b) partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) partition _ E = (E, E) partition p (T x a b) | p x = (T x a' b', union a'' b'') | otherwise = (union a' b', T x a'' b'') where (a', a'') = partition p a (b', b'') = partition p b deleteMin :: Ord a => Heap a -> Heap a deleteMin E = E deleteMin (T _ a b) = union a b deleteMax :: Ord a => Heap a -> Heap a deleteMax h = case maxView h of Nothing -> E Just (_,h') -> h' unsafeInsertMin :: Ord a => a -> Heap a -> Heap a unsafeInsertMin x h = T x h E unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a unsafeAppend E h = h unsafeAppend (T x a b) h = T x (unsafeAppend b h) a filterLT :: Ord a => a -> Heap a -> Heap a filterLT y (T x a b) | x < y = T x (filterLT y a) (filterLT y b) filterLT _ _ = E filterLE :: Ord a => a -> Heap a -> Heap a filterLE y (T x a b) | x <= y = T x (filterLE y a) (filterLE y b) filterLE _ _ = E filterGT :: Ord a => a -> Heap a -> Heap a filterGT y h = C.unionList (collect h []) where collect E hs = hs collect h@(T x a b) hs | x > y = h : hs | otherwise = collect a (collect b hs) filterGE :: Ord a => a -> Heap a -> Heap a filterGE y h = C.unionList (collect h []) where collect E hs = hs collect h@(T x a b) hs | x >= y = h : hs | otherwise = collect b (collect a hs) partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GE y h = (h', C.unionList hs) where (h', hs) = collect h [] collect E hs = (E, hs) collect h@(T x a b) hs | x >= y = (E, h:hs) | otherwise = let (a', hs') = collect a hs (b', hs'') = collect b hs' in (T x a' b', hs'') partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLE_GT y h = (h', C.unionList hs) where (h', hs) = collect h [] collect E hs = (E, hs) collect h@(T x a b) hs | x > y = (E, h:hs) | otherwise = let (a', hs') = collect a hs (b', hs'') = collect b hs' in (T x a' b', hs'') partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GT y h = (h', C.unionList hs) where (h', hs) = collect h [] collect E hs = (E, hs) collect h@(T x a b) hs = case compare x y of GT -> (E, h:hs) EQ -> let (a', hs') = collect a hs (b', hs'') = collect b hs' in (union a' b', hs'') LT -> let (a', hs') = collect a hs (b', hs'') = collect b hs' in (T x a' b', hs'') minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a) minView E = fail "SkewHeap.minView: empty heap" minView (T x a b) = return (x, union a b) minElem :: Ord a => Heap a -> a minElem E = error "SkewHeap.minElem: empty collection" minElem (T x _ _) = x maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a) maxView E = fail "SkewHeap.maxView: empty heap" maxView (T x E E) = return (x, E) maxView (T x a E) = return (y, T x a' E) where Just (y, a') = maxView a maxView (T x E a) = return (y, T x a' E) where Just (y, a') = maxView a maxView (T x a b) | y >= z = return (y, T x a' b) | otherwise = return (z, T x a b') where Just (y, a') = maxView a Just (z, b') = maxView b -- warning: maxView and maxElem may disagree if root is equal to max! maxElem :: Ord a => Heap a -> a maxElem E = error "SkewHeap.maxElem: empty collection" maxElem (T x E E) = x maxElem (T _ a E) = maxElem a maxElem (T _ E a) = maxElem a maxElem (T _ a b) = findMax b (findLeaf a) where findMax E m = m findMax (T x E E) m | m >= x = m | otherwise = x findMax (T _ a E) m = findMax a m findMax (T _ E a) m = findMax a m findMax (T _ a b) m = findMax a (findMax b m) findLeaf E = error "SkewHeap.maxElem: bug" findLeaf (T x E E) = x findLeaf (T _ a E) = findLeaf a findLeaf (T _ E a) = findLeaf a findLeaf (T _ a b) = findMax b (findLeaf a) foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldr _ e E = e foldr f e (T x a b) = f x (foldr f e (union a b)) foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldr' _ e E = e foldr' f e (T x a b) = e `seq` f x $! (foldr' f e (union a b)) foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldl _ e E = e foldl f e (T x a b) = foldl f (f e x) (union a b) foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldl' _ e E = e foldl' f e (T x a b) = e `seq` foldl' f (f e x) (union a b) foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a foldr1 _ E = error "SkewHeap.foldr1: empty collection" foldr1 _ (T x E E) = x foldr1 f (T x a b) = f x (foldr1 f (union a b)) foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a foldr1' _ E = error "SkewHeap.foldr1': empty collection" foldr1' _ (T x E E) = x foldr1' f (T x a b) = f x $! (foldr1' f (union a b)) foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a foldl1 _ E = error "SkewHeap.foldl1: empty collection" foldl1 f (T x a b) = foldl f x (union a b) foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a foldl1' _ E = error "SkewHeap.foldl1': empty collection" foldl1' f (T x a b) = foldl' f x (union a b) {- ???? -} unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a unsafeMapMonotonic _ E = E unsafeMapMonotonic f (T x a b) = T (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b) strict :: Heap a -> Heap a strict h@E = h strict h@(T _ l r) = strict l `seq` strict r `seq` h strictWith :: (a -> b) -> Heap a -> Heap a strictWith _ h@E = h strictWith f h@(T x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h -- the remaining functions all use default definitions fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a fromSeq = fromSeqUsingUnionSeq insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a insertSeq = insertSeqUsingUnion unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a unionSeq = unionSeqUsingReduce deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a deleteSeq = deleteSeqUsingDelete lookup :: Ord a => a -> Heap a -> a lookup = lookupUsingLookupM lookupWithDefault :: Ord a => a -> a -> Heap a -> a lookupWithDefault = lookupWithDefaultUsingLookupM unsafeInsertMax :: Ord a => a -> Heap a -> Heap a unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a toOrdSeq = toOrdSeqUsingFoldr -- instance declarations instance Ord a => C.CollX (Heap a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Ord a => C.OrdCollX (Heap a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance Ord a => C.Coll (Heap a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance Ord a => C.OrdColl (Heap a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = fold1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} instance Ord a => Eq (Heap a) where xs == ys = C.toOrdList xs == C.toOrdList ys instance (Ord a, Show a) => Show (Heap a) where showsPrec = showsPrecUsingToList instance (Ord a, Read a) => Read (Heap a) where readsPrec = readsPrecUsingFromList instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where arbitrary = sized (\n -> arbTree n) where arbTree 0 = return E arbTree n = frequency [(1, return E), (4, liftM3 sift arbitrary (arbTree (n `div` 2)) (arbTree (n `div` 4)))] sift x (T y a b) E | y < x = T y (sift x a b) E sift x E (T y a b) | y < x = T y E (sift x a b) sift x s@(T y a b) t@(T z c d) | y < x && y <= z = T y (sift x a b) t | z < x = T z s (sift x c d) sift x a b = T x a b instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where coarbitrary E = variant 0 coarbitrary (T x a b) = variant 1 . coarbitrary x . coarbitrary a . coarbitrary b instance (Ord a) => 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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/UnbalancedSet.hs0000644000000000000000000003374413223626550020731 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.UnbalancedSet -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Sets implemented as unbalanced binary search trees. module Data.Edison.Coll.UnbalancedSet ( -- * Set type Set, -- instance of Coll/CollX, OrdColl/OrdCollX, Set/SetX, OrdSet/OrdSetX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold', fold1,fold1',filter,partition,strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic, -- * SetX operations intersection,difference,symmetricDifference,properSubset,subset, -- * Set operations fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith, unionSeqWith,intersectionWith, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Prelude import qualified Data.Edison.Coll as C import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.Monoid import 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,Monad m) => a -> Set a -> m a lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a lookupWithDefault :: Ord a => a -> a -> Set a -> a fold :: (a -> b -> b) -> b -> Set a -> b fold1 :: (a -> a -> a) -> Set a -> a fold' :: (a -> b -> b) -> b -> Set a -> b fold1' :: (a -> a -> a) -> Set a -> a filter :: Ord a => (a -> Bool) -> Set a -> Set a partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a) strictWith :: (a -> b) -> Set a -> Set a deleteMin :: Ord a => Set a -> Set a deleteMax :: Ord a => Set a -> Set a unsafeInsertMin :: Ord a => a -> Set a -> Set a unsafeInsertMax :: Ord a => a -> Set a -> Set a unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a unsafeAppend :: Ord a => Set a -> Set a -> Set a filterLT :: Ord a => a -> Set a -> Set a filterLE :: Ord a => a -> Set a -> Set a filterGT :: Ord a => a -> Set a -> Set a filterGE :: Ord a => a -> Set a -> Set a partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a) partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a) partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a) minView :: (Monad m) => Set a -> m (a, Set a) minElem :: Set a -> a maxView :: (Monad m) => Set a -> m (a, Set a) maxElem :: Set a -> a foldr :: (a -> b -> b) -> b -> Set a -> b foldl :: (b -> a -> b) -> b -> Set a -> b foldr1 :: (a -> a -> a) -> Set a -> a foldl1 :: (a -> a -> a) -> Set a -> a foldr' :: (a -> b -> b) -> b -> Set a -> b foldl' :: (b -> a -> b) -> b -> Set a -> b foldr1' :: (a -> a -> a) -> Set a -> a foldl1' :: (a -> a -> a) -> Set a -> a toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a intersection :: Ord a => Set a -> Set a -> Set a difference :: Ord a => Set a -> Set a -> Set a symmetricDifference :: Ord a => Set a -> Set a -> Set a properSubset :: Ord a => Set a -> Set a -> Bool subset :: Ord a => Set a -> Set a -> Bool fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a unionl :: Ord a => Set a -> Set a -> Set a unionr :: Ord a => Set a -> Set a -> Set a unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a moduleName = "Data.Edison.Coll.UnbalancedSet" data Set a = E | T (Set a) a (Set a) -- invariants: -- * Binary Search Tree order structuralInvariant :: Ord a => Set a -> Bool structuralInvariant t = bounded Nothing Nothing t where bounded _ _ E = True bounded lo hi (T l x r) = cmp_l lo x && cmp_r x hi && bounded lo (Just x) l && bounded (Just x) hi r cmp_l Nothing _ = True cmp_l (Just x) y = x < y cmp_r _ Nothing = True cmp_r x (Just y) = x < y empty = E singleton x = T E x E insertWith c x = ins where ins E = T E x E ins (T a y b) = case compare x y of LT -> T (ins a) y b EQ -> T a (c x y) b GT -> T a y (ins b) delete _ E = E delete x (T a y b) = case compare x y of LT -> T (delete x a) y b EQ -> unsafeAppend a b GT -> T a y (delete x b) null E = True null (T _ _ _) = False size t = sz t 0 where sz E i = i sz (T a _ b) i = sz a (sz b (i+1)) member _ E = False member x (T a y b) = case compare x y of LT -> member x a EQ -> True GT -> member x b lookupM _ E = fail "UnbalancedSet.lookupM: XXX" lookupM x (T a y b) = case compare x y of LT -> lookupM x a EQ -> return y GT -> lookupM x b fold _ e E = e fold f e (T a x b) = f x (fold f (fold f e a) b) fold' _ e E = e fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b) fold1 _ E = error "UnbalancedSet.fold1: empty collection" fold1 f (T a x b) = fold f (fold f x a) b fold1' _ E = error "UnbalancedSet.fold1': empty collection" fold1' f (T a x b) = fold' f (fold' f x a) b deleteMin E = E deleteMin (T E _ b) = b deleteMin (T a x b) = T (deleteMin a) x b deleteMax E = E deleteMax (T a _ E) = a deleteMax (T a x b) = T a x (deleteMax b) unsafeInsertMin x t = T E x t unsafeInsertMax x t = T t x E unsafeFromOrdSeq xs = fst (ins xs (S.size xs)) where ins ys 0 = (E,ys) ins ys n = let m = n `div` 2 (a,ys') = ins ys m Just (y,ys'') = S.lview ys' (b,ys''') = ins ys'' (n - m - 1) in (T a y b,ys''') unsafeAppend a b = case minView b of Nothing -> a Just (x,b') -> T a x b' filterLT _ E = E filterLT y (T a x b) = case compare x y of LT -> T a x (filterLT y b) EQ -> a GT -> filterLT y a filterLE _ E = E filterLE y (T a x b) = case compare x y of LT -> T a x (filterLE y b) EQ -> T a x E GT -> filterLE y a filterGT _ E = E filterGT y (T a x b) = case compare x y of LT -> filterGT y b EQ -> b GT -> T (filterGT y a) x b filterGE _ E = E filterGE y (T a x b) = case compare x y of LT -> filterGE y b EQ -> T E x b GT -> T (filterGE y a) x b partitionLT_GE _ E = (E,E) partitionLT_GE y (T a x b) = case compare x y of LT -> (T a x b0,b1) where (b0,b1) = partitionLT_GE y b EQ -> (a,T E x b) GT -> (a0,T a1 x b) where (a0,a1) = partitionLT_GE y a partitionLE_GT _ E = (E,E) partitionLE_GT y (T a x b) = case compare x y of LT -> (T a x b0,b1) where (b0,b1) = partitionLE_GT y b EQ -> (T a x E,b) GT -> (a0,T a1 x b) where (a0,a1) = partitionLE_GT y a partitionLT_GT _ E = (E,E) partitionLT_GT y (T a x b) = case compare x y of LT -> (T a x b0,b1) where (b0,b1) = partitionLT_GT y b EQ -> (a,b) GT -> (a0,T a1 x b) where (a0,a1) = partitionLT_GT y a minView E = fail "UnbalancedSet.minView: empty collection" minView (T E x b) = return (x, b) minView (T a x b) = return (y, T a' x b) where Just (y,a') = minView a minElem E = error "UnbalancedSet.minElem: empty collection" minElem (T E x _) = x minElem (T a _ _) = minElem a maxView E = fail "UnbalancedSet.maxView: empty collection" maxView (T a x E) = return (x, a) maxView (T a x b) = return (y, T a x b') where Just (y, b') = maxView b maxElem E = error "UnbalancedSet.maxElem: empty collection" maxElem (T _ x E) = x maxElem (T _ _ b) = maxElem b foldr _ e E = e foldr f e (T a x b) = foldr f (f x (foldr f e b)) a foldr' _ e E = e foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a foldl _ e E = e foldl f e (T a x b) = foldl f (f (foldl f e a) x) b foldl' _ e E = e foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b foldr1 _ E = error "UnbalancedSet.foldr1: empty collection" foldr1 f (T a x E) = foldr f x a foldr1 f (T a x b) = foldr f (f x (foldr1 f b)) a foldr1' _ E = error "UnbalancedSet.foldr1': empty collection" foldr1' f (T a x E) = foldr' f x a foldr1' f (T a x b) = foldr' f (f x $! (foldr1' f b)) a foldl1 _ E = error "UnbalancedSet.foldl1: empty collection" foldl1 f (T E x b) = foldl f x b foldl1 f (T a x b) = foldl f (f (foldl1 f a) x) b foldl1' _ E = error "UnbalancedSet.foldl1': empty collection" foldl1' f (T E x b) = foldl' f x b foldl1' f (T a x b) = foldl' f ((f $! (foldl1' f a)) x) b unsafeMapMonotonic _ E = E unsafeMapMonotonic f (T a x b) = T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b) strict s@E = s strict s@(T l _ r) = strict l `seq` strict r `seq` s strictWith _ s@E = s strictWith f s@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` s -- the remaining functions all use default definitions fromSeq = fromSeqUsingUnionSeq insert = insertUsingInsertWith insertSeq = insertSeqUsingUnion union = unionUsingUnionWith unionSeq = unionSeqUsingReduce deleteAll = delete deleteSeq = deleteSeqUsingDelete count = countUsingMember toSeq = toSeqUsingFold lookup = lookupUsingLookupM lookupAll = lookupAllUsingLookupM lookupWithDefault = lookupWithDefaultUsingLookupM filter = filterUsingOrdLists partition = partitionUsingOrdLists toOrdSeq = toOrdSeqUsingFoldr intersection = intersectionUsingIntersectionWith difference = differenceUsingOrdLists symmetricDifference = symmetricDifferenceUsingDifference properSubset = properSubsetUsingOrdLists subset = subsetUsingOrdLists fromSeqWith = fromSeqWithUsingInsertWith insertSeqWith = insertSeqWithUsingInsertWith unionl = unionlUsingUnionWith unionr = unionrUsingUnionWith unionWith = unionWithUsingOrdLists unionSeqWith = unionSeqWithUsingReducer intersectionWith = intersectionWithUsingOrdLists -- instance declarations instance Ord a => C.CollX (Set a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Ord a => C.OrdCollX (Set a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance Ord a => C.Coll (Set a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance Ord a => C.OrdColl (Set a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} instance Ord a => C.SetX (Set a) a where {intersection = intersection; difference = difference; symmetricDifference = symmetricDifference; properSubset = properSubset; subset = subset} instance Ord a => C.Set (Set a) a where {fromSeqWith = fromSeqWith; insertWith = insertWith; insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; unionWith = unionWith; unionSeqWith = unionSeqWith; intersectionWith = intersectionWith} instance Ord a => C.OrdSetX (Set a) a instance Ord a => C.OrdSet (Set a) a instance Ord a => Eq (Set a) where xs == ys = C.toOrdList xs == C.toOrdList ys instance (Ord a, Show a) => Show (Set a) where showsPrec = showsPrecUsingToList instance (Ord a, Read a) => Read (Set a) where readsPrec = readsPrecUsingFromList instance (Ord a, Arbitrary a) => Arbitrary (Set a) where arbitrary = do (xs::[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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/LazyPairingHeap.hs0000644000000000000000000004336113223626550021244 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.LazyPairingHeap -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Lazy Paring Heaps -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. -- Section 6.5. module Data.Edison.Coll.LazyPairingHeap ( -- * Type of pairing heaps Heap, -- instance of Coll/CollX, OrdColl/OrdCollX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', fold1, fold1', filter, partition, strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq, unsafeMapMonotonic, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..), toOrdList ) import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.List (sort) import Data.Monoid import Data.Semigroup as SG import Control.Monad import Test.QuickCheck moduleName :: String moduleName = "Data.Edison.Coll.LazyPairingHeap" data Heap a = E | H1 a (Heap a) | H2 a !(Heap a) (Heap a) -- Invariants: -- * left child of H2 not empty structuralInvariant :: Heap a -> Bool structuralInvariant E = True structuralInvariant (H1 _ h) = structuralInvariant h structuralInvariant (H2 _ E _) = False structuralInvariant (H2 _ l r) = structuralInvariant l && structuralInvariant r -- second arg is not empty -- not used! -- link E h = h -- link (H1 x b) a = H2 x a b -- link (H2 x a b) a' = H1 x (union (union a a') b) makeH2 :: a -> Heap a -> Heap a -> Heap a makeH2 x E xs = H1 x xs makeH2 x h xs = H2 x h xs empty :: Heap a empty = E singleton :: a -> Heap a singleton x = H1 x E insert :: Ord a => a -> Heap a -> Heap a insert x E = H1 x E insert x h@(H1 y b) | x <= y = H1 x h | otherwise = H2 y (H1 x E) b insert x h@(H2 y a b) | x <= y = H1 x h | otherwise = H1 y (union (insert x a) b) union :: Ord a => Heap a -> Heap a -> Heap a union E h = h union hx@(H1 _ _) E = hx union hx@(H1 x xs) hy@(H1 y ys) | x <= y = H2 x hy xs | otherwise = H2 y hx ys union hx@(H1 x xs) hy@(H2 y a ys) | x <= y = H2 x hy xs | otherwise = H1 y (union (union hx a) ys) union hx@(H2 _ _ _) E = hx union hx@(H2 x a xs) hy@(H1 y ys) | x <= y = H1 x (union (union hy a) xs) | otherwise = H2 y hx ys union hx@(H2 x a xs) hy@(H2 y b ys) | x <= y = H1 x (union (union hy a) xs) | otherwise = H1 y (union (union hx b) ys) delete :: Ord a => a -> Heap a -> Heap a delete y h = case del h of Just h' -> h' Nothing -> h where del E = Nothing del (H1 x xs) = case compare x y of LT -> case del xs of Just ys -> Just (H1 x ys) Nothing -> Nothing EQ -> Just xs GT -> Nothing del (H2 x a xs) = case compare x y of LT -> case del a of Just a' -> Just (makeH2 x a' xs) Nothing -> case del xs of Just xs' -> Just (H2 x a xs') Nothing -> Nothing EQ -> Just (union a xs) GT -> Nothing deleteAll :: Ord a => a -> Heap a -> Heap a deleteAll _ E = E deleteAll y h@(H1 x xs) = case compare x y of LT -> H1 x (deleteAll y xs) EQ -> deleteAll y xs GT -> h deleteAll y h@(H2 x a xs) = case compare x y of LT -> makeH2 x (deleteAll y a) (deleteAll y xs) EQ -> union (deleteAll y a) (deleteAll y xs) GT -> h deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a deleteSeq = delList . sort . S.toList where delList [] h = h delList (y:ys) h = del y ys h del _ _ E = E del y ys h@(H1 x xs) = case compare x y of LT -> H1 x (del y ys xs) EQ -> delList ys xs GT -> delList ys h del y ys h@(H2 x a xs) = case compare x y of LT -> H1 x (del y ys (union a xs)) EQ -> delList ys (union a xs) GT -> delList ys h {- could write the two GT cases as delList (dropWhile (< x) ys) h but this is only a win if we expect many of the ys to be missing from the tree. However, we expect most of the ys to be present. -} null :: Heap a -> Bool null E = True null _ = False size :: Heap a -> Int size E = 0 size (H1 _ xs) = 1 + size xs size (H2 _ h xs) = 1 + size h + size xs member :: Ord a => a -> Heap a -> Bool member _ E = False member x (H1 y ys) = case compare x y of LT -> False EQ -> True GT -> member x ys member x (H2 y h ys) = case compare x y of LT -> False EQ -> True GT -> member x h || member x ys count :: Ord a => a -> Heap a -> Int count _ E = 0 count x (H1 y ys) = case compare x y of LT -> 0 EQ -> 1 + count x ys GT -> count x ys count x (H2 y h ys) = case compare x y of LT -> 0 EQ -> 1 + count x h + count x ys GT -> count x h + count x ys deleteMin :: Ord a => Heap a -> Heap a deleteMin E = E deleteMin (H1 _ xs) = xs deleteMin (H2 _ h xs) = union h xs unsafeInsertMin :: Ord a => a -> Heap a -> Heap a unsafeInsertMin = H1 unsafeInsertMax :: Ord a => a -> Heap a -> Heap a unsafeInsertMax x E = H1 x E unsafeInsertMax x (H1 y ys) = H2 y (H1 x E) ys unsafeInsertMax x (H2 y h ys) = H1 y (union (unsafeInsertMax x h) ys) unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a unsafeAppend h E = h unsafeAppend E h = h unsafeAppend (H1 x xs) h = H2 x h xs unsafeAppend (H2 x a xs) h = H1 x (union (unsafeAppend a h) xs) filterLT :: Ord a => a -> Heap a -> Heap a filterLT _ E = E filterLT y (H1 x xs) | x < y = H1 x (filterLT y xs) | otherwise = E filterLT y (H2 x h xs) | x < y = makeH2 x (filterLT y h) (filterLT y xs) | otherwise = E filterLE :: Ord a => a -> Heap a -> Heap a filterLE _ E = E filterLE y (H1 x xs) | x <= y = H1 x (filterLE y xs) | otherwise = E filterLE y (H2 x h xs) | x <= y = makeH2 x (filterLE y h) (filterLE y xs) | otherwise = E filterGT :: Ord a => a -> Heap a -> Heap a filterGT y h = fgt h E where fgt E rest = rest fgt i@(H1 x xs) rest | x > y = union i rest | otherwise = fgt xs rest fgt i@(H2 x a xs) rest | x > y = union i rest | otherwise = fgt a (fgt xs rest) filterGE :: Ord a => a -> Heap a -> Heap a filterGE y h = fge h E where fge E rest = rest fge i@(H1 x xs) rest | x >= y = union i rest | otherwise = fge xs rest fge i@(H2 x a xs) rest | x >= y = union i rest | otherwise = fge a (fge xs rest) partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GE _ E = (E,E) partitionLT_GE y h@(H1 x xs) | x < y = let (xs',xs'') = partitionLT_GE y xs in (H1 x xs',xs'') | otherwise = (E, h) partitionLT_GE y h@(H2 x a xs) | x < y = let (a',a'') = partitionLT_GE y a (xs',xs'') = partitionLT_GE y xs in (makeH2 x a' xs',union a'' xs'') | otherwise = (E, h) partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLE_GT _ E = (E,E) partitionLE_GT y h@(H1 x xs) | x <= y = let (xs',xs'') = partitionLE_GT y xs in (H1 x xs',xs'') | otherwise = (E, h) partitionLE_GT y h@(H2 x a xs) | x <= y = let (a',a'') = partitionLE_GT y a (xs',xs'') = partitionLE_GT y xs in (makeH2 x a' xs',union a'' xs'') | otherwise = (E, h) partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GT _ E = (E,E) partitionLT_GT y h@(H1 x xs) = case compare x y of LT -> let (xs',xs'') = partitionLT_GT y xs in (H1 x xs',xs'') EQ -> (E, filterGT y xs) GT -> (E, h) partitionLT_GT y h@(H2 x a xs) = case compare x y of LT -> let (a',a'') = partitionLT_GT y a (xs',xs'') = partitionLT_GT y xs in (makeH2 x a' xs',union a'' xs'') EQ -> (E, union (filterGT y a) (filterGT y xs)) GT -> (E, h) toSeq :: S.Sequence seq => Heap a -> seq a toSeq h = tol h S.empty where tol E rest = rest tol (H1 x xs) rest = S.lcons x (tol xs rest) tol (H2 x i xs) rest = S.lcons x $ tol i $ tol xs rest fold :: (a -> b -> b) -> b -> Heap a -> b fold _ c E = c fold f c (H1 x xs) = f x (fold f c xs) fold f c (H2 x h xs) = f x (fold f (fold f c xs) h) fold' :: (a -> b -> b) -> b -> Heap a -> b fold' _ c E = c fold' f c (H1 x xs) = c `seq` f x $! (fold' f c xs) fold' f c (H2 x h xs) = c `seq` f x $! (fold' f (fold' f c xs) h) fold1 :: (a -> a -> a) -> Heap a -> a fold1 _ E = error "LazyPairingHeap.fold1: empty heap" fold1 f (H1 x xs) = fold f x xs fold1 f (H2 x h xs) = fold f (fold f x xs) h fold1' :: (a -> a -> a) -> Heap a -> a fold1' _ E = error "LazyPairingHeap.fold1': empty heap" fold1' f (H1 x xs) = fold' f x xs fold1' f (H2 x h xs) = fold' f (fold' f x xs) h filter :: Ord a => (a -> Bool) -> Heap a -> Heap a filter _ E = E filter p (H1 x xs) = if p x then H1 x (filter p xs) else filter p xs filter p (H2 x h xs) = if p x then makeH2 x (filter p h) (filter p xs) else union (filter p h) (filter p xs) partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) partition _ E = (E, E) partition p (H1 x xs) = if p x then (H1 x xs',xs'') else (xs',H1 x xs'') where (xs',xs'') = partition p xs partition p (H2 x h xs) = if p x then (makeH2 x h' xs', union h'' xs'') else (union h' xs', makeH2 x h'' xs'') where (h',h'') = partition p h (xs',xs'') = partition p xs lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a lookupAll y h = look h S.empty where look E rest = rest look (H1 x xs) rest = case compare x y of LT -> look xs rest EQ -> S.lcons x (look xs rest) GT -> rest look (H2 x i xs) rest = case compare x y of LT -> look i $ look xs rest EQ -> S.lcons x $ look i $ look xs rest GT -> rest minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a) minView E = fail "LazyPairingHeap.minView: empty heap" minView (H1 x xs) = return (x,xs) minView (H2 x h xs) = return (x,union h xs) minElem :: Heap a -> a minElem E = error "LazyPairingHeap.minElem: empty heap" minElem (H1 x _) = x minElem (H2 x _ _) = x maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a) maxView E = fail "LazyPairingHeap.maxView: empty heap" maxView xs = return (y,xs') where (xs', y) = maxView' xs -- not exported maxView' :: (Ord a) => Heap a -> (Heap a, a) maxView' (H1 x E) = (E, x) maxView' (H1 x xs) = (H1 x xs', y) where (xs', y) = maxView' xs maxView' (H2 x a E) = (H1 x a', y) where (a', y) = maxView' a maxView' (H2 x a xs) = if y > z then (makeH2 x a' xs, y) else (H2 x a xs', z) where (a', y) = maxView' a (xs', z) = maxView' xs maxView' E = error "LazyPairingHeap.maxView': bug!" maxElem :: Ord a => Heap a -> a maxElem E = error "LazyPairingHeap.maxElem: empty heap" maxElem (H1 x E) = x maxElem (H1 _ xs) = maxElem xs maxElem (H2 _ h E) = maxElem h maxElem (H2 _ h xs) = max (maxElem h) (maxElem xs) foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldr _ c E = c foldr f c (H1 x xs) = f x (foldr f c xs) foldr f c (H2 x h xs) = f x (foldr f c (union h xs)) foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldr' _ c E = c foldr' f c (H1 x xs) = c `seq` f x $! (foldr' f c xs) foldr' f c (H2 x h xs) = c `seq` f x $! (foldr' f c (union h xs)) foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldl _ c E = c foldl f c (H1 x xs) = foldl f (f c x) xs foldl f c (H2 x h xs) = foldl f (f c x) (union h xs) foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldl' _ c E = c foldl' f c (H1 x xs) = c `seq` foldl' f (f c x) xs foldl' f c (H2 x h xs) = c `seq` foldl' f (f c x) (union h xs) foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a foldr1 _ E = error "LazyPairingHeap.foldr1: empty heap" foldr1 _ (H1 x E) = x foldr1 f (H1 x xs) = f x (foldr1 f xs) foldr1 f (H2 x h xs) = f x (foldr1 f (union h xs)) foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a foldr1' _ E = error "LazyPairingHeap.foldr1': empty heap" foldr1' _ (H1 x E) = x foldr1' f (H1 x xs) = f x $! (foldr1' f xs) foldr1' f (H2 x h xs) = f x $! (foldr1' f (union h xs)) foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a foldl1 _ E = error "LazyPairingHeap.foldl1: empty heap" foldl1 f (H1 x xs) = foldl f x xs foldl1 f (H2 x h xs) = foldl f x (union h xs) foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a foldl1' _ E = error "LazyPairingHeap.foldl1': empty heap" foldl1' f (H1 x xs) = foldl' f x xs foldl1' f (H2 x h xs) = foldl' f x (union h xs) unsafeMapMonotonic :: (Ord a,Ord b) => (a -> b) -> Heap a -> Heap b unsafeMapMonotonic = mapm where mapm _ E = E mapm f (H1 x xs) = H1 (f x) (mapm f xs) mapm f (H2 x h xs) = H2 (f x) (mapm f h) (mapm f xs) strict :: Heap a -> Heap a strict h@E = h strict h@(H1 _ xs) = strict xs `seq` h strict h@(H2 _ h' xs) = strict h' `seq` strict xs `seq` h strictWith :: (a -> b) -> Heap a -> Heap a strictWith _ h@E = h strictWith f h@(H1 x xs) = f x `seq` strictWith f xs `seq` h strictWith f h@(H2 x h' xs) = f x `seq` strictWith f h' `seq` strictWith f xs `seq` h -- the remaining functions all use default definitions fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a fromSeq = fromSeqUsingFoldr insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a insertSeq = insertSeqUsingFoldr unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a unionSeq = unionSeqUsingFoldl unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin deleteMax :: Ord a => Heap a -> Heap a deleteMax = deleteMaxUsingMaxView lookup :: Ord a => a -> Heap a -> a lookup = lookupUsingLookupAll lookupM :: (Ord a, Monad m) => a -> Heap a -> m a lookupM = lookupMUsingLookupAll lookupWithDefault :: Ord a => a -> a -> Heap a -> a lookupWithDefault = lookupWithDefaultUsingLookupAll toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a toOrdSeq = toOrdSeqUsingFoldr -- instance declarations instance Ord a => C.CollX (Heap a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Ord a => C.OrdCollX (Heap a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance Ord a => C.Coll (Heap a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance Ord a => C.OrdColl (Heap a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} instance Ord a => Eq (Heap a) where xs == ys = C.toOrdList xs == C.toOrdList ys instance (Ord a, Show a) => Show (Heap a) where showsPrec = showsPrecUsingToList instance (Ord a, Read a) => Read (Heap a) where readsPrec = readsPrecUsingFromList instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where arbitrary = sized (\n -> arbTree n) where arbTree 0 = return E arbTree n = frequency [(1, return E), (2, liftM2 sift1 arbitrary (arbTree (n - 1))), (3, liftM3 sift arbitrary (arbTree (n `div` 4)) (arbTree (n `div` 2)))] sift x E a = sift1 x a sift x a E = let H1 x' a' = sift1 x a in H2 x' a' E sift x a b | x <= ma && x <= mb = H2 x a b | ma < x && ma <= mb = H2 ma (siftInto x a) b | otherwise = H2 mb a (siftInto x b) where ma = minElem a mb = minElem b sift1 x E = H1 x E sift1 x a | x <= ma = H1 x a | otherwise = H1 ma (siftInto x a) where ma = minElem a siftInto x (H1 _ a) = sift1 x a siftInto x (H2 _ a b) = sift x a b siftInto _ E = error "LazyPairingHeap.arbitrary: bug!" instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where coarbitrary E = variant 0 coarbitrary (H1 x a) = variant 1 . coarbitrary x . coarbitrary a coarbitrary (H2 x a b) = variant 2 . coarbitrary x . coarbitrary a . coarbitrary b instance (Ord a) => 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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/Defaults.hs0000644000000000000000000002117113223626550017757 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.Defaults -- Copyright : Copyright (c) 1998, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : internal (unstable) -- Portability : GHC / Hugs (MPTC and FD) -- -- This module provides default implementations of many of the collection methods. The functions -- in this module are used to fill out collection implementations and are not intended to be -- used directly by end users. module Data.Edison.Coll.Defaults where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import Control.Monad.Identity import Data.Edison.Coll import qualified Data.Edison.Seq as S import qualified Data.Edison.Seq.ListSeq as L import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) insertSeqUsingUnion :: (CollX c a,S.Sequence seq) => seq a -> c -> c insertSeqUsingUnion xs c = union (fromSeq xs) c insertSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c -> c insertSeqUsingFoldr xs c = S.foldr insert c xs memberUsingFold :: Coll c a => c -> a -> Bool memberUsingFold h x = fold (\y ans -> (x == y) || ans) False h countUsingMember :: SetX c a => a -> c -> Int countUsingMember x xs = if member x xs then 1 else 0 lookupAllUsingLookupM :: (Set c a,S.Sequence seq) => a -> c -> seq a lookupAllUsingLookupM x xs = case lookupM x xs of Nothing -> S.empty Just y -> S.singleton y deleteSeqUsingDelete :: (CollX c a,S.Sequence seq) => seq a -> c -> c deleteSeqUsingDelete xs c = S.foldr delete c xs unionSeqUsingFoldl :: (CollX c a,S.Sequence seq) => seq c -> c unionSeqUsingFoldl = S.foldl union empty unionSeqUsingFoldl' :: (CollX c a,S.Sequence seq) => seq c -> c unionSeqUsingFoldl' = S.foldl' union empty unionSeqUsingReduce :: (CollX c a,S.Sequence seq) => seq c -> c unionSeqUsingReduce = S.reducel union empty fromSeqUsingFoldr :: (CollX c a,S.Sequence seq) => seq a -> c fromSeqUsingFoldr = S.foldr insert empty fromSeqUsingUnionSeq :: (CollX c a,S.Sequence seq) => seq a -> c fromSeqUsingUnionSeq = unionList . S.foldl singleCons [] where singleCons xs x = S.lcons (singleton x) xs toSeqUsingFold :: (Coll c a,S.Sequence seq) => c -> seq a toSeqUsingFold = fold S.lcons S.empty unsafeInsertMaxUsingUnsafeAppend :: OrdCollX c a => a -> c -> c unsafeInsertMaxUsingUnsafeAppend x c = unsafeAppend c (singleton x) toOrdSeqUsingFoldr :: (OrdColl c a,S.Sequence seq) => c -> seq a toOrdSeqUsingFoldr = foldr S.lcons S.empty unsafeFromOrdSeqUsingUnsafeInsertMin :: (OrdCollX c a,S.Sequence seq) => seq a -> c unsafeFromOrdSeqUsingUnsafeInsertMin = S.foldr unsafeInsertMin empty disjointUsingToOrdList :: OrdColl c a => c -> c -> Bool disjointUsingToOrdList xs ys = disj (toOrdList xs) (toOrdList ys) where disj a@(c:cs) b@(d:ds) = case compare c d of LT -> disj cs b EQ -> False GT -> disj a ds disj _ _ = True intersectWitnessUsingToOrdList :: (OrdColl c a, Monad m) => c -> c -> m (a,a) intersectWitnessUsingToOrdList as bs = witness (toOrdList as) (toOrdList bs) where witness a@(x:xs) b@(y:ys) = case compare x y of LT -> witness xs b EQ -> return (x, y) GT -> witness a ys -- XXX witness _ _ = fail $ instanceName as ++ ".intersect: failed" lookupUsingLookupM :: Coll c a => a -> c -> a lookupUsingLookupM x ys = runIdentity (lookupM x ys) lookupUsingLookupAll :: Coll c a => a -> c -> a lookupUsingLookupAll x ys = case lookupAll x ys of (y:_) -> y [] -> error $ instanceName ys ++ ".lookup: lookup failed" lookupMUsingLookupAll :: (Coll c a, Monad m) => a -> c -> m a lookupMUsingLookupAll x ys = case lookupAll x ys of (y:_) -> return y [] -> fail $ instanceName ys ++ ".lookupM: lookup failed" lookupWithDefaultUsingLookupAll :: Coll c a => a -> a -> c -> a lookupWithDefaultUsingLookupAll dflt x ys = case lookupAll x ys of (y:_) -> y [] -> dflt lookupWithDefaultUsingLookupM :: Coll c a => a -> a -> c -> a lookupWithDefaultUsingLookupM dflt x ys = case lookupM x ys of Just y -> y Nothing -> dflt deleteMaxUsingMaxView :: OrdColl c a => c -> c deleteMaxUsingMaxView c = case maxView c of Just (_,c') -> c' Nothing -> c fromSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c fromSeqWithUsingInsertWith c = S.foldr (insertWith c) empty insertUsingInsertWith :: Set c a => a -> c -> c insertUsingInsertWith = insertWith (\x _ -> x) unionUsingUnionWith :: Set c a => c -> c -> c unionUsingUnionWith = unionWith (\x _ -> x) filterUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> c filterUsingOrdLists p = unsafeFromOrdList . L.filter p . toOrdList partitionUsingOrdLists :: OrdColl c a => (a -> Bool) -> c -> (c,c) partitionUsingOrdLists p xs = (unsafeFromOrdList ys,unsafeFromOrdList zs) where (ys,zs) = L.partition p (toOrdList xs) intersectionUsingIntersectionWith :: Set c a => c -> c -> c intersectionUsingIntersectionWith = intersectionWith (\x _ -> x) differenceUsingOrdLists :: OrdSet c a => c -> c -> c differenceUsingOrdLists as bs = unsafeFromOrdList $ diff (toOrdList as) (toOrdList bs) where diff a@(x:xs) b@(y:ys) = case compare x y of LT -> x : diff xs b EQ -> diff xs ys GT -> diff a ys diff a _ = a symmetricDifferenceUsingDifference :: SetX c a => c -> c -> c symmetricDifferenceUsingDifference xs ys = union (difference xs ys) (difference ys xs) properSubsetUsingOrdLists :: OrdSet c a => c -> c -> Bool properSubsetUsingOrdLists xs ys = properSubsetOnOrdLists (toOrdList xs) (toOrdList ys) subsetUsingOrdLists :: OrdSet c a => c -> c -> Bool subsetUsingOrdLists xs ys = subsetOnOrdLists (toOrdList xs) (toOrdList ys) properSubsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool properSubsetOnOrdLists [] [] = False properSubsetOnOrdLists [] (_:_) = True properSubsetOnOrdLists (_:_) [] = False properSubsetOnOrdLists a@(x:xs) (y:ys) = case compare x y of LT -> False EQ -> properSubsetOnOrdLists xs ys GT -> subsetOnOrdLists a ys subsetOnOrdLists :: (Ord t) => [t] -> [t] -> Bool subsetOnOrdLists [] _ = True subsetOnOrdLists (_:_) [] = False subsetOnOrdLists a@(x:xs) (y:ys) = case compare x y of LT -> False EQ -> subsetOnOrdLists xs ys GT -> subsetOnOrdLists a ys insertSeqWithUsingInsertWith :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq a -> c -> c insertSeqWithUsingInsertWith c xs s = S.foldr (insertWith c) s xs unionlUsingUnionWith :: Set c a => c -> c -> c unionlUsingUnionWith xs ys = unionWith (\x _ -> x) xs ys unionrUsingUnionWith :: Set c a => c -> c -> c unionrUsingUnionWith xs ys = unionWith (\_ y -> y) xs ys unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c unionWithUsingOrdLists c as bs = unsafeFromOrdList $ merge (toOrdList as) (toOrdList bs) where merge a@(x:xs) b@(y:ys) = case compare x y of LT -> x : merge xs b EQ -> c x y : merge xs ys GT -> y : merge a ys merge a [] = a merge [] b = b unionSeqWithUsingReducer :: (Set c a,S.Sequence seq) => (a -> a -> a) -> seq c -> c unionSeqWithUsingReducer c = S.reducer (unionWith c) empty intersectionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c intersectionWithUsingOrdLists c as bs = unsafeFromOrdList $ inter (toOrdList as) (toOrdList bs) where inter a@(x:xs) b@(y:ys) = case compare x y of LT -> inter xs b EQ -> c x y : inter xs ys GT -> inter a ys inter _ _ = [] unsafeMapMonotonicUsingFoldr :: (OrdColl cin a, OrdCollX cout b) => (a -> b) -> (cin -> cout) unsafeMapMonotonicUsingFoldr f xs = foldr (unsafeInsertMin . f) empty xs showsPrecUsingToList :: (Coll c a,Show a) => Int -> c -> ShowS showsPrecUsingToList i xs rest | i == 0 = concat [ instanceName xs,".fromSeq ",showsPrec 10 (toList xs) rest] | otherwise = concat ["(",instanceName xs,".fromSeq ",showsPrec 10 (toList xs) (')':rest)] readsPrecUsingFromList :: (Coll c a, Read a) => Int -> ReadS c readsPrecUsingFromList _ xs = let result = maybeParens p xs p ys = tokenMatch ((instanceName x) ++ ".fromSeq") ys >>= readsPrec 10 >>= \(l,rest) -> return (fromList l,rest) -- play games with the typechecker so we don't have to use -- extensions for scoped type variables ~[(x,_)] = result in result compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering compareUsingToOrdList as bs = cmp (toOrdList as) (toOrdList bs) where cmp [] [] = EQ cmp [] _ = LT cmp _ [] = GT cmp (x:xs) (y:ys) = case compare x y of EQ -> cmp xs ys c -> c EdisonCore-1.3.2.1/src/Data/Edison/Coll/StandardSet.hs0000644000000000000000000002436613223626550020435 0ustar0000000000000000-- | -- Module : Data.Edison.Coll -- Copyright : Copyright (c) 2006, 2008 Robert Dockins -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- The standard library "Data.Set" repackaged as an Edison collection. module Data.Edison.Coll.StandardSet ( -- * Set type Set, -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict, -- * Coll operations toSeq,lookup,lookupM,lookupAll,lookupWithDefault,fold,fold', fold1,fold1',filter,partition,strictWith,structuralInvariant, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq,unsafeMapMonotonic, -- * SetX operations intersection,difference,symmetricDifference,properSubset,subset, -- * Set operations fromSeqWith,insertWith,insertSeqWith,unionl,unionr,unionWith, unionSeqWith,intersectionWith, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Prelude import qualified Data.List import qualified Data.Edison.Coll as C import qualified Data.Edison.Seq as S import qualified Data.Edison.Seq.ListSeq as L import Data.Edison.Coll.Defaults import Test.QuickCheck import qualified Data.Set as DS -- signatures for exported functions moduleName :: String empty :: Set a singleton :: a -> Set a fromSeq :: (Ord a,S.Sequence seq) => seq a -> Set a insert :: Ord a => a -> Set a -> Set a insertSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a union :: Ord a => Set a -> Set a -> Set a unionSeq :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a delete :: Ord a => a -> Set a -> Set a deleteAll :: Ord a => a -> Set a -> Set a deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a null :: Set a -> Bool size :: Set a -> Int member :: Ord a => a -> Set a -> Bool count :: Ord a => a -> Set a -> Int strict :: Ord a => Set a -> Set a toSeq :: (Ord a,S.Sequence seq) => Set a -> seq a lookup :: Ord a => a -> Set a -> a lookupM :: (Ord a,Monad m) => a -> Set a -> m a lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a lookupWithDefault :: Ord a => a -> a -> Set a -> a fold :: (a -> b -> b) -> b -> Set a -> b fold1 :: (a -> a -> a) -> Set a -> a fold' :: (a -> b -> b) -> b -> Set a -> b fold1' :: (a -> a -> a) -> Set a -> a filter :: Ord a => (a -> Bool) -> Set a -> Set a partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a) strictWith :: Ord a => (a -> b) -> Set a -> Set a deleteMin :: Ord a => Set a -> Set a deleteMax :: Ord a => Set a -> Set a unsafeInsertMin :: Ord a => a -> Set a -> Set a unsafeInsertMax :: Ord a => a -> Set a -> Set a unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a unsafeAppend :: Ord a => Set a -> Set a -> Set a filterLT :: Ord a => a -> Set a -> Set a filterLE :: Ord a => a -> Set a -> Set a filterGT :: Ord a => a -> Set a -> Set a filterGE :: Ord a => a -> Set a -> Set a partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a) partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a) partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a) minView :: (Ord a,Monad m) => Set a -> m (a, Set a) minElem :: Set a -> a maxView :: (Ord a,Monad m) => Set a -> m (a, Set a) maxElem :: Set a -> a foldr :: (a -> b -> b) -> b -> Set a -> b foldl :: (b -> a -> b) -> b -> Set a -> b foldr1 :: (a -> a -> a) -> Set a -> a foldl1 :: (a -> a -> a) -> Set a -> a foldr' :: (a -> b -> b) -> b -> Set a -> b foldl' :: (b -> a -> b) -> b -> Set a -> b foldr1' :: (a -> a -> a) -> Set a -> a foldl1' :: (a -> a -> a) -> Set a -> a toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a intersection :: Ord a => Set a -> Set a -> Set a difference :: Ord a => Set a -> Set a -> Set a symmetricDifference :: Ord a => Set a -> Set a -> Set a properSubset :: Ord a => Set a -> Set a -> Bool subset :: Ord a => Set a -> Set a -> Bool fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a unionl :: Ord a => Set a -> Set a -> Set a unionr :: Ord a => Set a -> Set a -> Set a unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a moduleName = "Data.Edison.Coll.StandardSet" type Set = DS.Set structuralInvariant :: Ord a => Set a -> Bool structuralInvariant = DS.valid empty = DS.empty singleton = DS.singleton fromSeq = fromSeqUsingFoldr insert = DS.insert insertSeq = insertSeqUsingUnion union = DS.union unionSeq se = DS.unions $ S.toList se delete = DS.delete deleteAll = DS.delete -- by set property deleteSeq = deleteSeqUsingDelete null = DS.null size = DS.size member = DS.member count = countUsingMember strict xs = DS.fold (flip const) () xs `seq` xs toSeq = toSeqUsingFold lookup el set = DS.findMin (DS.intersection set (DS.singleton el)) lookupM = lookupMUsingLookupAll lookupAll el set = toSeqUsingFold (DS.intersection set (DS.singleton el)) lookupWithDefault = lookupWithDefaultUsingLookupAll fold = DS.fold fold' f x xs = L.foldl' (flip f) x (DS.toList xs) fold1 f set = let (x,s) = DS.deleteFindMin set in DS.fold f x s fold1' f xs = L.foldl1' (flip f) (DS.toList xs) filter = DS.filter partition = DS.partition strictWith f xs = DS.fold (\x z -> f x `seq` z) () xs `seq` xs deleteMin = DS.deleteMin deleteMax = DS.deleteMax unsafeInsertMin = DS.insert unsafeInsertMax = DS.insert unsafeFromOrdSeq = DS.fromDistinctAscList . S.toList unsafeAppend = DS.union filterLT x = fst . DS.split x filterLE x = DS.filter (<=x) filterGT x = snd . DS.split x filterGE x = DS.filter (>=x) partitionLT_GE x = DS.partition ( 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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/MinHeap.hs0000644000000000000000000003240013223626550017526 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.MinHeap -- Copyright : Copyright (c) 1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- A generic adaptor for bags to keep the minimum element separately. module Data.Edison.Coll.MinHeap ( -- * Min heap adaptor type Min, -- instance of Coll/CollX, OrdColl/OrdCollX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', fold1, fold1', filter, partition, strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq, unsafeMapMonotonic, -- * Other supported operations toColl,fromColl, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Data.Edison.Coll as C import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) import Data.Monoid import qualified Data.Semigroup as SG import Control.Monad import Test.QuickCheck data Min h a = E | M a h deriving (Eq) moduleName :: String moduleName = "Data.Edison.Coll.MinHeap" structuralInvariant :: (Ord a,C.OrdColl h a) => Min h a -> Bool structuralInvariant E = True structuralInvariant (M x h) = if C.null h then True else x <= C.minElem h empty :: Min h a singleton :: (C.CollX h a,Ord a) => a -> Min h a fromSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a insert :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a insertSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a union :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a unionSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s (Min h a) -> Min h a delete :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a deleteAll :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a deleteSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => s a -> Min h a -> Min h a null :: Min h a -> Bool size :: C.CollX h a => Min h a -> Int member :: (C.CollX h a,Ord a) => a -> Min h a -> Bool count :: (C.CollX h a,Ord a) => a -> Min h a -> Int strict :: (C.CollX h a,Ord a) => Min h a -> Min h a toSeq :: (C.Coll h a,S.Sequence s) => Min h a -> s a lookup :: (C.Coll h a,Ord a) => a -> Min h a -> a lookupM :: (C.Coll h a,Ord a,Monad m) => a -> Min h a -> m a lookupAll :: (C.Coll h a,Ord a,S.Sequence s) => a -> Min h a -> s a lookupWithDefault :: (C.Coll h a,Ord a) => a -> a -> Min h a -> a fold :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b fold1 :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a fold' :: (C.Coll h a) => (a -> b -> b) -> b -> Min h a -> b fold1' :: (C.Coll h a) => (a -> a -> a) -> Min h a -> a filter :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> Min h a partition :: (C.OrdColl h a) => (a -> Bool) -> Min h a -> (Min h a, Min h a) strictWith :: (C.OrdColl h a) => (a -> b) -> Min h a -> Min h a deleteMin :: (C.OrdColl h a,Ord a) => Min h a -> Min h a deleteMax :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a unsafeInsertMin :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a unsafeInsertMax :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a unsafeFromOrdSeq :: (C.OrdCollX h a,Ord a,S.Sequence s) => s a -> Min h a unsafeAppend :: (C.OrdCollX h a,Ord a) => Min h a -> Min h a -> Min h a filterLT :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a filterLE :: (C.OrdCollX h a,Ord a) => a -> Min h a -> Min h a filterGT :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a filterGE :: (C.OrdColl h a,Ord a) => a -> Min h a -> Min h a partitionLT_GE :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) partitionLE_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) partitionLT_GT :: (C.OrdColl h a,Ord a) => a -> Min h a -> (Min h a, Min h a) minView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a) minElem :: (C.OrdColl h a,Ord a) => Min h a -> a maxView :: (C.OrdColl h a,Ord a,Monad m) => Min h a -> m (a, Min h a) maxElem :: (C.OrdColl h a,Ord a) => Min h a -> a foldr :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b foldl :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b foldr1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a foldl1 :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a foldr' :: (C.OrdColl h a,Ord a) => (a -> b -> b) -> b -> Min h a -> b foldl' :: (C.OrdColl h a,Ord a) => (b -> a -> b) -> b -> Min h a -> b foldr1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a foldl1' :: (C.OrdColl h a,Ord a) => (a -> a -> a) -> Min h a -> a toOrdSeq :: (C.OrdColl h a,Ord a,S.Sequence s) => Min h a -> s a unsafeMapMonotonic :: (C.OrdColl h a,Ord a) => (a -> a) -> Min h a -> Min h a fromColl :: C.OrdColl h a => h -> Min h a fromColl = fromPrim toColl :: C.OrdColl h a => Min h a -> h toColl = toPrim fromPrim :: (C.OrdColl c a) => c -> Min c a fromPrim xs = case C.minView xs of Nothing -> E Just (x, xs') -> M x xs' toPrim :: (C.OrdCollX c a) => Min c a -> c toPrim E = C.empty toPrim (M x xs) = C.unsafeInsertMin x xs empty = E singleton x = M x C.empty fromSeq = fromPrim . C.fromSeq insert x E = M x C.empty insert x (M y xs) | x <= y = M x (C.unsafeInsertMin y xs) | otherwise = M y (C.insert x xs) insertSeq xs E = fromSeq xs insertSeq xs (M y ys) = case C.minView xs_ys of Nothing -> M y C.empty Just (x, rest) | x < y -> M x (C.insert y rest) | otherwise -> M y xs_ys where xs_ys = C.insertSeq xs ys union E ys = ys union xs E = xs union (M x xs) (M y ys) | x <= y = M x (C.union xs (C.unsafeInsertMin y ys)) | otherwise = M y (C.union (C.unsafeInsertMin x xs) ys) unionSeq = unionSeqUsingReduce delete _ E = E delete x m@(M y ys) | x > y = M y (C.delete x ys) | x == y = fromPrim ys | otherwise = m deleteAll _ E = E deleteAll x m@(M y ys) | x > y = M y (C.deleteAll x ys) | x == y = fromPrim (C.deleteAll x ys) | otherwise = m deleteSeq = deleteSeqUsingDelete null E = True null (M _ _) = False size E = 0 size (M _ xs) = 1 + C.size xs member _ E = False member x (M y ys) | x > y = C.member x ys | otherwise = (x == y) count _ E = 0 count x (M y ys) | x > y = C.count x ys | x == y = 1 + C.count x ys | otherwise = 0 toSeq E = S.empty toSeq (M x xs) = S.lcons x (C.toSeq xs) lookup x (M y ys) | x > y = C.lookup x ys | x == y = y lookup _ _ = error "MinHeap.lookup: empty heap" lookupM x (M y ys) | x > y = C.lookupM x ys | x == y = return y lookupM _ _ = fail "lookupM.lookup: XXX" lookupAll x (M y ys) | x > y = C.lookupAll x ys | x == y = S.lcons y (C.lookupAll x ys) lookupAll _ _ = S.empty lookupWithDefault d x (M y ys) | x > y = C.lookupWithDefault d x ys | x == y = y lookupWithDefault d _ _ = d fold _ e E = e fold f e (M x xs) = f x (C.fold f e xs) fold' _ e E = e fold' f e (M x xs) = f x $! (C.fold' f e xs) fold1 _ E = error "MinHeap.fold1: empty heap" fold1 f (M x xs) = C.fold f x xs fold1' _ E = error "MinHeap.fold1': empty heap" fold1' f (M x xs) = C.fold' f x xs filter _ E = E filter p (M x xs) | p x = M x (C.filter p xs) | otherwise = fromPrim (C.filter p xs) partition _ E = (E, E) partition p (M x xs) | p x = (M x ys, fromPrim zs) | otherwise = (fromPrim ys, M x zs) where (ys,zs) = C.partition p xs deleteMin E = E deleteMin (M _ xs) = fromPrim xs deleteMax E = E deleteMax (M x xs) | C.null xs = E | otherwise = M x (C.deleteMax xs) unsafeInsertMin x xs = M x (toPrim xs) unsafeInsertMax x E = M x C.empty unsafeInsertMax x (M y ys) = M y (C.unsafeInsertMax x ys) unsafeFromOrdSeq xs = case S.lview xs of Nothing -> E Just (x,xs') -> M x (C.unsafeFromOrdSeq xs') unsafeAppend E ys = ys unsafeAppend (M x xs) ys = M x (C.unsafeAppend xs (toPrim ys)) filterLT x (M y ys) | y < x = M y (C.filterLT x ys) filterLT _ _ = E filterLE x (M y ys) | y <= x = M y (C.filterLE x ys) filterLE _ _ = E filterGT x (M y ys) | y <= x = fromPrim (C.filterGT x ys) filterGT _ h = h filterGE x (M y ys) | y < x = fromPrim (C.filterGE x ys) filterGE _ h = h partitionLT_GE x (M y ys) | y < x = (M y lows, fromPrim highs) where (lows,highs) = C.partitionLT_GE x ys partitionLT_GE _ h = (E, h) partitionLE_GT x (M y ys) | y <= x = (M y lows, fromPrim highs) where (lows,highs) = C.partitionLE_GT x ys partitionLE_GT _ h = (E, h) partitionLT_GT x (M y ys) | y < x = let (lows,highs) = C.partitionLT_GT x ys in (M y lows, fromPrim highs) | y == x = (E, fromPrim (C.filterGT x ys)) partitionLT_GT _ h = (E, h) minView E = fail "MinHeap.minView: empty heap" minView (M x xs) = return (x, fromPrim xs) minElem E = error "MinHeap.minElem: empty heap" minElem (M x _) = x maxView E = fail "MinHeap.maxView: empty heap" maxView (M x xs) = case C.maxView xs of Nothing -> return (x, E) Just (y,ys) -> return (y, M x ys) maxElem E = error "MinHeap.minElem: empty heap" maxElem (M x xs) | C.null xs = x | otherwise = C.maxElem xs foldr _ e E = e foldr f e (M x xs) = f x (C.foldr f e xs) foldr' _ e E = e foldr' f e (M x xs) = f x $! (C.foldr' f e xs) foldl _ e E = e foldl f e (M x xs) = C.foldl f (f e x) xs foldl' _ e E = e foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs foldr1 _ E = error "MinHeap.foldr1: empty heap" foldr1 f (M x xs) | C.null xs = x | otherwise = f x (C.foldr1 f xs) foldr1' _ E = error "MinHeap.foldr1': empty heap" foldr1' f (M x xs) | C.null xs = x | otherwise = f x $! (C.foldr1' f xs) foldl1 _ E = error "MinHeap.foldl1: empty heap" foldl1 f (M x xs) = C.foldl f x xs foldl1' _ E = error "MinHeap.foldl1': empty heap" foldl1' f (M x xs) = C.foldl' f x xs toOrdSeq E = S.empty toOrdSeq (M x xs) = S.lcons x (C.toOrdSeq xs) unsafeMapMonotonic = unsafeMapMonotonicUsingFoldr strict h@E = h strict h@(M _ xs) = C.strict xs `seq` h strictWith _ h@E = h strictWith f h@(M x xs) = f x `seq` C.strictWith f xs `seq` h -- instance declarations instance (C.OrdColl h a, Ord a) => C.CollX (Min h a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance (C.OrdColl h a, Ord a) => C.OrdCollX (Min h a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance (C.OrdColl h a, Ord a) => C.Coll (Min h a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance (C.OrdColl h a, Ord a) => C.OrdColl (Min h a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} -- instance Eq is derived instance (C.OrdColl h a, Show h) => Show (Min h a) where showsPrec i xs rest | i == 0 = concat [ moduleName,".fromColl ",showsPrec 10 (toColl xs) rest] | otherwise = concat ["(",moduleName,".fromColl ",showsPrec 10 (toColl xs) (')':rest)] instance (C.OrdColl h a, Read h) => Read (Min h a) where readsPrec _ xs = maybeParens p xs where p ys = tokenMatch (moduleName++".fromColl") ys >>= readsPrec 10 >>= \(coll,rest) -> return (fromColl coll,rest) instance (C.OrdColl h a,Arbitrary h,Arbitrary a) => Arbitrary (Min h a) where arbitrary = do xs <- arbitrary x <- arbitrary i <- arbitrary :: Gen Int return (if C.null xs || x <= C.minElem xs then M x xs else if odd i then M (C.minElem xs) xs else fromPrim xs) instance (C.OrdColl h a,CoArbitrary h,CoArbitrary a) => CoArbitrary (Min h a) where coarbitrary E = variant 0 coarbitrary (M x xs) = variant 1 . coarbitrary x . coarbitrary xs instance (C.OrdColl h a) => 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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/LeftistHeap.hs0000644000000000000000000003703013223626550020421 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.LeftistHeap -- Copyright : Copyright (c) 1998-1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Leftist Heaps -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. Section 3.1. module Data.Edison.Coll.LeftistHeap ( -- * Type of leftist heaps Heap, -- instance of Coll/CollX, OrdColl/OrdCollX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', fold1, fold1', filter, partition, strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq, unsafeMapMonotonic, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..), unionList, toOrdList ) import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.Monoid import Data.Semigroup as SG import Control.Monad import Test.QuickCheck moduleName :: String moduleName = "Data.Edison.Coll.LeftistHeap" data Heap a = E | L !Int !a !(Heap a) !(Heap a) -- invariants: -- * Heap ordered -- * Leftist; the rank of any left node is >= the -- rank of its right sibling. The rank of a node -- is the length of its right spine. structuralInvariant :: Ord a => Heap a -> Bool structuralInvariant E = True structuralInvariant t@(L i x _ _) = i == rank t && isMin x t && checkLeftist t where rank :: Heap a -> Int rank E = 0 rank (L _ _ _ s) = (rank s) + 1 isMin _ E = True isMin z (L _ y l r) = z <= y && (isMin y l) && (isMin y r) checkLeftist E = True checkLeftist (L _ _ l r) = rank l >= rank r && checkLeftist l && checkLeftist r node :: a -> Heap a -> Heap a -> Heap a node x a E = L 1 x a E node x E b = L 1 x b E node x a@(L m _ _ _) b@(L n _ _ _) | m <= n = L (m + 1) x b a | otherwise = L (n + 1) x a b {- Note: when we want to recurse down both sides, and we have a choice, recursing down the smaller side first will minimize stack usage. For delete,deleteAll,filter,partition: could compute fringe and reduce rather that rebuilding with union at every deleted node -} empty :: Ord a => Heap a empty = E singleton :: Ord a => a -> Heap a singleton x = L 1 x E E insert :: Ord a => a -> Heap a -> Heap a insert x E = L 1 x E E insert x h@(L _ y a b) | x <= y = L 1 x h E | otherwise = node y a (insert x b) union :: Ord a => Heap a -> Heap a -> Heap a union E h = h union h@(L _ x a b) h' = union' h x a b h' where union' i _ _ _ E = i union' hx z q e hy@(L _ y c d) | z <= y = node z q (union' hy y c d e) | otherwise = node y c (union' hx z q e d) {- union E h = h union h E = h union h1@(L _ x a b) h2@(L _ y c d) | x <= y = node x a (union b h2) | otherwise = node y c (union h1 d) -- ??? optimize to catch fact that h1 or h2 is known to be L case? -} delete :: Ord a => a -> Heap a -> Heap a delete x h = case del h of Just h' -> h' Nothing -> h where del (L _ y a b) = case compare x y of LT -> Nothing EQ -> Just (union a b) GT -> case del b of Just b' -> Just (node y a b') Nothing -> case del a of Just a' -> Just (node y a' b) Nothing -> Nothing del E = Nothing deleteAll :: Ord a => a -> Heap a -> Heap a deleteAll x h@(L _ y a b) = case compare x y of LT -> h EQ -> union (deleteAll x a) (deleteAll x b) GT -> node y (deleteAll x a) (deleteAll x b) deleteAll _ E = E null :: Ord a => Heap a -> Bool null E = True null _ = False size :: Ord a => Heap a -> Int size h = sz h 0 where sz E i = i sz (L _ _ a b) i = sz a (sz b (i + 1)) member :: Ord a => a -> Heap a -> Bool member _ E = False member x (L _ y a b) = case compare x y of LT -> False EQ -> True GT -> member x b || member x a count :: Ord a => a -> Heap a -> Int count _ E = 0 count x (L _ y a b) = case compare x y of LT -> 0 EQ -> 1 + count x b + count x a GT -> count x b + count x a toSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a toSeq h = tol h S.empty where tol E rest = rest tol (L _ x a b) rest = S.lcons x (tol b (tol a rest)) lookupM :: (Ord a, Monad m) => a -> Heap a -> m a lookupM _ E = fail "LeftistHeap.lookupM: XXX" lookupM x (L _ y a b) = case compare x y of LT -> fail "LeftistHeap.lookupM: XXX" EQ -> return y GT -> case lookupM x b `mplus` lookupM x a of Nothing -> fail "LeftistHeap.lookupM: XXX" Just q -> return q lookupAll :: (Ord a,S.Sequence seq) => a -> Heap a -> seq a lookupAll x h = look h S.empty where look E ys = ys look (L _ y a b) ys = case compare x y of LT -> ys EQ -> S.lcons y (look b (look a ys)) GT -> look b (look a ys) fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b fold _ e E = e fold f e (L _ x a b) = f x (fold f (fold f e a) b) fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b fold' _ e E = e fold' f e (L _ x a b) = e `seq` f x $! (fold' f (fold' f e a) b) fold1 :: Ord a => (a -> a -> a) -> Heap a -> a fold1 _ E = error "LeftistHeap.fold1: empty collection" fold1 f (L _ x a b) = fold f (fold f x a) b fold1' :: Ord a => (a -> a -> a) -> Heap a -> a fold1' _ E = error "LeftistHeap.fold1': empty collection" fold1' f (L _ x a b) = fold' f (fold' f x a) b filter :: Ord a => (a -> Bool) -> Heap a -> Heap a filter _ E = E filter p (L _ x a b) | p x = node x (filter p a) (filter p b) | otherwise = union (filter p a) (filter p b) partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) partition _ E = (E, E) partition p (L _ x a b) | p x = (node x a' b', union a'' b'') | otherwise = (union a' b', node x a'' b'') where (a', a'') = partition p a (b', b'') = partition p b deleteMin :: Ord a => Heap a -> Heap a deleteMin E = E deleteMin (L _ _ a b) = union a b deleteMax :: Ord a => Heap a -> Heap a deleteMax h = case maxView h of Nothing -> E Just (_,h') -> h' unsafeInsertMin :: Ord a => a -> Heap a -> Heap a unsafeInsertMin x h = L 1 x h E unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a unsafeAppend E h = h unsafeAppend (L _ y a b) h = node y a (unsafeAppend b h) filterLT :: Ord a => a -> Heap a -> Heap a filterLT y (L _ x a b) | x < y = node x (filterLT y a) (filterLT y b) filterLT _ _ = E filterLE :: Ord a => a -> Heap a -> Heap a filterLE y (L _ x a b) | x <= y = node x (filterLE y a) (filterLE y b) filterLE _ _ = E filterGT :: Ord a => a -> Heap a -> Heap a filterGT y h = C.unionList (collect h []) where collect E hs = hs collect h@(L _ x a b) hs | x > y = h : hs | otherwise = collect a (collect b hs) filterGE :: Ord a => a -> Heap a -> Heap a filterGE y h = C.unionList (collect h []) where collect E hs = hs collect h@(L _ x a b) hs | x >= y = h : hs | otherwise = collect b (collect a hs) partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GE y h = (h', C.unionList hs) where (h', hs) = collect h [] collect E hs = (E, hs) collect h@(L _ x a b) hs | x >= y = (E, h:hs) | otherwise = let (a', hs') = collect a hs (b', hs'') = collect b hs' in (node x a' b', hs'') partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLE_GT y h = (h', C.unionList hs) where (h', hs) = collect h [] collect E hs = (E, hs) collect h@(L _ x a b) hs | x > y = (E, h:hs) | otherwise = let (a', hs') = collect a hs (b', hs'') = collect b hs' in (node x a' b', hs'') partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GT y h = (h', C.unionList hs) where (h', hs) = collect h [] collect E hs = (E, hs) collect h@(L _ x a b) is = case compare x y of GT -> (E, h:is) EQ -> let (a', hs') = collect a is (b', hs'') = collect b hs' in (union a' b', hs'') LT -> let (a', hs') = collect a is (b', hs'') = collect b hs' in (node x a' b', hs'') minView :: (Ord a, Monad m) => Heap a -> m (a, Heap a) minView E = fail "LeftistHeap.minView: empty collection" minView (L _ x a b) = return (x, union a b) minElem :: Ord a => Heap a -> a minElem E = error "LeftistHeap.minElem: empty collection" minElem (L _ x _ _) = x maxView :: (Ord a, Monad m) => Heap a -> m (a, Heap a) maxView E = fail "LeftistHeap.maxView: empty collection" maxView (L _ x E _) = return (x, E) maxView (L _ x a E) = return (y, L 1 x a' E) where Just (y,a') = maxView a maxView (L _ x a b) | y >= z = return (y, node x a' b) | otherwise = return (z, node x a b') where Just (y, a') = maxView a Just (z, b') = maxView b -- warning: maxView and maxElem may disagree if root is equal to max! maxElem :: Ord a => Heap a -> a maxElem E = error "LeftistHeap.maxElem: empty collection" maxElem (L _ x E _) = x maxElem (L _ _ a b) = findMax b (findLeaf a) where findMax E m = m findMax (L _ x E _) m | m >= x = m | otherwise = x findMax (L _ _ d c) m = findMax d (findMax c m) findLeaf E = error "LeftistHeap.maxElem: bug" findLeaf (L _ x E _) = x findLeaf (L _ _ y c) = findMax c (findLeaf y) foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldr _ e E = e foldr f e (L _ x a b) = f x (foldr f e (union a b)) foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldr' _ e E = e foldr' f e (L _ x a b) = e `seq` f x $! (foldr' f e (union a b)) foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldl _ e E = e foldl f e (L _ x a b) = foldl f (f e x) (union a b) foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldl' _ e E = e foldl' f e (L _ x a b) = e `seq` foldl' f (f e x) (union a b) foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a foldr1 _ E = error "LeftistHeap.foldr1: empty collection" foldr1 _ (L _ x E _) = x foldr1 f (L _ x a b) = f x (foldr1 f (union a b)) foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a foldr1' _ E = error "LeftistHeap.foldr1': empty collection" foldr1' _ (L _ x E _) = x foldr1' f (L _ x a b) = f x $! (foldr1' f (union a b)) foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a foldl1 _ E = error "LeftistHeap.foldl1: empty collection" foldl1 f (L _ x a b) = foldl f x (union a b) foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a foldl1' _ E = error "LeftistHeap.foldl1: empty collection" foldl1' f (L _ x a b) = foldl' f x (union a b) {- ???? -} unsafeMapMonotonic :: Ord a => (a -> a) -> Heap a -> Heap a unsafeMapMonotonic _ E = E unsafeMapMonotonic f (L i x a b) = L i (f x) (unsafeMapMonotonic f a) (unsafeMapMonotonic f b) -- all fields are already fully strict! strict :: Heap a -> Heap a strict h = h strictWith :: (a -> b) -> Heap a -> Heap a strictWith _ h@E = h strictWith f h@(L _ x l r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h -- the remaining functions all use default definitions fromSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a fromSeq = fromSeqUsingUnionSeq insertSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a insertSeq = insertSeqUsingUnion unionSeq :: (Ord a,S.Sequence seq) => seq (Heap a) -> Heap a unionSeq = unionSeqUsingReduce deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a -> Heap a deleteSeq = deleteSeqUsingDelete lookup :: Ord a => a -> Heap a -> a lookup = lookupUsingLookupM lookupWithDefault :: Ord a => a -> a -> Heap a -> a lookupWithDefault = lookupWithDefaultUsingLookupM unsafeInsertMax :: Ord a => a -> Heap a -> Heap a unsafeInsertMax = unsafeInsertMaxUsingUnsafeAppend unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Heap a unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin toOrdSeq :: (Ord a,S.Sequence seq) => Heap a -> seq a toOrdSeq = toOrdSeqUsingFoldr -- instance declarations instance Ord a => C.CollX (Heap a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Ord a => C.OrdCollX (Heap a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance Ord a => C.Coll (Heap a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance Ord a => C.OrdColl (Heap a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} instance Ord a => Eq (Heap a) where xs == ys = C.toOrdList xs == C.toOrdList ys instance (Ord a, Show a) => Show (Heap a) where showsPrec = showsPrecUsingToList instance (Ord a, Read a) => Read (Heap a) where readsPrec = readsPrecUsingFromList instance (Ord a, Arbitrary a) => Arbitrary (Heap a) where arbitrary = sized (\n -> arbTree n) where arbTree 0 = return E arbTree n = frequency [(1, return E), (4, liftM3 snode arbitrary (arbTree (n `div` 2)) (arbTree (n `div` 4)))] snode x a b = sift (node x a b) sift E = E sift t@(L _ x a E) | a == E || x <= minElem a = t sift (L r x (L r' y a b) E) = L r y (sift (L r' x a b)) E sift t@(L _ x a b) | x <= minElem a && x <= minElem b = t sift (L r x (L r' y a b) c) | y <= minElem c = L r y (sift (L r' x a b)) c sift (L r x a (L r' y b c)) = L r y a (sift (L r' x b c)) sift _ = error "LeftistHeap.arbitrary: bug!" instance (Ord a, CoArbitrary a) => CoArbitrary (Heap a) where coarbitrary E = variant 0 coarbitrary (L _ x a b) = variant 1 . coarbitrary x . coarbitrary a . coarbitrary b instance (Ord a) => 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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/SplayHeap.hs0000644000000000000000000003632213223626550020102 0ustar0000000000000000-- | -- Module : Data.Edison.Coll.SplayHeap -- Copyright : Copyright (c) 1999, 2008 Chris Okasaki -- License : MIT; see COPYRIGHT file for terms and conditions -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- Splay heaps. -- -- If 'minElem' is called frequently, then SplayHeap should -- be used in conjunction with "Data.Edison.Coll.MinHeap". -- -- /References:/ -- -- * Chris Okasaki. /Purely Functional Data Structures/. 1998. -- Section 5.4. module Data.Edison.Coll.SplayHeap ( -- * Type of splay heaps Heap, -- instance of Coll/CollX, OrdColl/OrdCollX -- * CollX operations empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, deleteSeq,null,size,member,count,strict,structuralInvariant, -- * Coll operations toSeq, lookup, lookupM, lookupAll, lookupWithDefault, fold, fold', fold1, fold1', filter, partition, strictWith, -- * OrdCollX operations deleteMin,deleteMax,unsafeInsertMin,unsafeInsertMax,unsafeFromOrdSeq, unsafeAppend,filterLT,filterLE,filterGT,filterGE,partitionLT_GE, partitionLE_GT,partitionLT_GT, -- * OrdColl operations minView,minElem,maxView,maxElem,foldr,foldr',foldl,foldl', foldr1,foldr1',foldl1,foldl1',toOrdSeq, unsafeMapMonotonic, -- * Documentation moduleName ) where import Prelude hiding (null,foldr,foldl,foldr1,foldl1,lookup,filter) import qualified Data.Edison.Coll as C import qualified Data.Edison.Seq as S import Data.Edison.Coll.Defaults import Data.Monoid import Data.Semigroup as SG import Control.Monad import Test.QuickCheck moduleName :: String moduleName = "Data.Edison.Coll.SplayHeap" data Heap a = E | T (Heap a) a (Heap a) -- invariants: -- * Binary Search Tree order (allowing duplicates) structuralInvariant :: Ord a => Heap a -> Bool structuralInvariant t = bounded Nothing Nothing t where bounded _ _ E = True bounded lo hi (T l x r) = cmp_l lo x && cmp_r x hi && bounded lo (Just x) l && bounded (Just x) hi r cmp_l Nothing _ = True cmp_l (Just x) y = x <= y cmp_r _ Nothing = True cmp_r x (Just y) = x <= y empty :: Heap a singleton :: a -> Heap a fromSeq :: (Ord a,S.Sequence s) => s a -> Heap a insert :: Ord a => a -> Heap a -> Heap a insertSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a union :: Ord a => Heap a -> Heap a -> Heap a unionSeq :: (Ord a,S.Sequence s) => s (Heap a) -> Heap a delete :: Ord a => a -> Heap a -> Heap a deleteAll :: Ord a => a -> Heap a -> Heap a deleteSeq :: (Ord a,S.Sequence s) => s a -> Heap a -> Heap a null :: Heap a -> Bool size :: Heap a -> Int member :: Ord a => a -> Heap a -> Bool count :: Ord a => a -> Heap a -> Int strict :: Heap a -> Heap a toSeq :: (Ord a, S.Sequence s) => Heap a -> s a lookup :: Ord a => a -> Heap a -> a lookupM :: (Ord a,Monad m) => a -> Heap a -> m a lookupAll :: (Ord a,S.Sequence s) => a -> Heap a -> s a lookupWithDefault :: Ord a => a -> a -> Heap a -> a fold :: Ord a => (a -> b -> b) -> b -> Heap a -> b fold1 :: Ord a => (a -> a -> a) -> Heap a -> a fold' :: Ord a => (a -> b -> b) -> b -> Heap a -> b fold1' :: Ord a => (a -> a -> a) -> Heap a -> a filter :: Ord a => (a -> Bool) -> Heap a -> Heap a partition :: Ord a => (a -> Bool) -> Heap a -> (Heap a, Heap a) strictWith :: (a -> b) -> Heap a -> Heap a deleteMin :: Ord a => Heap a -> Heap a deleteMax :: Ord a => Heap a -> Heap a unsafeInsertMin :: Ord a => a -> Heap a -> Heap a unsafeInsertMax :: Ord a => a -> Heap a -> Heap a unsafeFromOrdSeq :: (Ord a,S.Sequence s) => s a -> Heap a unsafeAppend :: Ord a => Heap a -> Heap a -> Heap a filterLT :: Ord a => a -> Heap a -> Heap a filterLE :: Ord a => a -> Heap a -> Heap a filterGT :: Ord a => a -> Heap a -> Heap a filterGE :: Ord a => a -> Heap a -> Heap a partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLE_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) partitionLT_GT :: Ord a => a -> Heap a -> (Heap a, Heap a) minView :: (Ord a,Monad m) => Heap a -> m (a, Heap a) minElem :: Ord a => Heap a -> a maxView :: (Ord a,Monad m) => Heap a -> m (a, Heap a) maxElem :: Ord a => Heap a -> a foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldl :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldr1 :: Ord a => (a -> a -> a) -> Heap a -> a foldl1 :: Ord a => (a -> a -> a) -> Heap a -> a foldr' :: Ord a => (a -> b -> b) -> b -> Heap a -> b foldl' :: Ord a => (b -> a -> b) -> b -> Heap a -> b foldr1' :: Ord a => (a -> a -> a) -> Heap a -> a foldl1' :: Ord a => (a -> a -> a) -> Heap a -> a toOrdSeq :: (Ord a,S.Sequence s) => Heap a -> s a unsafeMapMonotonic :: (a -> b) -> Heap a -> Heap b empty = E singleton x = T E x E insert x xs = T a x b where (a,b) = partitionLE_GT x xs union E ys = ys union (T a x b) ys = T (union c a) x (union d b) where (c,d) = partitionLE_GT x ys delete x xs = let (a,b) = partitionLE_GT x xs in case maxView a of Nothing -> b Just (y, a') | x > y -> T a' y b | otherwise -> unsafeAppend a' b deleteAll x xs = unsafeAppend a b where (a,b) = partitionLT_GT x xs null E = True null (T _ _ _) = False size = sz 0 where sz n E = n sz n (T a _ b) = sz (sz (1+n) a) b member _ E = False member x (T a y b) = if x < y then member x a else x==y || member x b count = cnt 0 where cnt n _ E = n cnt n x (T a y b) | x < y = cnt n x a | x > y = cnt n x b | otherwise = cnt (cnt (1+n) x a) x b toSeq xs = tos xs S.empty where tos E rest = rest tos (T a x b) rest = S.lcons x (tos a (tos b rest)) lookup _ E = error "SplayHeap.lookup: empty heap" lookup x (T a y b) | x < y = lookup x a | x > y = lookup x b | otherwise = y lookupM _ E = fail "SplayHeap.lookup: empty heap" lookupM x (T a y b) | x < y = lookupM x a | x > y = lookupM x b | otherwise = return y lookupWithDefault d _ E = d lookupWithDefault d x (T a y b) | x < y = lookupWithDefault d x a | x > y = lookupWithDefault d x b | otherwise = y lookupAll x xs = look xs x S.empty where look E _ rest = rest look (T a y b) x rest | x < y = look a x rest | x > y = look b x rest | otherwise = look a x (S.lcons y (look b x rest)) fold _ e E = e fold f e (T a x b) = f x (fold f (fold f e b) a) fold' _ e E = e fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a) fold1 _ E = error "SplayHeap.fold1: empty heap" fold1 f (T a x b) = fold f (fold f x b) a fold1' _ E = error "SplayHeap.fold1': empty heap" fold1' f (T a x b) = fold' f (fold' f x b) a filter _ E = E filter p (T a x b) | p x = T (filter p a) x (filter p b) | otherwise = unsafeAppend (filter p a) (filter p b) partition _ E = (E, E) partition p (T a x b) | p x = (T a0 x b0, unsafeAppend a1 b1) | otherwise = (unsafeAppend a0 b0, T a1 x b1) where (a0,a1) = partition p a (b0,b1) = partition p b deleteMin E = E deleteMin (T a x b) = del a x b where del E _ b = b del (T E _ b) y c = T b y c del (T (T a x b) y c) z d = T (del a x b) y (T c z d) deleteMax E = E deleteMax (T a x b) = del a x b where del a _ E = a del a x (T b _ E) = T a x b del a x (T b y (T c z d)) = T (T a x b) y (del c z d) unsafeInsertMin x xs = T E x xs unsafeInsertMax x xs = T xs x E unsafeAppend a b = case maxView a of Nothing -> b Just (x, a') -> T a' x b filterLT _ E = E filterLT k t@(T a x b) = if x >= k then filterLT k a else case b of E -> t T ba y bb -> if y >= k then T a x (filterLT k ba) else T (T a x ba) y (filterLT k bb) filterLE _ E = E filterLE k t@(T a x b) = if x > k then filterLE k a else case b of E -> t T ba y bb -> if y > k then T a x (filterLE k ba) else T (T a x ba) y (filterLE k bb) filterGT _ E = E filterGT k t@(T a x b) = if x <= k then filterGT k b else case a of E -> t T aa y ab -> if y <= k then T (filterGT k ab) x b else T (filterGT k aa) y (T ab x b) filterGE _ E = E filterGE k t@(T a x b) = if x < k then filterGE k b else case a of E -> t T aa y ab -> if y < k then T (filterGE k ab) x b else T (filterGE k aa) y (T ab x b) partitionLT_GE _ E = (E,E) partitionLT_GE k t@(T a x b) = if x >= k then case a of E -> (E,t) T aa y ab -> if y >= k then let (small,big) = partitionLT_GE k aa in (small, T big y (T ab x b)) else let (small,big) = partitionLT_GE k ab in (T aa y small, T big x b) else case b of E -> (t,E) T ba y bb -> if y >= k then let (small,big) = partitionLT_GE k ba in (T a x small, T big y bb) else let (small,big) = partitionLT_GE k bb in (T (T a x ba) y small, big) partitionLE_GT _ E = (E,E) partitionLE_GT k t@(T a x b) = if x > k then case a of E -> (E,t) T aa y ab -> if y > k then let (small,big) = partitionLE_GT k aa in (small, T big y (T ab x b)) else let (small,big) = partitionLE_GT k ab in (T aa y small, T big x b) else case b of E -> (t,E) T ba y bb -> if y > k then let (small,big) = partitionLE_GT k ba in (T a x small, T big y bb) else let (small,big) = partitionLE_GT k bb in (T (T a x ba) y small, big) -- could specialize calls to filterLT/filterGT partitionLT_GT _ E = (E,E) partitionLT_GT k t@(T a x b) = if x > k then case a of E -> (E,t) T aa y ab -> if y > k then let (small,big) = partitionLT_GT k aa in (small, T big y (T ab x b)) else if y < k then let (small,big) = partitionLT_GT k ab in (T aa y small, T big x b) else (filterLT k aa, T (filterGT k ab) x b) else if x < k then case b of E -> (t,E) T ba y bb -> if y > k then let (small,big) = partitionLT_GT k ba in (T a x small, T big y bb) else if y < k then let (small,big) = partitionLT_GT k bb in (T (T a x ba) y small, big) else (T a x (filterLT k ba), filterGT k bb) else (filterLT k a, filterGT k b) minView E = fail "SplayHeap.minView: empty heap" minView (T a x b) = return (y, ys) where (y,ys) = minv a x b minv E x b = (x,b) minv (T E x b) y c = (x,T b y c) minv (T (T a x b) y c) z d = (w,T ab y (T c z d)) where (w,ab) = minv a x b minElem E = error "SplayHeap.minElem: empty heap" minElem (T a x _) = minel a x where minel E x = x minel (T a x _) _ = minel a x maxView E = fail "SplayHeap.maxView: empty heap" maxView (T a x b) = return (y,ys) where (ys,y) = maxv a x b maxv a x E = (a,x) maxv a x (T b y E) = (T a x b,y) maxv a x (T b y (T c z d)) = (T (T a x b) y cd,w) where (cd,w) = maxv c z d maxElem E = error "SplayHeap.minElem: empty heap" maxElem (T _ x b) = maxel x b where maxel x E = x maxel _ (T _ x b) = maxel x b foldr _ e E = e foldr f e (T a x b) = foldr f (f x (foldr f e b)) a foldr' _ e E = e foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a foldl _ e E = e foldl f e (T a x b) = foldl f (f (foldl f e a) x) b foldl' _ e E = e foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b foldr1 _ E = error "SplayHeap.foldr1: empty heap" foldr1 f (T a x b) = foldr f (myfold f x b) a where myfold _ x E = x myfold f x (T a y b) = f x (foldr f (myfold f y b) a) foldr1' _ E = error "SplayHeap.foldr1': empty heap" foldr1' f (T a x b) = foldr' f (myfold f x b) a where myfold _ x E = x myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a) foldl1 _ E = error "SplayHeap.foldl1: empty heap" foldl1 f (T a x b) = foldl f (myfold f a x) b where myfold _ E x = x myfold f (T a x b) y = f (foldl f (myfold f a x) b) y foldl1' _ E = error "SplayHeap.foldl1': empty heap" foldl1' f (T a x b) = foldl' f (myfold f a x) b where myfold _ E x = x myfold f (T a x b) y = (f $! (foldl f (myfold f a x) b)) y toOrdSeq xs = tos xs S.empty where tos E rest = rest tos (T a x b) rest = tos a (S.lcons x (tos b rest)) unsafeMapMonotonic _ E = E unsafeMapMonotonic f (T a x b) = T (unsafeMapMonotonic f a) (f x) (unsafeMapMonotonic f b) strict h@E = h strict h@(T l _ r) = strict l `seq` strict r `seq` h strictWith _ h@E = h strictWith f h@(T l x r) = f x `seq` strictWith f l `seq` strictWith f r `seq` h -- the remaining functions all use defaults fromSeq = fromSeqUsingFoldr insertSeq = insertSeqUsingFoldr unionSeq = unionSeqUsingReduce deleteSeq = deleteSeqUsingDelete unsafeFromOrdSeq = unsafeFromOrdSeqUsingUnsafeInsertMin -- instance declarations instance Ord a => C.CollX (Heap a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance Ord a => C.OrdCollX (Heap a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance Ord a => C.Coll (Heap a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; strictWith = strictWith; filter = filter; partition = partition} instance Ord a => C.OrdColl (Heap a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} instance Ord a => Eq (Heap a) where xs == ys = C.toOrdList xs == C.toOrdList ys instance (Ord a, Show a) => Show (Heap a) where showsPrec = showsPrecUsingToList instance (Ord a, Read a) => Read (Heap a) where readsPrec = readsPrecUsingFromList instance (Ord a,Arbitrary a) => Arbitrary (Heap a) where arbitrary = do xs <- arbitrary return (C.fromList xs) instance (Ord a,CoArbitrary a) => CoArbitrary (Heap a) where coarbitrary E = variant 0 coarbitrary (T a x b) = variant 1 . coarbitrary a . coarbitrary x . coarbitrary b instance (Ord a) => 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 EdisonCore-1.3.2.1/src/Data/Edison/Coll/EnumSet.hs0000644000000000000000000006473413223626550017604 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Edison.Coll.EnumSet -- Copyright : (c) David F. Place 2006 -- License : BSD -- -- Maintainer : robdockins AT fastmail DOT fm -- Stability : stable -- Portability : GHC, Hugs (MPTC and FD) -- -- An efficient implementation of sets over small enumerations. -- The implementation of 'EnumSet' is based on bit-wise operations. -- -- For this implementation to work as expected at type @A@, there are a number -- of preconditions on the @Eq@, @Enum@ and @Ord@ instances. -- -- The @Enum A@ instance must create a bijection between the elements of type @A@ and -- a finite subset of the naturals [0,1,2,3....]. As a corollary we must have: -- -- > forall x y::A, fromEnum x == fromEnum y <==> x is indistinguishable from y -- -- Also, the number of distinct elements of @A@ must be less than or equal -- to the number of bits in @Word@. -- -- The @Enum A@ instance must be consistent with the @Eq A@ instance. -- That is, we must have: -- -- > forall x y::A, x == y <==> toEnum x == toEnum y -- -- Additionally, for operations that require an @Ord A@ context, we require that -- toEnum be monotonic with respect to comparison. That is, we must have: -- -- > forall x y::A, x < y <==> toEnum x < toEnum y -- -- Derived @Eq@, @Ord@ and @Enum@ instances will fulfill these conditions, if -- the enumerated type has sufficently few constructors. {- Copyright (c) 2006, 2008, David F. Place All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of David F. Place nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} module Data.Edison.Coll.EnumSet ( -- * Set type Set -- * CollX operations , empty , singleton , fromSeq , insert , insertSeq , union , unionSeq , delete , deleteAll , deleteSeq , null , size , member , count , strict -- * OrdCollX operations , deleteMin , deleteMax , unsafeInsertMin , unsafeInsertMax , unsafeFromOrdSeq , unsafeAppend , filterLT , filterLE , filterGT , filterGE , partitionLT_GE , partitionLE_GT , partitionLT_GT -- * SetX operations , intersection , difference , symmetricDifference , properSubset , subset -- * Coll operations , toSeq , lookup , lookupM , lookupAll , lookupWithDefault , fold, fold', fold1, fold1' , filter , partition , strictWith -- * OrdColl operations , minView , minElem , maxView , maxElem , foldr, foldr', foldl, foldl' , foldr1, foldr1', foldl1, foldl1' , toOrdSeq , unsafeMapMonotonic -- * Set operations , fromSeqWith , fromOrdSeq , insertWith , insertSeqWith , unionl , unionr , unionWith , unionSeqWith , intersectionWith -- * Bonus operations , map , setCoerce , complement , toBits , fromBits -- * Documenation , moduleName ) where import qualified Prelude import Prelude hiding (filter,foldl,foldr,null,map,lookup,foldl1,foldr1) import qualified Data.Bits as Bits import Data.Bits hiding (complement) import Data.Word import Data.Monoid (Monoid(..)) import 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, Monad m) => a -> Set a -> m a lookupM x s | member x s = return x | otherwise = fail (moduleName++".lookupM: lookup failed") lookupAll :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a lookupAll = lookupAllUsingLookupM lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a lookupWithDefault = lookupWithDefaultUsingLookupM {-------------------------------------------------------------------- Construction --------------------------------------------------------------------} -- | /O(1)/. The empty set. empty :: Set a empty = Set 0 -- | /O(1)/. Create a singleton set. singleton :: (Eq a, Enum a) => a -> Set a singleton x = Set $ setBit 0 $ check "singleton" $ fromEnum x {-------------------------------------------------------------------- Insertion, Deletion --------------------------------------------------------------------} -- | /O(1)/. Insert an element in a set. -- If the set already contains an element equal to the given value, -- it is replaced with the new value. insert :: (Eq a, Enum a) => a -> Set a -> Set a insert x (Set w) = Set $ setBit w $ check "insert" $ fromEnum x -- given the preconditions, we can just ignore the combining function insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a insertWith _ x (Set w) = Set $ setBit w $ check "insertWith" $ fromEnum x -- | /O(1)/. Delete an element from a set. delete :: (Eq a, Enum a) => a -> Set a -> Set a delete x (Set w) = Set $ clearBit w $ fromEnum x deleteAll :: (Eq a, Enum a) => a -> Set a -> Set a deleteAll = delete deleteSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a deleteSeq = deleteSeqUsingDelete {-------------------------------------------------------------------- Subset --------------------------------------------------------------------} -- | /O(1)/. Is this a proper subset? (ie. a subset but not equal). properSubset :: Set a -> Set a -> Bool properSubset x y = (x /= y) && (subset x y) -- | /O(1)/. Is this a subset? -- @(s1 `subset` s2)@ tells whether @s1@ is a subset of @s2@. subset :: Set a -> Set a -> Bool subset x y = (x `union` y) == y {-------------------------------------------------------------------- Minimal, Maximal --------------------------------------------------------------------} -- | /O(1)/. The minimal element of a set. minElem :: (Enum a) => Set a -> a minElem (Set w) | w == 0 = error $ moduleName++".minElem: empty set" | otherwise = toEnum $ lsb w -- | /O(1)/. The maximal element of a set. maxElem :: (Enum a) => Set a -> a maxElem (Set w) | w == 0 = error $ moduleName++".maxElem: empty set" | otherwise = toEnum $ msb w -- | /O(1)/. Delete the minimal element. deleteMin :: (Enum a) => Set a -> Set a deleteMin (Set w) | w == 0 = empty | otherwise = Set $ clearBit w $ lsb w -- | /O(1)/. Delete the maximal element. deleteMax :: (Enum a) => Set a -> Set a deleteMax (Set w) | w == 0 = empty | otherwise = Set $ clearBit w $ msb w minView :: (Enum a, Monad m) => Set a -> m (a, Set a) minView (Set w) | w == 0 = fail (moduleName++".minView: empty set") | otherwise = let i = lsb w in return (toEnum i,Set $ clearBit w i) maxView :: (Enum a, Monad m) => Set a -> m (a, Set a) maxView (Set w) | w == 0 = fail (moduleName++".maxView: empty set") | otherwise = let i = msb w in return (toEnum i, Set $ clearBit w i) unsafeInsertMin :: (Ord a, Enum a) => a -> Set a -> Set a unsafeInsertMin = insert unsafeInsertMax :: (Ord a, Enum a) => a -> Set a -> Set a unsafeInsertMax = insert unsafeAppend :: (Ord a, Enum a) => Set a -> Set a -> Set a unsafeAppend = union unsafeFromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a unsafeFromOrdSeq = fromSeq filterLT :: (Ord a, Enum a) => a -> Set a -> Set a filterLT x (Set w) = Set (w .&. lowMask (fromEnum x)) filterLE :: (Ord a, Enum a) => a -> Set a -> Set a filterLE x (Set w) = Set (w .&. lowMask (fromEnum x + 1)) filterGT :: (Ord a, Enum a) => a -> Set a -> Set a filterGT x (Set w) = Set (w .&. highMask (fromEnum x + 1)) filterGE :: (Ord a, Enum a) => a -> Set a -> Set a filterGE x (Set w) = Set (w .&. highMask (fromEnum x)) partitionLT_GE :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a) partitionLT_GE x s = (filterLT x s,filterGE x s) partitionLE_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a) partitionLE_GT x s = (filterLE x s,filterGT x s) partitionLT_GT :: (Ord a, Enum a) => a -> Set a -> (Set a, Set a) partitionLT_GT x s = (filterLT x s,filterGT x s) {-------------------------------------------------------------------- Union. --------------------------------------------------------------------} -- | The union of a list of sets: (@'unions' == 'foldl' 'union' 'empty'@). unionSeq :: (Eq a, Enum a, S.Sequence s) => s (Set a) -> Set a unionSeq = unionSeqUsingFoldl' -- | /O(1)/. The union of two sets. union :: Set a -> Set a -> Set a union (Set x) (Set y) = Set $ x .|. y unionl :: Set a -> Set a -> Set a unionl = union unionr :: Set a -> Set a -> Set a unionr = union -- given the preconditions, we can just ignore the combining function unionWith :: (a -> a -> a) -> Set a -> Set a -> Set a unionWith _ = union unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a unionSeqWith _ = unionSeq {-------------------------------------------------------------------- Difference --------------------------------------------------------------------} -- | /O(1)/. Difference of two sets. difference :: Set a -> Set a -> Set a difference (Set x) (Set y) = Set $ (x .|. y) `xor` y symmetricDifference :: Set a -> Set a -> Set a symmetricDifference (Set x) (Set y) = Set $ x `xor` y {-------------------------------------------------------------------- Intersection --------------------------------------------------------------------} -- | /O(1)/. The intersection of two sets. intersection :: Set a -> Set a -> Set a intersection (Set x) (Set y) = Set $ x .&. y intersectionWith :: (a -> a -> a) -> Set a -> Set a -> Set a intersectionWith _ = intersection {-------------------------------------------------------------------- Complement --------------------------------------------------------------------} -- | /O(1)/. The complement of a set with its universe set. @complement@ can be used -- with bounded types for which the universe set -- will be automatically created. complement :: (Eq a, Bounded a, Enum a) => Set a -> Set a complement x = symmetricDifference u x where u = (fromSeq [minBound .. maxBound]) `asTypeOf` x {-------------------------------------------------------------------- Filter and partition --------------------------------------------------------------------} -- | /O(n)/. Filter all elements that satisfy the predicate. filter :: (Eq a, Enum a) => (a -> Bool) -> Set a -> Set a filter p (Set w) = Set $ foldlBits' f 0 w where f z i | p $ toEnum i = setBit z i | otherwise = z -- | /O(n)/. Partition the set into two sets, one with all elements that satisfy -- the predicate and one with all elements that don't satisfy the predicate. -- See also 'split'. partition :: (Eq a, Enum a) => (a -> Bool) -> Set a -> (Set a,Set a) partition p (Set w) = (Set yay,Set nay) where (yay,nay) = foldlBits' f (0,0) w f (x,y) i | p $ toEnum i = (setBit x i,y) | otherwise = (x,setBit y i) {---------------------------------------------------------------------- Map ----------------------------------------------------------------------} -- | /O(n)/. -- @'map' f s@ is the set obtained by applying @f@ to each element of @s@. -- -- It's worth noting that the size of the result may be smaller if, -- for some @(x,y)@, @x \/= y && f x == f y@ map :: (Enum a,Enum b) => (a -> b) -> Set a -> Set b map f0 (Set w) = Set $ foldlBits' f 0 w where f z i = setBit z $ check "map" $ fromEnum $ f0 (toEnum i) unsafeMapMonotonic :: (Enum a) => (a -> a) -> Set a -> Set a unsafeMapMonotonic = map -- | /O(1)/ Changes the type of the elements in the set without changing -- the representation. Equivalant to @map (toEnum . fromEnum)@, and -- to @(fromBits . toBits)@. This method is operationally a no-op. setCoerce :: (Enum a, Enum b) => Set a -> Set b setCoerce (Set w) = Set w -- | /O(1)/ Get the underlying bit-encoded representation. -- This method is operationally a no-op. toBits :: Set a -> Word toBits (Set w) = w -- | /O(1)/ Create an EnumSet from a bit-encoded representation. -- This method is operationally a no-op. fromBits :: Word -> Set a fromBits w = Set w {-------------------------------------------------------------------- Fold --------------------------------------------------------------------} fold :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c fold f z (Set w) = foldrBits folder z w where folder i = f (toEnum i) fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c fold' f z (Set w) = foldrBits' folder z w where folder i = f (toEnum i) fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a fold1 _ (Set 0) = error (moduleName++".fold1: empty set") fold1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) where maxi = msb w folder i z = f (toEnum i) z fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a fold1' _ (Set 0) = error (moduleName++".fold1': empty set") fold1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) where maxi = msb w folder i z = f (toEnum i) z foldr :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b foldr f z (Set w) = foldrBits folder z w where folder i = f (toEnum i) foldr' :: (Ord a, Enum a) => (a -> b -> b) -> b -> Set a -> b foldr' f z (Set w) = foldrBits' folder z w where folder i j = f (toEnum i) j foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a foldr1 _ (Set 0) = error (moduleName ++ ".foldr1: empty set") foldr1 f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) where maxi = msb w folder i z = f (toEnum i) z foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a foldr1' _ (Set 0) = error (moduleName++".foldr1': empty set") foldr1' f (Set w) = foldrBits folder (toEnum maxi) (clearBit w maxi) where maxi = msb w folder i z = f (toEnum i) z foldl :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c foldl f z (Set w) = foldlBits folder z w where folder h i = f h (toEnum i) foldl' :: (Ord a, Enum a) => (c -> a -> c) -> c -> Set a -> c foldl' f z (Set w) = foldlBits' folder z w where folder h i = f h (toEnum i) foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a foldl1 _ (Set 0) = error (moduleName++".foldl1: empty set") foldl1 f (Set w) = foldlBits folder (toEnum mininum) (clearBit w mininum) where mininum = lsb w folder z i = f z (toEnum i) foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a foldl1' _ (Set 0) = error (moduleName++".foldl1': empty set") foldl1' f (Set w) = foldlBits' folder (toEnum mininum) (clearBit w mininum) where mininum = lsb w folder z i = f z (toEnum i) {-------------------------------------------------------------------- Lists --------------------------------------------------------------------} fromSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a fromSeq xs = Set $ S.fold' f 0 xs where f x z = setBit z $ check "fromSeq" $ fromEnum x fromOrdSeq :: (Ord a, Enum a, S.Sequence s) => s a -> Set a fromOrdSeq = fromSeq insertSeq :: (Eq a, Enum a, S.Sequence s) => s a -> Set a -> Set a insertSeq = insertSeqUsingUnion -- given the preconditions, we can just ignore the combining function insertSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a -> Set a insertSeqWith _ = insertSeq toSeq :: (Eq a, Enum a, S.Sequence s) => Set a -> s a toSeq (Set w) = foldrBits f S.empty w where f i z = S.lcons (toEnum i) z toOrdSeq :: (Ord a, Enum a, S.Sequence s) => Set a -> s a toOrdSeq = toSeq fromSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s a -> Set a fromSeqWith = fromSeqWithUsingInsertWith {-------------------------------------------------------------------- Split --------------------------------------------------------------------} {- splitMember :: (Ord a, Enum a) => a -> Set a -> (Set a,Bool,Set a) splitMember x (Set w) = (Set lesser,isMember,Set greater) where (lesser,isMember,greater) = foldrBits f (0,False,0) w f i (lesser,isMember,greater) = case compare (toEnum i) x of GT -> (lesser,isMember,setBit greater i) LT -> (setBit lesser i,isMember,greater) EQ -> (lesser,True,greater) -} {---------------------------------------------------------------- Strictness enhancement ----------------------------------------------------------------} strict :: Set a -> Set a strict s@(Set w) = w `seq` s strictWith :: (a -> b) -> Set a -> Set a strictWith _ s@(Set w) = w `seq` s {-------------------------------------------------------------------- Utility functions. --------------------------------------------------------------------} foldrBits :: (Int -> a -> a) -> a -> Word -> a foldrBits f z w = foldrBits_aux f z 0 w foldrBits_aux :: (Int -> a -> a) -> a -> Int -> Word -> a foldrBits_aux _ z _ 0 = z foldrBits_aux f z i w | i `seq` w `seq` False = undefined | otherwise = case w .&. 0x0F of 0x00 -> a 0x01 -> f i $ a 0x02 -> f (i+1) $ a 0x03 -> f i $ f (i+1) $ a 0x04 -> f (i+2) $ a 0x05 -> f i $ f (i+2) $ a 0x06 -> f (i+1) $ f (i+2) $ a 0x07 -> f i $ f (i+1) $ f (i+2) $ a 0x08 -> f (i+3) $ a 0x09 -> f i $ f (i+3) $ a 0x0A -> f (i+1) $ f (i+3) $ a 0x0B -> f i $ f (i+1) $ f (i+3) $ a 0x0C -> f (i+2) $ f (i+3) $ a 0x0D -> f i $ f (i+2) $ f (i+3) $ a 0x0E -> f (i+1) $ f (i+2) $ f (i+3) $ a 0x0F -> f i $ f (i+1) $ f (i+2) $ f (i+3) $ a _ -> error "bug in foldrBits_aux" where a = foldrBits_aux f z (i+4) (Bits.shiftR w 4) foldrBits' :: (Int -> a -> a) -> a -> Word -> a foldrBits' f z w = foldrBits_aux' f z 0 w foldrBits_aux' :: (Int -> a -> a) -> a -> Int -> Word -> a foldrBits_aux' _ z _ 0 = z foldrBits_aux' f z i w | i `seq` w `seq` False = undefined | otherwise = case w .&. 0x0F of 0x00 -> a 0x01 -> f i $! a 0x02 -> f (i+1) $! a 0x03 -> f i $! f (i+1) $! a 0x04 -> f (i+2) $! a 0x05 -> f i $! f (i+2) $! a 0x06 -> f (i+1) $! f (i+2) $! a 0x07 -> f i $! f (i+1) $! f (i+2) $! a 0x08 -> f (i+3) $! a 0x09 -> f i $! f (i+3) $! a 0x0A -> f (i+1) $! f (i+3) $! a 0x0B -> f i $! f (i+1) $! f (i+3) $! a 0x0C -> f (i+2) $! f (i+3) $! a 0x0D -> f i $! f (i+2) $! f (i+3) $! a 0x0E -> f (i+1) $! f (i+2) $! f (i+3) $! a 0x0F -> f i $! f (i+1) $! f (i+2) $! f (i+3) $! a _ -> error "bug in foldrBits_aux'" where a = foldrBits_aux' f z (i+4) (Bits.shiftR w 4) foldlBits :: (a -> Int -> a) -> a -> Word -> a foldlBits f z w = foldlBits_aux f z 0 w foldlBits_aux :: (a -> Int -> a) -> a -> Int -> Word -> a foldlBits_aux _ z _ 0 = z foldlBits_aux f z i w | i `seq` w `seq` False = undefined | otherwise = case w .&. 0x0F of 0x00 -> a $ z 0x01 -> a $ f z i 0x02 -> a $ f z (i+1) 0x03 -> a $ f (f z i) (i+1) 0x04 -> a $ f z (i+2) 0x05 -> a $ f (f z i) (i+2) 0x06 -> a $ f (f z (i+1)) (i+2) 0x07 -> a $ f (f (f z i) (i+1)) (i+2) 0x08 -> a $ f z (i+3) 0x09 -> a $ f (f z i) (i+3) 0x0A -> a $ f (f z (i+1)) (i+3) 0x0B -> a $ f (f (f z i) (i+1)) (i+3) 0x0C -> a $ f (f z (i+2)) (i+3) 0x0D -> a $ f (f (f z i) (i+2)) (i+3) 0x0E -> a $ f (f (f z (i+1)) (i+2)) (i+3) 0x0F -> a $ f (f (f (f z i) (i+1)) (i+2)) (i+3) _ -> error "bug in foldlBits_aux" where a b = foldlBits_aux f b (i + 4) (Bits.shiftR w 4) foldlBits' :: (a -> Int -> a) -> a -> Word -> a foldlBits' f z w = foldlBits_aux' (\x i -> x `seq` f x i) z 0 w foldlBits_aux' :: (a -> Int -> a) -> a -> Int -> Word -> a foldlBits_aux' _ z _ 0 = z foldlBits_aux' f z i w | i `seq` w `seq` False = undefined | otherwise = case w .&. 0x0F of 0x00 -> a $! z 0x01 -> a $! f z i 0x02 -> a $! f z (i+1) 0x03 -> a $! f (f z i) (i+1) 0x04 -> a $! f z (i+2) 0x05 -> a $! f (f z i) (i+2) 0x06 -> a $! f (f z (i+1)) (i+2) 0x07 -> a $! f (f (f z i) (i+1)) (i+2) 0x08 -> a $! f z (i+3) 0x09 -> a $! f (f z i) (i+3) 0x0A -> a $! f (f z (i+1)) (i+3) 0x0B -> a $! f (f (f z i) (i+1)) (i+3) 0x0C -> a $! f (f z (i+2)) (i+3) 0x0D -> a $! f (f (f z i) (i+2)) (i+3) 0x0E -> a $! f (f (f z (i+1)) (i+2)) (i+3) 0x0F -> a $! f (f (f (f z i) (i+1)) (i+2)) (i+3) _ -> error "bug in foldlBits_aux" where a b = foldlBits_aux' f b (i + 4) (Bits.shiftR w 4) instance (Eq a, Enum a) => C.CollX (Set a) a where {singleton = singleton; fromSeq = fromSeq; insert = insert; insertSeq = insertSeq; unionSeq = unionSeq; delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; null = null; size = size; member = member; count = count; strict = strict; structuralInvariant = structuralInvariant; instanceName _ = moduleName} instance (Ord a, Enum a) => C.OrdCollX (Set a) a where {deleteMin = deleteMin; deleteMax = deleteMax; unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; filterGE = filterGE; partitionLT_GE = partitionLT_GE; partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} instance (Eq a, Enum a) => C.SetX (Set a) a where {intersection = intersection; difference = difference; symmetricDifference = symmetricDifference; properSubset = properSubset; subset = subset} instance (Eq a, Enum a) => C.Coll (Set a) a where {toSeq = toSeq; lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; filter = filter; partition = partition; strictWith = strictWith} instance (Ord a, Enum a) => C.OrdColl (Set a) a where {minView = minView; minElem = minElem; maxView = maxView; maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; unsafeMapMonotonic = unsafeMapMonotonic} instance (Eq a, Enum a) => C.Set (Set a) a where {fromSeqWith = fromSeqWith; insertWith = insertWith; insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; unionWith = unionWith; unionSeqWith = unionSeqWith; intersectionWith = intersectionWith} instance (Ord a, Enum a) => C.OrdSetX (Set a) a instance (Ord a, Enum a) => C.OrdSet (Set a) a instance (Eq a, Enum a, Show a) => Show (Set a) where showsPrec = showsPrecUsingToList instance (Eq a, Enum a, Read a) => Read (Set a) where readsPrec = readsPrecUsingFromList instance (Eq a, Enum a, Arbitrary a) => Arbitrary (Set a) where arbitrary = do (w::Int) <- arbitrary return (Set (fromIntegral w)) instance (Eq a, Enum a, CoArbitrary a) => CoArbitrary (Set a) where coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int) instance (Eq a, Enum a) => 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 EdisonCore-1.3.2.1/src/Data/Edison/Concrete/0000755000000000000000000000000013223626550016523 5ustar0000000000000000EdisonCore-1.3.2.1/src/Data/Edison/Concrete/FingerTree.hs0000644000000000000000000010005513223626550021112 0ustar0000000000000000{-# 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) infixr 5 `lcons` infixl 5 `rcons0` data Digit a = One a | Two a a | Three a a a | Four a a a a deriving Show foldDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b foldDigit _ f (One a) = f a foldDigit mapp f (Two a b) = f a `mapp` f b foldDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c foldDigit mapp f (Four a b c d) = f a `mapp` f b `mapp` f c `mapp` f d reduceDigit :: (b -> b -> b) -> (a -> b) -> Digit a -> b reduceDigit _ f (One a) = f a reduceDigit mapp f (Two a b) = f a `mapp` f b reduceDigit mapp f (Three a b c) = f a `mapp` f b `mapp` f c reduceDigit mapp f (Four a b c d) = (f a `mapp` f b) `mapp` (f c `mapp` f d) digitToList :: Digit a -> [a] -> [a] digitToList (One a) xs = a : xs digitToList (Two a b) xs = a : b : xs digitToList (Three a b c) xs = a : b : c : xs digitToList (Four a b c d) xs = a : b : c : d : xs sizeDigit :: (a -> Int) -> Digit a -> Int sizeDigit f (One x) = f x sizeDigit f (Two x y) = f x + f y sizeDigit f (Three x y z) = f x + f y + f z sizeDigit f (Four x y z w) = f x + f y + f z + f w instance (Measured v a) => Measured v (Digit a) where measure = foldDigit mappend measure data Node v a = Node2 !v a a | Node3 !v a a a deriving Show sizeNode :: (a -> Int) -> Node v a -> Int sizeNode f (Node2 _ x y) = f x + f y sizeNode f (Node3 _ x y z) = f x + f y + f z foldNode :: (b -> b -> b) -> (a -> b) -> Node v a -> b foldNode mapp f (Node2 _ a b) = f a `mapp` f b foldNode mapp f (Node3 _ a b c) = f a `mapp` f b `mapp` f c nodeToList :: Node v a -> [a] -> [a] nodeToList (Node2 _ a b) xs = a : b : xs nodeToList (Node3 _ a b c) xs = a : b : c : xs node2 :: (Measured v a) => a -> a -> Node v a node2 a b = Node2 (measure a `mappend` measure b) a b node3 :: (Measured v a) => a -> a -> a -> Node v a node3 a b c = Node3 (measure a `mappend` measure b `mappend` measure c) a b c instance (Monoid v) => Measured v (Node v a) where measure (Node2 v _ _) = v measure (Node3 v _ _ _) = v nodeToDigit :: Node v a -> Digit a nodeToDigit (Node2 _ a b) = Two a b nodeToDigit (Node3 _ a b c) = Three a b c -- | Finger trees with element type @a@, annotated with measures of type @v@. -- The operations enforce the constraint @'Measured' v a@. data FingerTree v a = Empty | Single a | Deep !v !(Digit a) (FingerTree v (Node v a)) !(Digit a) deep :: (Measured v a) => Digit a -> FingerTree v (Node v a) -> Digit a -> FingerTree v a deep pr m sf = Deep ((measure pr `mappendVal` m) `mappend` measure sf) pr m sf structuralInvariant :: (Eq v, Measured v a) => FingerTree v a -> Bool structuralInvariant Empty = True structuralInvariant (Single _) = True structuralInvariant (Deep v pr m sf) = v == foldDigit mappend measure pr `mappend` foldFT mempty mappend (foldNode mappend measure) m `mappend` foldDigit mappend measure sf instance (Measured v a) => Measured v (FingerTree v a) where measure Empty = mempty measure (Single x) = measure x measure (Deep v _ _ _) = v sizeFT :: (a -> Int) -> FingerTree v a -> Int sizeFT _ Empty = 0 sizeFT f (Single x) = f x sizeFT f (Deep _ d1 m d2) = sizeDigit f d1 + sizeFT (sizeNode f) m + sizeDigit f d2 size :: FingerTree v a -> Int size = sizeFT (const 1) foldFT :: b -> (b -> b -> b) -> (a -> b) -> FingerTree v a -> b foldFT mz _ _ Empty = mz foldFT _ _ f (Single x) = f x foldFT mz mapp f (Deep _ pr m sf) = foldDigit mapp f pr `mapp` foldFT mz mapp (foldNode mapp f) m `mapp` foldDigit mapp f sf ftToList :: FingerTree v a -> [a] -> [a] ftToList Empty xs = xs ftToList (Single a) xs = a : xs ftToList (Deep _ d1 ft d2) xs = digitToList d1 (foldr nodeToList [] . ftToList ft $ []) ++ (digitToList d2 xs) toList :: FingerTree v a -> [a] toList ft = ftToList ft [] reduce1_aux :: (b -> b -> b) -> (a -> b) -> Digit a -> FingerTree v (Node v a) -> Digit a -> b reduce1_aux mapp f pr Empty sf = (reduceDigit mapp f pr) `mapp` (reduceDigit mapp f sf) reduce1_aux mapp f pr (Single x) sf = (reduceDigit mapp f pr) `mapp` (foldNode mapp f x) `mapp` (reduceDigit mapp f sf) reduce1_aux mapp f pr (Deep _ pr' m sf') sf = (reduceDigit mapp f pr) `mapp` (reduce1_aux mapp (foldNode mapp f) pr' m sf') `mapp` (reduceDigit mapp f sf) reduce1 :: (a -> a -> a) -> FingerTree v a -> a reduce1 _ Empty = error "FingerTree.reduce1: empty tree" reduce1 _ (Single x) = x reduce1 mapp (Deep _ pr m sf) = reduce1_aux mapp id pr m sf reduce1' :: (a -> a -> a) -> FingerTree v a -> a reduce1' _ Empty = error "FingerTree.reduce1': empty tree" reduce1' _ (Single x) = x reduce1' mapp (Deep _ pr m sf) = reduce1_aux mapp' id pr m sf where mapp' x y = x `seq` y `seq` mapp x y strict :: FingerTree v a -> FingerTree v a strict xs = foldFT () seq (const ()) xs `seq` xs strictWith :: (a -> b) -> FingerTree v a -> FingerTree v a strictWith f xs = foldFT () seq (\x -> f x `seq` ()) xs `seq` xs instance (Measured v a, Eq a) => Eq (FingerTree v a) where xs == ys = toList xs == toList ys instance (Measured v a, Ord a) => Ord (FingerTree v a) where compare xs ys = compare (toList xs) (toList ys) instance (Measured v a, Show a) => Show (FingerTree v a) where showsPrec p xs = showParen (p > 10) $ showString "fromList " . shows (toList xs) mapTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 mapTree _ Empty = Empty mapTree f (Single x) = Single (f x) mapTree f (Deep _ pr m sf) = deep (mapDigit f pr) (mapTree (mapNode f) m) (mapDigit f sf) mapNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2 mapNode f (Node2 _ a b) = node2 (f a) (f b) mapNode f (Node3 _ a b c) = node3 (f a) (f b) (f c) mapDigit :: (a -> b) -> Digit a -> Digit b mapDigit f (One a) = One (f a) mapDigit f (Two a b) = Two (f a) (f b) mapDigit f (Three a b c) = Three (f a) (f b) (f c) mapDigit f (Four a b c d) = Four (f a) (f b) (f c) (f d) {- -- | Like 'traverse', but with a more constrained type. traverse' :: (Measured v1 a1, Measured v2 a2, Applicative f) => (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverse' = traverseTree traverseTree :: (Measured v2 a2, Applicative f) => (a1 -> f a2) -> FingerTree v1 a1 -> f (FingerTree v2 a2) traverseTree _ Empty = pure Empty traverseTree f (Single x) = Single <$> f x traverseTree f (Deep _ pr m sf) = deep <$> traverseDigit f pr <*> traverseTree (traverseNode f) m <*> traverseDigit f sf traverseNode :: (Measured v2 a2, Applicative f) => (a1 -> f a2) -> Node v1 a1 -> f (Node v2 a2) traverseNode f (Node2 _ a b) = node2 <$> f a <*> f b traverseNode f (Node3 _ a b c) = node3 <$> f a <*> f b <*> f c traverseDigit :: (Applicative f) => (a -> f b) -> Digit a -> f (Digit b) traverseDigit f (One a) = One <$> f a traverseDigit f (Two a b) = Two <$> f a <*> f b traverseDigit f (Three a b c) = Three <$> f a <*> f b <*> f c traverseDigit f (Four a b c d) = Four <$> f a <*> f b <*> f c <*> f d -} -- | /O(1)/. The empty sequence. empty :: Measured v a => FingerTree v a empty = Empty -- | /O(1)/. A singleton sequence. singleton :: Measured v a => a -> FingerTree v a singleton = Single -- | /O(n)/. Create a sequence from a finite list of elements. fromList :: (Measured v a) => [a] -> FingerTree v a fromList = foldr lcons Empty -- | /O(1)/. Add an element to the left end of a sequence. lcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a a `lcons` Empty = Single a a `lcons` Single b = deep (One a) Empty (One b) a `lcons` Deep _ (Four b c d e) m sf = m `seq` deep (Two a b) (node3 c d e `lcons` m) sf a `lcons` Deep _ pr m sf = deep (consDigit a pr) m sf consDigit :: a -> Digit a -> Digit a consDigit a (One b) = Two a b consDigit a (Two b c) = Three a b c consDigit a (Three b c d) = Four a b c d consDigit _ _ = error "FingerTree.consDigit: bug!" -- | /O(1)/. Add an element to the right end of a sequence. rcons :: (Measured v a) => a -> FingerTree v a -> FingerTree v a rcons = flip rcons0 rcons0 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a Empty `rcons0` a = Single a Single a `rcons0` b = deep (One a) Empty (One b) Deep _ pr m (Four a b c d) `rcons0` e = m `seq` deep pr (m `rcons0` node3 a b c) (Two d e) Deep _ pr m sf `rcons0` x = deep pr m (snocDigit sf x) snocDigit :: Digit a -> a -> Digit a snocDigit (One a) b = Two a b snocDigit (Two a b) c = Three a b c snocDigit (Three a b c) d = Four a b c d snocDigit _ _ = error "FingerTree.snocDigit: bug!" -- | /O(1)/. Is this the empty sequence? null :: (Measured v a) => FingerTree v a -> Bool null Empty = True null _ = False -- | /O(1)/. Analyse the left end of a sequence. lview :: (Measured v a, Monad m) => FingerTree v a -> m (a,FingerTree v a) lview Empty = fail "FingerTree.lview: empty tree" lview (Single x) = return (x, Empty) lview (Deep _ (One x) m sf) = return . (,) x $ case lview m of Nothing -> digitToTree sf Just (a,m') -> deep (nodeToDigit a) m' sf lview (Deep _ pr m sf) = return (lheadDigit pr, deep (ltailDigit pr) m sf) lheadDigit :: Digit a -> a lheadDigit (One a) = a lheadDigit (Two a _) = a lheadDigit (Three a _ _) = a lheadDigit (Four a _ _ _) = a ltailDigit :: Digit a -> Digit a ltailDigit (Two _ b) = One b ltailDigit (Three _ b c) = Two b c ltailDigit (Four _ b c d) = Three b c d ltailDigit _ = error "FingerTree.ltailDigit: bug!" -- | /O(1)/. Analyse the right end of a sequence. rview :: (Measured v a, Monad m) => FingerTree v a -> m (a, FingerTree v a) rview Empty = fail "FingerTree.rview: empty tree" rview (Single x) = return (x, Empty) rview (Deep _ pr m (One x)) = return . (,) x $ case rview m of Nothing -> digitToTree pr Just (a,m') -> deep pr m' (nodeToDigit a) rview (Deep _ pr m sf) = return (rheadDigit sf, deep pr m (rtailDigit sf)) rheadDigit :: Digit a -> a rheadDigit (One a) = a rheadDigit (Two _ b) = b rheadDigit (Three _ _ c) = c rheadDigit (Four _ _ _ d) = d rtailDigit :: Digit a -> Digit a rtailDigit (Two a _) = One a rtailDigit (Three a b _) = Two a b rtailDigit (Four a b c _) = Three a b c rtailDigit _ = error "FingerTree.rtailDigit: bug!" digitToTree :: (Measured v a) => Digit a -> FingerTree v a digitToTree (One a) = Single a digitToTree (Two a b) = deep (One a) Empty (One b) digitToTree (Three a b c) = deep (Two a b) Empty (One c) digitToTree (Four a b c d) = deep (Two a b) Empty (Two c d) -- | /O(log(min(n1,n2)))/. Concatenate two sequences. append :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a append = appendTree0 appendTree0 :: (Measured v a) => FingerTree v a -> FingerTree v a -> FingerTree v a appendTree0 Empty xs = xs appendTree0 xs Empty = xs appendTree0 (Single x) xs = x `lcons` xs appendTree0 xs (Single x) = xs `rcons0` x appendTree0 (Deep _ pr1 m1 sf1) (Deep _ pr2 m2 sf2) = deep pr1 (addDigits0 m1 sf1 pr2 m2) sf2 addDigits0 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits0 m1 (One a) (One b) m2 = appendTree1 m1 (node2 a b) m2 addDigits0 m1 (One a) (Two b c) m2 = appendTree1 m1 (node3 a b c) m2 addDigits0 m1 (One a) (Three b c d) m2 = appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits0 m1 (One a) (Four b c d e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Two a b) (One c) m2 = appendTree1 m1 (node3 a b c) m2 addDigits0 m1 (Two a b) (Two c d) m2 = appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits0 m1 (Two a b) (Three c d e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Two a b) (Four c d e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits0 m1 (Three a b c) (One d) m2 = appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits0 m1 (Three a b c) (Two d e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Three a b c) (Three d e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits0 m1 (Three a b c) (Four d e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits0 m1 (Four a b c d) (One e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits0 m1 (Four a b c d) (Two e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits0 m1 (Four a b c d) (Three e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits0 m1 (Four a b c d) (Four e f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 appendTree1 :: (Measured v a) => FingerTree v a -> a -> FingerTree v a -> FingerTree v a appendTree1 Empty a xs = a `lcons` xs appendTree1 xs a Empty = xs `rcons0` a appendTree1 (Single x) a xs = x `lcons` (a `lcons` xs) appendTree1 xs a (Single x) = xs `rcons0` a `rcons0` x appendTree1 (Deep _ pr1 m1 sf1) a (Deep _ pr2 m2 sf2) = deep pr1 (addDigits1 m1 sf1 a pr2 m2) sf2 addDigits1 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits1 m1 (One a) b (One c) m2 = appendTree1 m1 (node3 a b c) m2 addDigits1 m1 (One a) b (Two c d) m2 = appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits1 m1 (One a) b (Three c d e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits1 m1 (One a) b (Four c d e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Two a b) c (One d) m2 = appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits1 m1 (Two a b) c (Two d e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits1 m1 (Two a b) c (Three d e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Two a b) c (Four d e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits1 m1 (Three a b c) d (One e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits1 m1 (Three a b c) d (Two e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Three a b c) d (Three e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits1 m1 (Three a b c) d (Four e f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits1 m1 (Four a b c d) e (One f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits1 m1 (Four a b c d) e (Two f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits1 m1 (Four a b c d) e (Three f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits1 m1 (Four a b c d) e (Four f g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 appendTree2 :: (Measured v a) => FingerTree v a -> a -> a -> FingerTree v a -> FingerTree v a appendTree2 Empty a b xs = a `lcons` (b `lcons` xs) appendTree2 xs a b Empty = xs `rcons0` a `rcons0` b appendTree2 (Single x) a b xs = x `lcons` (a `lcons` (b `lcons` xs)) appendTree2 xs a b (Single x) = xs `rcons0` a `rcons0` b `rcons0` x appendTree2 (Deep _ pr1 m1 sf1) a b (Deep _ pr2 m2 sf2) = deep pr1 (addDigits2 m1 sf1 a b pr2 m2) sf2 addDigits2 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits2 m1 (One a) b c (One d) m2 = appendTree2 m1 (node2 a b) (node2 c d) m2 addDigits2 m1 (One a) b c (Two d e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits2 m1 (One a) b c (Three d e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits2 m1 (One a) b c (Four d e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Two a b) c d (One e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits2 m1 (Two a b) c d (Two e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits2 m1 (Two a b) c d (Three e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Two a b) c d (Four e f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits2 m1 (Three a b c) d e (One f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits2 m1 (Three a b c) d e (Two f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Three a b c) d e (Three f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits2 m1 (Three a b c) d e (Four f g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits2 m1 (Four a b c d) e f (One g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits2 m1 (Four a b c d) e f (Two g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits2 m1 (Four a b c d) e f (Three g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits2 m1 (Four a b c d) e f (Four g h i j) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 appendTree3 :: (Measured v a) => FingerTree v a -> a -> a -> a -> FingerTree v a -> FingerTree v a appendTree3 Empty a b c xs = a `lcons` (b `lcons` (c `lcons` xs)) appendTree3 xs a b c Empty = xs `rcons0` a `rcons0` b `rcons0` c appendTree3 (Single x) a b c xs = x `lcons` (a `lcons` (b `lcons` (c `lcons` xs))) appendTree3 xs a b c (Single x) = xs `rcons0` a `rcons0` b `rcons0` c `rcons0` x appendTree3 (Deep _ pr1 m1 sf1) a b c (Deep _ pr2 m2 sf2) = deep pr1 (addDigits3 m1 sf1 a b c pr2 m2) sf2 addDigits3 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits3 m1 (One a) b c d (One e) m2 = appendTree2 m1 (node3 a b c) (node2 d e) m2 addDigits3 m1 (One a) b c d (Two e f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits3 m1 (One a) b c d (Three e f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits3 m1 (One a) b c d (Four e f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Two a b) c d e (One f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits3 m1 (Two a b) c d e (Two f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits3 m1 (Two a b) c d e (Three f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Two a b) c d e (Four f g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits3 m1 (Three a b c) d e f (One g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits3 m1 (Three a b c) d e f (Two g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Three a b c) d e f (Three g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits3 m1 (Three a b c) d e f (Four g h i j) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits3 m1 (Four a b c d) e f g (One h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits3 m1 (Four a b c d) e f g (Two h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits3 m1 (Four a b c d) e f g (Three h i j) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits3 m1 (Four a b c d) e f g (Four h i j k) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 appendTree4 :: (Measured v a) => FingerTree v a -> a -> a -> a -> a -> FingerTree v a -> FingerTree v a appendTree4 Empty a b c d xs = a `lcons` b `lcons` c `lcons` d `lcons` xs appendTree4 xs a b c d Empty = xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d appendTree4 (Single x) a b c d xs = x `lcons` a `lcons` b `lcons` c `lcons` d `lcons` xs appendTree4 xs a b c d (Single x) = xs `rcons0` a `rcons0` b `rcons0` c `rcons0` d `rcons0` x appendTree4 (Deep _ pr1 m1 sf1) a b c d (Deep _ pr2 m2 sf2) = deep pr1 (addDigits4 m1 sf1 a b c d pr2 m2) sf2 addDigits4 :: (Measured v a) => FingerTree v (Node v a) -> Digit a -> a -> a -> a -> a -> Digit a -> FingerTree v (Node v a) -> FingerTree v (Node v a) addDigits4 m1 (One a) b c d e (One f) m2 = appendTree2 m1 (node3 a b c) (node3 d e f) m2 addDigits4 m1 (One a) b c d e (Two f g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits4 m1 (One a) b c d e (Three f g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits4 m1 (One a) b c d e (Four f g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Two a b) c d e f (One g) m2 = appendTree3 m1 (node3 a b c) (node2 d e) (node2 f g) m2 addDigits4 m1 (Two a b) c d e f (Two g h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits4 m1 (Two a b) c d e f (Three g h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Two a b) c d e f (Four g h i j) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits4 m1 (Three a b c) d e f g (One h) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node2 g h) m2 addDigits4 m1 (Three a b c) d e f g (Two h i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Three a b c) d e f g (Three h i j) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits4 m1 (Three a b c) d e f g (Four h i j k) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 addDigits4 m1 (Four a b c d) e f g h (One i) m2 = appendTree3 m1 (node3 a b c) (node3 d e f) (node3 g h i) m2 addDigits4 m1 (Four a b c d) e f g h (Two i j) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node2 g h) (node2 i j) m2 addDigits4 m1 (Four a b c d) e f g h (Three i j k) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node2 j k) m2 addDigits4 m1 (Four a b c d) e f g h (Four i j k l) m2 = appendTree4 m1 (node3 a b c) (node3 d e f) (node3 g h i) (node3 j k l) m2 -- | /O(log(min(i,n-i)))/. Split a sequence at a point where the predicate -- on the accumulated measure changes from 'False' to 'True'. split :: (Measured v a) => (v -> Bool) -> FingerTree v a -> (FingerTree v a, FingerTree v a) split _p Empty = (Empty, Empty) split p xs | p (measure xs) = (l, x `lcons` r) | otherwise = (xs, Empty) where Split l x r = splitTree p mempty xs takeUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a takeUntil p = fst . split p dropUntil :: (Measured v a) => (v -> Bool) -> FingerTree v a -> FingerTree v a dropUntil p = snd . split p data Split t a = Split t a t splitTree :: (Measured v a) => (v -> Bool) -> v -> FingerTree v a -> Split (FingerTree v a) a splitTree _ _ Empty = error "FingerTree.splitTree: bug!" splitTree _p _i (Single x) = Split Empty x Empty splitTree p i (Deep _ pr m sf) | p vpr = let Split l x r = splitDigit p i pr in Split (maybe Empty digitToTree l) x (deepL r m sf) | p vm = let Split ml xs mr = splitTree p vpr m Split l x r = splitNode p (vpr `mappendVal` ml) xs in Split (deepR pr ml l) x (deepL r mr sf) | otherwise = let Split l x r = splitDigit p vm sf in Split (deepR pr m l) x (maybe Empty digitToTree r) where vpr = i `mappend` measure pr vm = vpr `mappendVal` m mappendVal :: (Measured v a) => v -> FingerTree v a -> v mappendVal v Empty = v mappendVal v t = v `mappend` measure t deepL :: (Measured v a) => Maybe (Digit a) -> FingerTree v (Node v a) -> Digit a -> FingerTree v a deepL Nothing m sf = case lview m of Nothing -> digitToTree sf Just (a,m') -> deep (nodeToDigit a) m' sf deepL (Just pr) m sf = deep pr m sf deepR :: (Measured v a) => Digit a -> FingerTree v (Node v a) -> Maybe (Digit a) -> FingerTree v a deepR pr m Nothing = case rview m of Nothing -> digitToTree pr Just (a,m') -> deep pr m' (nodeToDigit a) deepR pr m (Just sf) = deep pr m sf splitNode :: (Measured v a) => (v -> Bool) -> v -> Node v a -> Split (Maybe (Digit a)) a splitNode p i (Node2 _ a b) | p va = Split Nothing a (Just (One b)) | otherwise = Split (Just (One a)) b Nothing where va = i `mappend` measure a splitNode p i (Node3 _ a b c) | p va = Split Nothing a (Just (Two b c)) | p vab = Split (Just (One a)) b (Just (One c)) | otherwise = Split (Just (Two a b)) c Nothing where va = i `mappend` measure a vab = va `mappend` measure b splitDigit :: (Measured v a) => (v -> Bool) -> v -> Digit a -> Split (Maybe (Digit a)) a splitDigit _ i (One a) = i `seq` Split Nothing a Nothing splitDigit p i (Two a b) | p va = Split Nothing a (Just (One b)) | otherwise = Split (Just (One a)) b Nothing where va = i `mappend` measure a splitDigit p i (Three a b c) | p va = Split Nothing a (Just (Two b c)) | p vab = Split (Just (One a)) b (Just (One c)) | otherwise = Split (Just (Two a b)) c Nothing where va = i `mappend` measure a vab = va `mappend` measure b splitDigit p i (Four a b c d) | p va = Split Nothing a (Just (Three b c d)) | p vab = Split (Just (One a)) b (Just (Two c d)) | p vabc = Split (Just (Two a b)) c (Just (One d)) | otherwise = Split (Just (Three a b c)) d Nothing where va = i `mappend` measure a vab = va `mappend` measure b vabc = vab `mappend` measure c -- | /O(n)/. The reverse of a sequence. reverse :: (Measured v a) => FingerTree v a -> FingerTree v a reverse = reverseTree id reverseTree :: (Measured v2 a2) => (a1 -> a2) -> FingerTree v1 a1 -> FingerTree v2 a2 reverseTree _ Empty = Empty reverseTree f (Single x) = Single (f x) reverseTree f (Deep _ pr m sf) = deep (reverseDigit f sf) (reverseTree (reverseNode f) m) (reverseDigit f pr) reverseNode :: (Measured v2 a2) => (a1 -> a2) -> Node v1 a1 -> Node v2 a2 reverseNode f (Node2 _ a b) = node2 (f b) (f a) reverseNode f (Node3 _ a b c) = node3 (f c) (f b) (f a) reverseDigit :: (a -> b) -> Digit a -> Digit b reverseDigit f (One a) = One (f a) reverseDigit f (Two a b) = Two (f b) (f a) reverseDigit f (Three a b c) = Three (f c) (f b) (f a) reverseDigit f (Four a b c d) = Four (f d) (f c) (f b) (f a) two :: Monad m => m a -> m (a, a) two m = liftM2 (,) m m three :: Monad m => m a -> m (a, a, a) three m = liftM3 (,,) m m m four :: Monad m => m a -> m (a, a, a, a) four m = liftM4 (,,,) m m m m instance (Arbitrary a) => Arbitrary (Digit a) where arbitrary = oneof [ arbitrary >>= \x -> return (One x) , two arbitrary >>= \(x,y) -> return (Two x y) , three arbitrary >>= \(x,y,z) -> return (Three x y z) , four arbitrary >>= \(x,y,z,w) -> return (Four x y z w) ] instance (CoArbitrary a) => CoArbitrary (Digit a) where coarbitrary p = case p of One x -> variant 0 . coarbitrary x Two x y -> variant 1 . coarbitrary x . coarbitrary y Three x y z -> variant 2 . coarbitrary x . coarbitrary y . coarbitrary z Four x y z w -> variant 3 . coarbitrary x . coarbitrary y . coarbitrary z . coarbitrary w instance (Measured v a, Arbitrary a) => Arbitrary (Node v a) where arbitrary = oneof [ two arbitrary >>= \(x,y) -> return (node2 x y) , three arbitrary >>= \(x,y,z) -> return (node3 x y z) ] instance (Measured v a, CoArbitrary a) => CoArbitrary (Node v a) where coarbitrary p = case p of Node2 _ x y -> variant 0 . coarbitrary x . coarbitrary y Node3 _ x y z -> variant 1 . coarbitrary x . coarbitrary y . coarbitrary z instance (Measured v a, Arbitrary a) => Arbitrary (FingerTree v a) where arbitrary = oneof [ return Empty , arbitrary >>= return . Single , do pf <- arbitrary m <- arbitrary sf <- arbitrary return (deep pf m sf) ] instance (Measured v a, CoArbitrary a) => CoArbitrary (FingerTree v a) where coarbitrary p = case p of Empty -> variant 0 Single x -> variant 1 . coarbitrary x Deep _ sf m pf -> variant 2 . coarbitrary sf . coarbitrary m . coarbitrary pf