diff --git a/COPYRIGHT b/COPYRIGHT new file mode 100644 --- /dev/null +++ b/COPYRIGHT @@ -0,0 +1,23 @@ +Copyright (c) 1998-1999 Chris Okasaki +Portions Copyright (c) 2002 Andrew Bromage +Portions Copyright (c) 2006 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. diff --git a/EdisonCore.cabal b/EdisonCore.cabal new file mode 100644 --- /dev/null +++ b/EdisonCore.cabal @@ -0,0 +1,55 @@ +Name: EdisonCore +Version: 1.2.1 +License: OtherLicense +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 +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. +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 >= 1.0, + haskell98 >= 1.0, + mtl >= 1.0, + QuickCheck == 1.0, + EdisonAPI == 1.2.1 +Extensions: + MultiParamTypeClasses + FunctionalDependencies + UndecidableInstances + CPP +Ghc-Options: -funbox-strict-fields -fwarn-incomplete-patterns -O2 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,206 @@ +Edison: A Library of Efficient Data Structures +Version: 1.2.1 +Dec 15, 2006 + + +About Edison +----------------------- + +Edison is a library of purely function data structures for Haskell +originally written by Chris Okasaki. Conceptually, it consists of two +things: + 1) A set of type classes defining data the following data structure + abstractions: "sequences", "collections" and "associative collections" + 2) Multiple concrete implementations of each of the abstractions. + +In theory, either component may be used independently of the other. + +This release is an update to (hopefully) make Edison easier to use, +mostly by updating Edison to use the most current Haskell tools. +The following major changes have been made since version 1.1, which +was released in 1999. + + * Typeclasses updated to use fundeps (by Andrew Bromage) + * Implementation of ternary search tries (by Andrew Bromage) + * Modules renamed to use the hierarchical module extension + * Documentation haddockized + * Source moved to a darcs repository + * Build system cabalized + * Unit tests integrated into a single driver program which exercises + all the concrete implementations shipped with Edison + * Multiple additions to the APIs (mostly the associated collection API) + + +Hopefully, these changes will make Edison more accessible than it has +been previously. + + +License +----------------------- + +Edison is released under an MIT style license. See the COPYRIGHT +file for details. + + + +Building Edison +----------------------- + +Edison is distributed as a set of related Cabal packages. +The EdisonAPI package contains the main API typeclass definitions. +The EdisonCore package provides the main concrete implementations; +this package depends on the EdisonAPI package. The Edison-test +package contains the test suite and depends on both packages. + +You may either manually invoke cabal for each of the sub-packages +as appropriate, or you may use the included Makefile, which will +build and install the EdisonAPI and EdisonCore packages +automaticly. + +If you do not have an executable named 'runhaskell' on your search +path, you will need to edit the Makefile and set the RUNHS variable +appropriately (or run the cabal commands manually). + +If you wish to build the API docs, you will first need to +build the relevant package and type the following command in +the package subdirectory: + +runhaskell Setup.hs haddock + + +A Note about Cabal versions +----------------------------------- + +This version of edison builds correctly with Cabal version 1.1.4, +which is shipped with GHC 6.4.2. To build on earlier versions, +it should suffice to: + +s/UndecidableInstances/AllowUndecidableInstances/ +s/Hs-Source-Dirs:/Hs-Source-Dir:/ + +in the .cabal files. + + + +Notes on portability +---------------------- + +Short version: + +Edison is expected to work correctly on recent GHC and Hugs (with +extensions enabled). Other Haskell implementations may also work, but +have not been tested. + + +Longer version: + +Edison uses a number of extensions beyond Haskell 98, the current +official Haskell standard. These include: + + * Multi-parameter typeclasses + * Functional dependencies + * Undecidable instances + +In all cases, these extensions are used to allow the typeclass +abstractions to be expressed. These extensions are fairly popular +and seem likely to make it in some form into a Haskell standard +(hopefully in the not too distant future). + +Currently, Edison builds and runs correctly under GHC and Hugs. +More specificly, most development and testing has been done with +GHC 6.4.1, and the test suite builds and runs to completion with no errors. +With Hugs (March 2005 release) and the '-98' option, all of the core Edison +data structures should work correctly. Unfortunately, the test suite will +not load, due to differences in Hugs' and GHC's implementations of +multi-parameter typeclasses. + +As the extensions used are not recent developments, I also expect that less +recent versions of GHC and Hugs will also work. Other implementations +may also work correctly with Edison, but this has not been tested. + + + +The Story on Edison Packages +---------------------------------- + +Cabal is a nice tool for building and distributing Haskell projects. However, +it has the slightly undesirable property that the "Package" unit is the atomic +unit of compilation, documentation and of dependency resolution. In order to +support implementations which have varying external dependencies, Edison has been +split into multiple cabal sub-packages, which cooperate. The root package is +named 'EdisonAPI' and it contains the typeclass specifications, together with +extensive documentation and a few utility classes. 'EdisonAPI' essentially +represents a design contract. The 'EdisonCore' package contains core Edison +implementations. These implementations have no dependencies beyond the standard +libraries. Other implementation modules are planned: these other modules +may have dependencies on eg, Adiran Hay's AVL tree implementation or Don +Stewart's Fast Packed String, etc. Additionally there is a unit test package. +Currently it is tied to the 'EdisonCore' package, but in the future it will +provide basic unit testing capabilities for extended implementations as well. + + + + +Edison Versioning +----------------------- + +As the maintainer of Edison, I take API stability very seriously. My goal is +that programs written against Edison will not suffer from version drift. +However, I also wish to allow Edison to incorporate new ideas and evolve into a +better way to use data structures in Haskell. In order to help accommodate these +somewhat opposing goals, I have adopted the following versioning scheme. Respect +the versioning scheme, and you should have no compatibility problems. + + +Each Edison release number is composed of four components: + + xxx.yyy.zzz.www + ^ ^ ^ ^ + | | | | + | | | +------ patch level + | | +---------- API version number + | +-------------- minor version number + +------------------ major version number + + +The API version number and/or patch level may be omitted for brevity. When +omitted, they are assumed to be 0. + +I have adopted the (pre-2.6) Linux kernel versioning scheme for major and +minor numbers: the major number is incremented at major updates (ie, something +on the order of total API re-engineering or complete rewrites). Minor numbers +represent "branches" of development. + +Releases with even minor numbers are "stable" releases (0 is considered even). +For example, the Edison 1.2 release is a stable release. Even numbered releases +will have stable user-visible APIs; my goal is that any program compiled against +an Edison stable release will work correctly for all later Edison releases with +the same major and minor version numbers. This means that API changes will be +limited to additions. However, I intend that even additions be rare, and they will +only be considered with compelling evidence that the lack of the feature in question +inhibits desirable use cases. The user-visible behavior of an implementation will +only be changed if it was originally in violation of the contract (ie, a bug). + +*NOTE* +THE EXACT BEHAVIOR OF AMBIGUOUS OPERATIONS IS NOT CONSIDERED USER-VISIBLE BEHAVIOR, +nor is the behavior of unsafe operations when used in violation of their preconditions. +Ambiguous operations may change their behavior in stable releases as long as such +changes still obey the design contract. + + +Releases with odd minor numbers are "development" branches. Such releases +are branched from the immediately preceding stable release minor number. +For example, the Edison 1.3 development branch will be forked from the Edison 1.2 +release family. No guarantees are made about the user-visible APIs for development +branches. API operations may be added, deleted, or have the terms of their design +contracts altered in development branches, and implementations may freely change their +behavior. Eventually development branches are stabilized and transform into the next +even-numbered stable release. + +For both even and odd minor numbers, the third component represents the "API version". +Any change to the API will cause a bump in the API version number. For stable branches, +this should be fairly rare; for odd branches, it may occur rather frequently. + +The fourth component is incremented for each official release whenever the first three +components are not altered. Two Edison versions which differ only in their patch level +should have identical APIs. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/src/Data/Edison/Assoc/AssocList.hs b/src/Data/Edison/Assoc/AssocList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Assoc/AssocList.hs @@ -0,0 +1,618 @@ +-- | +-- Module : Data.Edison.Assoc.AssocList +-- Copyright : Copyright (c) 1998 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- This module implements finite maps as simple association lists. +-- +-- Duplicates are removed conceptually, but not physically. The first +-- occurrence of a given key is the one that is considered to be in the map. +-- +-- The list type is mildly customized to prevent boxing the pairs. + +module Data.Edison.Assoc.AssocList ( + -- * Type of simple association lists + FM, -- instance of Assoc(X), FiniteMap(X) + -- also instance of Functor + + -- * AssocX operations + empty,singleton,fromSeq,insert,insertSeq,union,unionSeq,delete,deleteAll, + deleteSeq,null,size,member,count,lookup,lookupM,lookupAll, + lookupAndDelete,lookupAndDeleteM,lookupAndDeleteAll, + lookupWithDefault,adjust,adjustAll,adjustOrInsert,adjustAllOrInsert, + adjustOrDelete,adjustOrDeleteAll,strict,strictWith, + map,fold,fold',fold1,fold1',filter,partition,elements,structuralInvariant, + + -- * OrdAssocX operations + minView, minElem, deleteMin, unsafeInsertMin, maxView, maxElem, deleteMax, + unsafeInsertMax, foldr, foldr', foldl, foldl', foldr1, foldr1', + foldl1, foldl1', unsafeFromOrdSeq, unsafeAppend, + filterLT, filterLE, filterGT, filterGE, + partitionLT_GE, partitionLE_GT, partitionLT_GT, + + -- * Assoc operations + toSeq,keys,mapWithKey,foldWithKey,foldWithKey',filterWithKey,partitionWithKey, + + -- * OrdAssoc operations + minViewWithKey, minElemWithKey, maxViewWithKey, maxElemWithKey, + foldrWithKey, foldrWithKey', foldlWithKey, foldlWithKey', toOrdSeq, + + -- * FiniteMapX operations + fromSeqWith,fromSeqWithKey,insertWith,insertWithKey,insertSeqWith, + insertSeqWithKey,unionl,unionr,unionWith,unionSeqWith,intersectionWith, + difference,properSubset,subset,properSubmapBy,submapBy,sameMapBy, + properSubmap,submap,sameMap, + + -- * FiniteMap operations + unionWithKey,unionSeqWithKey,intersectionWithKey, + + -- * Documentation + moduleName +) where + +import Prelude hiding (null,map,lookup,foldr,foldl,foldr1,foldl1,filter) +import qualified Prelude +import Data.Monoid +import Control.Monad.Identity +import Data.Edison.Prelude +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(..), 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 (k,x) = I k x + + +-- left biased merge. +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 E = RL.empty +toRandList (I k a m) = RL.lcons (I k a E) (toRandList m) + +mergeSortFM m = RL.reducer mergeFM E (toRandList m) + +foldrFM :: Eq k => (a -> b -> b) -> b -> FM k a -> b +foldrFM f 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 f (I k a E) = a +foldr1FM f (I k a m) = f a (foldr1FM f (delete k m)) +foldr1FM f _ = error "invalid call to foldr1FM on empty map" + +foldrFM' :: Eq k => (a -> b -> b) -> b -> FM k a -> b +foldrFM' f 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' f (I k a E) = a +foldr1FM' f (I k a m) = f a $! (foldr1FM' f (delete k m)) +foldr1FM' f _ = error "invalid call to foldr1FM' on empty map" + +foldlFM :: Eq k => (b -> a -> b) -> b -> FM k a -> b +foldlFM f 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' f 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 f 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' f 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 f 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' f 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 p 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 p E = E +dropWhileFM p o@(I k a m) + | p k = dropWhileFM p m + | otherwise = o + +spanFM :: (k -> Bool) -> FM k a -> (FM k a,FM k a) +spanFM p 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 key 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 k x m) = False + +size E = 0 +size (I k x m) = 1 + size (delete k m) + +member key E = False +member key (I k x m) = key == k || member key m + +count key E = 0 +count key (I k x m) | key == k = 1 + | otherwise = count key m + +lookup key m = runIdentity (lookupM key m) + +lookupM key E = fail "AssocList.lookup: lookup failed" +lookupM key (I k x m) | key == k = return x + | otherwise = lookupM key m + +lookupAll key 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 key 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 key 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 f key 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 f 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 f E = E +map f (I k x m) = I k (f x) (map f m) + +fold f c E = c +fold f c (I k x m) = fold f (f x c) (delete k m) + +fold' f c E = c +fold' f c (I k x m) = c `seq` fold' f (f x c) (delete k m) + +fold1 f E = error "AssocList.fold1: empty map" +fold1 f (I k x m) = fold f x (delete k m) + +fold1' f E = error "AssocList.fold1': empty map" +fold1' f (I k x m) = fold' f x (delete k m) + +filter p 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 p 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 x m) = S.lcons k (keys (delete k m)) + +mapWithKey f E = E +mapWithKey f (I k x m) = I k (f k x) (mapWithKey f m) + +foldWithKey f c E = c +foldWithKey f c (I k x m) = foldWithKey f (f k x c) (delete k m) + +foldWithKey' f c E = c +foldWithKey' f c (I k x m) = c `seq` foldWithKey' f (f k x c) (delete k m) + +filterWithKey p 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 p 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 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 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" + m -> foldr1FM f m + +foldr1' f m = + case mergeSortFM m of + E -> error $ moduleName++".foldlr1': empty map" + m -> foldr1FM' f m + +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 m -> foldlFM f a (delete k m) + +foldl1' f m = + case mergeSortFM m of + E -> error $ moduleName++".foldl1': empty map" + I k a m -> foldlFM' f a (delete k m) + +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 m = moduleName} + +instance Ord k => A.OrdAssocX (FM k) k where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Eq k => A.FiniteMapX (FM k) k where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance Ord k => A.OrdFiniteMapX (FM k) k + +instance Eq k => A.Assoc (FM k) k where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance Ord k => A.OrdAssoc (FM k) k where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance Eq k => A.FiniteMap (FM k) k where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance Ord k => A.OrdFiniteMap (FM k) k + +instance Eq k => Functor (FM k) where + fmap = map + +instance (Eq k,Eq a) => Eq (FM k a) where + (==) = sameMap + +instance (Ord k, Ord a) => Ord (FM k a) where + compare = compareUsingToOrdList + +instance (Eq k,Show k,Show a) => Show (FM k a) where + showsPrec = showsPrecUsingToList + +instance (Eq k,Read k,Read a) => Read (FM k a) where + readsPrec = readsPrecUsingFromList + +instance (Eq k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where + arbitrary = do xs <- arbitrary + return (Prelude.foldr (uncurry insert) empty xs) + + coarbitrary E = variant 0 + coarbitrary (I k a m) = variant 1 . coarbitrary k + . coarbitrary a . coarbitrary m + + +instance Eq k => Monoid (FM k a) where + mempty = empty + mappend = union + mconcat = unionSeq diff --git a/src/Data/Edison/Assoc/Defaults.hs b/src/Data/Edison/Assoc/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Assoc/Defaults.hs @@ -0,0 +1,313 @@ +-- | +-- Module : Data.Edison.Assoc.Defaults +-- Copyright : Copyright (c) 1998 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.Maybe (fromJust) + +import Data.Edison.Assoc +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) + +singletonUsingInsert :: (Assoc m k) => k -> a -> m a +singletonUsingInsert k v = insert k v empty + +fromSeqUsingInsertSeq :: (AssocX m k,S.Sequence seq) => seq (k,a) -> m a +fromSeqUsingInsertSeq kvs = insertSeq kvs empty + +insertSeqUsingFoldr :: + (AssocX m k,S.Sequence seq) => seq (k,a) -> m a -> m a +insertSeqUsingFoldr kvs m = S.foldr (uncurry insert) m kvs + +unionSeqUsingReduce :: (AssocX m k,S.Sequence seq) => seq (m a) -> m a +unionSeqUsingReduce ms = S.reducel union empty ms + +deleteSeqUsingFoldr :: (AssocX m k,S.Sequence seq) => seq k -> m a -> m a +deleteSeqUsingFoldr ks m = S.foldr delete m ks + +memberUsingLookupM :: (AssocX m k) => k -> m a -> Bool +memberUsingLookupM k m + = case lookupM k m of + Just _ -> True + Nothing -> False + +sizeUsingElements :: (AssocX m k) => m a -> Int +sizeUsingElements m = length (elements m) + +countUsingMember :: AssocX m k => k -> m a -> Int +countUsingMember k m = if member k m then 1 else 0 + +lookupAllUsingLookupM :: (AssocX m k,S.Sequence seq) => k -> m a -> seq a +lookupAllUsingLookupM k m = case lookupM k m of + Just x -> S.singleton x + Nothing -> S.empty + +lookupWithDefaultUsingLookupM :: AssocX m k => a -> k -> m a -> a +lookupWithDefaultUsingLookupM d k m = case lookupM k m of + Just x -> x + Nothing -> d + +partitionUsingFilter :: AssocX m k => (a -> Bool) -> m a -> (m a,m a) +partitionUsingFilter f m = (filter f m, filter (not . f) m) + +fold1UsingElements :: (AssocX m k) => (a -> a -> a) -> m a -> a +fold1UsingElements op m = L.foldr1 op (elements m) + +elementsUsingFold :: (AssocX m k,S.Sequence seq) => m a -> seq a +elementsUsingFold = fold S.lcons S.empty + +nullUsingElements :: (AssocX m k) => m a -> Bool +nullUsingElements m + = case elements m of + [] -> True + _ -> False + +insertWithUsingLookupM :: + FiniteMapX m k => (a -> a -> a) -> k -> a -> m a -> m a +insertWithUsingLookupM f k x m = + case lookupM k m of + Nothing -> insert k x m + Just y -> insert k (f x y) m + +fromSeqWithUsingInsertSeqWith :: + (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) -> m a +fromSeqWithUsingInsertSeqWith f kvs = insertSeqWith f kvs empty + +fromSeqWithKeyUsingInsertSeqWithKey :: + (FiniteMapX m k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) -> m a +fromSeqWithKeyUsingInsertSeqWithKey f kvs = insertSeqWithKey f kvs empty + +insertWithKeyUsingInsertWith :: + FiniteMapX m k => (k -> a -> a -> a) -> k -> a -> m a -> m a +insertWithKeyUsingInsertWith f k = insertWith (f k) k + +insertSeqWithUsingInsertWith :: + (FiniteMapX m k,S.Sequence seq) => + (a -> a -> a) -> seq (k,a) -> m a -> m a +insertSeqWithUsingInsertWith f kvs m = + S.foldr (uncurry (insertWith f)) m kvs + +insertSeqWithKeyUsingInsertWithKey :: + (FiniteMapX m k,S.Sequence seq) => + (k -> a -> a -> a) -> seq (k,a) -> m a -> m a +insertSeqWithKeyUsingInsertWithKey f kvs m = + S.foldr (uncurry (insertWithKey f)) m kvs + +unionSeqWithUsingReduce :: + (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a +unionSeqWithUsingReduce f ms = S.reducel (unionWith f) empty ms + +unionSeqWithUsingFoldr :: + (FiniteMapX m k,S.Sequence seq) => (a -> a -> a) -> seq (m a) -> m a +unionSeqWithUsingFoldr f ms = S.foldr (unionWith f) empty ms + +toSeqUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq (k,a) +toSeqUsingFoldWithKey = foldWithKey conspair S.empty + where conspair k v kvs = S.lcons (k,v) kvs + +keysUsingFoldWithKey :: (Assoc m k,S.Sequence seq) => m a -> seq k +keysUsingFoldWithKey = foldWithKey conskey S.empty + where conskey k v 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 (elem,m') -> + case f elem 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 m = m + ins (Just x) m = insert k x m + 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 i xs = + let result = maybeParens p xs + p xs = tokenMatch ((instanceName x)++".fromSeq") 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 + +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 xs = tokenMatch ((instanceName x)++".unsafeFromOrdSeq") xs + >>= 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 (x:xs) (y:ys) = + case compare x y of + EQ -> cmp xs ys + c -> c diff --git a/src/Data/Edison/Assoc/PatriciaLoMap.hs b/src/Data/Edison/Assoc/PatriciaLoMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Assoc/PatriciaLoMap.hs @@ -0,0 +1,838 @@ +-- | +-- Module : Data.Edison.Assoc.PatriciaLoMap +-- Copyright : Copyright (c) 1998 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.Edison.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 Data.Bits +import Test.QuickCheck (Arbitrary(..), variant) + +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 k x) = True +structuralInvariant x = inv 0 0 x + +inv :: Int -> Int -> FM a -> Bool +inv pre msk E = False +inv pre msk (L k x) = 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 p m E t = t +makeB p m t E = t +makeB p m t0 t1 = B p m t0 t1 + +lmakeB p m E t = t +lmakeB p m t0 t1 = B p m t0 t1 + +rmakeB p m 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 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 x 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 y) = 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 k E = E +delete k t@(L j x) = 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 k E = False +member k (L j x) = (j == k) +member k (B p 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 k E = fail "PatriciaLoMap.lookup: lookup failed" +lookupM k (L j x) + | j == k = return x + | otherwise = fail "PatriciaLoMap.lookup: lookup failed" +lookupM k (B p 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 cont k 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 f k 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 f 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 f c E = c +fold f c (L k x) = f x c +fold f c (B p m t0 t1) = fold f (fold f c t1) t0 + +fold' :: (a -> b -> b) -> b -> FM a -> b +fold' f c E = c +fold' f c (L k x) = c `seq` f x c +fold' f c (B p m t0 t1) = c `seq` (fold f $! (fold f c t1)) t0 + +fold1 :: (a -> a -> a) -> FM a -> a +fold1 f E = error "PatriciaLoMap.fold1: empty map" +fold1 f (L k x) = x +fold1 f (B p m t0 t1) = f (fold1 f t0) (fold1 f t1) + +fold1' :: (a -> a -> a) -> FM a -> a +fold1' f E = error "PatriciaLoMap.fold1: empty map" +fold1' f (L k x) = x +fold1' f (B p m t0 t1) = f (fold1' f t0) $! (fold1' f t1) + +filter :: (a -> Bool) -> FM a -> FM a +filter g E = E +filter g t@(L k 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 g E = (E, E) +partition g t@(L k 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 f 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 f s@(B _ _ _ _) E = s +unionWith f (L k x) t = insertWith f k x t +unionWith f 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 p 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 f s@(B _ _ _ _) E = E +intersectionWith f (L k x) t = + case lookupM k t of + Just y -> L k (f x y) + Nothing -> E +intersectionWith f E t = 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 y) = + 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 x) t = if member k t then E else s +difference E t = E + +properSubset :: FM a -> FM b -> Bool +properSubset s t = case subset' s t of {LT -> True; _ -> False} + +subset' s@(B p m s0 s1) t@(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 p m s0 s1) _ = GT +subset' (L k x) (L j y) = if k == j then EQ else GT +subset' (L k x) 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) t@(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 p m s0 s1) _ = False +subset (L k x) t = member k t +subset E t = 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 f 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 f c E = c +foldWithKey f c (L k x) = f k x c +foldWithKey f c (B p m t0 t1) = foldWithKey f (foldWithKey f c t1) t0 + +foldWithKey' :: (Int -> a -> b -> b) -> b -> FM a -> b +foldWithKey' f c E = c +foldWithKey' f c (L k x) = c `seq` f k x c +foldWithKey' f c (B p m t0 t1) = c `seq` (foldWithKey f $! (foldWithKey f c t1)) t0 + + +filterWithKey :: (Int -> a -> Bool) -> FM a -> FM a +filterWithKey g 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 g 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 f s@(B _ _ _ _) E = s +unionWithKey f (L k x) t = insertWith (f k) k x t +unionWithKey f 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 p 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 f s@(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 f E t = E + +-- Datastructure definition is strict in all submaps, +-- no forcing required +strict n = n + +strictWith f n@E = n +strictWith f n@(L i x) = f x `seq` n +strictWith f n@(B i j 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 p m 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 p m 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) z -> f z k x) z . ordListFM_rev $ fm + +foldlWithKey' :: (b -> Int -> a -> b) -> b -> FM a -> b +foldlWithKey' f z fm = L.foldl' (\ z (k,x) -> f z 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 m = moduleName} + +instance A.Assoc FM Int where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance A.FiniteMapX FM Int where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance A.FiniteMap FM Int where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance A.OrdAssocX FM Int where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance A.OrdAssoc FM Int where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance A.OrdFiniteMapX FM Int +instance A.OrdFiniteMap FM Int + +instance Functor FM where + fmap = map + +instance (Show a) => Show (FM a) where + showsPrec = showsPrecUsingToList + +instance (Read a) => Read (FM a) where + readsPrec = readsPrecUsingFromList + +instance (Eq a) => Eq (FM a) where + (==) = sameMap + +instance (Ord a) => Ord (FM a) where + compare = compareUsingToOrdList + +instance (Arbitrary a) => Arbitrary (FM a) where + arbitrary = do xs <- arbitrary + return (Prelude.foldr (uncurry insert) empty xs) + + coarbitrary E = variant 0 + coarbitrary (L i a) = variant 1 . coarbitrary i . coarbitrary a + coarbitrary (B i j m n) = variant 2 . coarbitrary i . coarbitrary j + . coarbitrary m . coarbitrary n + + +instance Monoid (FM a) where + mempty = empty + mappend = union + mconcat = unionSeq diff --git a/src/Data/Edison/Assoc/StandardMap.hs b/src/Data/Edison/Assoc/StandardMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Assoc/StandardMap.hs @@ -0,0 +1,372 @@ +-- | +-- Module : Data.Edison.Assoc.AssocList +-- Copyright : Copyright (c) 2006 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 Control.Monad.Identity (runIdentity) +import Data.Edison.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 Data.Bits +import Test.QuickCheck (Arbitrary(..)) + +import qualified Data.Map as DM + +type FM = DM.Map + +moduleName :: String +moduleName = "Data.Edison.Assoc.StandardMap" + +empty :: FM k a +singleton :: Ord k => k -> a -> FM k a +fromSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a +insert :: Ord k => k -> a -> FM k a -> FM k a +insertSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a -> FM k a +union :: Ord k => FM k a -> FM k a -> FM k a +unionSeq :: (Ord k,S.Sequence seq) => seq (FM k a) -> FM k a +delete :: Ord k => k -> FM k a -> FM k a +deleteAll :: Ord k => k -> FM k a -> FM k a +deleteSeq :: (Ord k,S.Sequence seq) => seq k -> FM k a -> FM k a +null :: FM k a -> Bool +size :: FM k a -> Int +member :: Ord k => k -> FM k a -> Bool +count :: Ord k => k -> FM k a -> Int +lookup :: Ord k => k -> FM k a -> a +lookupAll :: (Ord k,S.Sequence seq) => k -> FM k a -> seq a +lookupM :: (Ord k,Monad m) => k -> FM k a -> m a +lookupWithDefault :: Ord k => a -> k -> FM k a -> a +lookupAndDelete :: Ord k => k -> FM k a -> (a, FM k a) +lookupAndDeleteM :: (Ord k,Monad m) => k -> FM k a -> m (a, FM k a) +lookupAndDeleteAll :: (Ord k,S.Sequence seq) => k -> FM k a -> (seq a,FM k a) +adjust :: Ord k => (a->a) -> k -> FM k a -> FM k a +adjustAll :: Ord k => (a->a) -> k -> FM k a -> FM k a +adjustOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a +adjustAllOrInsert :: Ord k => (a -> a) -> a -> k -> FM k a -> FM k a +adjustOrDelete :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a +adjustOrDeleteAll :: Ord k => (a -> Maybe a) -> k -> FM k a -> FM k a +strict :: Ord k => FM k a -> FM k a +strictWith :: Ord k => (a -> b) -> FM k a -> FM k a +map :: (Ord k,Functor (FM k)) => (a -> b) -> FM k a -> FM k b +fold :: Ord k => (a -> b -> b) -> b -> FM k a -> b +fold1 :: Ord k => (a -> a -> a) -> FM k a -> a +fold' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +fold1' :: Ord k => (a -> a -> a) -> FM k a -> a +filter :: Ord k => (a -> Bool) -> FM k a -> FM k a +partition :: Ord k => (a -> Bool) -> FM k a -> (FM k a,FM k a) +elements :: (Ord k,S.Sequence seq) => FM k a -> seq a + +minView :: (Ord k,Monad m) => FM k a -> m (a, FM k a) +minElem :: Ord k => FM k a -> a +deleteMin :: Ord k => FM k a -> FM k a +unsafeInsertMin :: Ord k => k -> a -> FM k a -> FM k a +maxView :: (Ord k,Monad m) => FM k a -> m (a, FM k a) +maxElem :: Ord k => FM k a -> a +deleteMax :: Ord k => FM k a -> FM k a +unsafeInsertMax :: Ord k => k -> a -> FM k a -> FM k a +foldr :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldl :: Ord k => (b -> a -> b) -> b -> FM k a -> b +foldr1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldl1 :: Ord k => (a -> a -> a) -> FM k a -> a +foldr' :: Ord k => (a -> b -> b) -> b -> FM k a -> b +foldl' :: Ord k => (b -> a -> b) -> b -> FM k a -> b +foldr1' :: Ord k => (a -> a -> a) -> FM k a -> a +foldl1' :: Ord k => (a -> a -> a) -> FM k a -> a +unsafeFromOrdSeq :: (Ord k,S.Sequence seq) => seq (k,a) -> FM k a +unsafeAppend :: Ord k => FM k a -> FM k a -> FM k a +filterLT :: Ord k => k -> FM k a -> FM k a +filterGT :: Ord k => k -> FM k a -> FM k a +filterLE :: Ord k => k -> FM k a -> FM k a +filterGE :: Ord k => k -> FM k a -> FM k a +partitionLT_GE :: Ord k => k -> FM k a -> (FM k a,FM k a) +partitionLE_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) +partitionLT_GT :: Ord k => k -> FM k a -> (FM k a,FM k a) + +fromSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) + -> seq (k,a) -> FM k a +fromSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) + -> seq (k,a) -> FM k a +insertWith :: Ord k => (a -> a -> a) -> k -> a + -> FM k a -> FM k a +insertWithKey :: Ord k => (k -> a -> a -> a) -> k -> a + -> FM k a -> FM k a +insertSeqWith :: (Ord k,S.Sequence seq) => (a -> a -> a) -> seq (k,a) + -> FM k a -> FM k a +insertSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) -> seq (k,a) + -> FM k a -> FM k a +unionl :: Ord k => FM k a -> FM k a -> FM k a +unionr :: Ord k => FM k a -> FM k a -> FM k a +unionWith :: Ord k => (a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWith :: (Ord k,S.Sequence seq) => + (a -> a -> a) -> seq (FM k a) -> FM k a +intersectionWith :: Ord k => (a -> b -> c) -> FM k a -> FM k b -> FM k c +difference :: Ord k => FM k a -> FM k b -> FM k a +properSubset :: Ord k => FM k a -> FM k b -> Bool +subset :: Ord k => FM k a -> FM k b -> Bool +properSubmapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +submapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +sameMapBy :: Ord k => (a -> a -> Bool) -> FM k a -> FM k a -> Bool +properSubmap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool +submap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool +sameMap :: (Ord k,Eq a) => FM k a -> FM k a -> Bool + +toSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) +keys :: (Ord k,S.Sequence seq) => FM k a -> seq k +mapWithKey :: Ord k => (k -> a -> b) -> FM k a -> FM k b +foldWithKey :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b +foldWithKey' :: Ord k => (k -> a -> b -> b) -> b -> FM k a -> b +filterWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> FM k a +partitionWithKey :: Ord k => (k -> a -> Bool) -> FM k a -> (FM k a,FM k a) + +minViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a) +minElemWithKey :: Ord k => FM k a -> (k,a) +maxViewWithKey :: (Ord k,Monad m) => FM k a -> m ((k, a), FM k a) +maxElemWithKey :: Ord k => FM k a -> (k,a) +foldrWithKey :: (k -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey :: (b -> k -> a -> b) -> b -> FM k a -> b +foldrWithKey' :: (k -> a -> b -> b) -> b -> FM k a -> b +foldlWithKey' :: (b -> k -> a -> b) -> b -> FM k a -> b +toOrdSeq :: (Ord k,S.Sequence seq) => FM k a -> seq (k,a) + +unionWithKey :: Ord k => (k -> a -> a -> a) -> FM k a -> FM k a -> FM k a +unionSeqWithKey :: (Ord k,S.Sequence seq) => (k -> a -> a -> a) + -> seq (FM k a) -> FM k a +intersectionWithKey :: Ord k => (k -> a -> b -> c) -> FM k a -> FM k b -> FM k c + +structuralInvariant :: Ord k => FM k a -> Bool +structuralInvariant = DM.valid + + +empty = DM.empty +singleton = DM.singleton +fromSeq = fromSeqUsingInsertSeq +insert = DM.insert +insertSeq = insertSeqUsingFoldr +union = DM.union +unionSeq = DM.unions . S.toList +delete = DM.delete +deleteAll = DM.delete -- by finite map property +deleteSeq = deleteSeqUsingFoldr +null = DM.null +size = DM.size +member = DM.member +count = countUsingMember +lookup k m = case lookupM k m of + Nothing -> error (moduleName ++ ".lookup: failed") + Just x -> x +lookupM = DM.lookup +lookupAll = lookupAllUsingLookupM +lookupWithDefault = DM.findWithDefault +lookupAndDelete = lookupAndDeleteDefault +lookupAndDeleteM = lookupAndDeleteMDefault +lookupAndDeleteAll = lookupAndDeleteAllDefault +adjust = DM.adjust +adjustAll = DM.adjust +adjustOrInsert = adjustOrInsertUsingMember +adjustAllOrInsert = adjustOrInsertUsingMember +adjustOrDelete = DM.update +adjustOrDeleteAll = DM.update +strict xs = DM.fold (flip const) () xs `seq` xs +strictWith f xs = DM.fold (\x z -> f x `seq` z) () xs `seq` xs +map = fmap +fold = DM.fold +fold' f x xs = L.foldl' (flip f) x (DM.elems xs) +fold1 f xs = L.foldr1 f (DM.elems xs) +fold1' f xs = L.foldl1' (flip f) (DM.elems xs) +filter = DM.filter +partition = DM.partition +elements = elementsUsingFold + +minView m = if DM.null m + then fail (moduleName ++ ".minView: failed") + else let ((k,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 ((k,x),m') = DM.deleteFindMax m + in return (x,m') +maxElem = snd . DM.findMax +deleteMax = DM.deleteMax +unsafeInsertMax = DM.insert +foldr f x m = L.foldr f x (DM.elems m) +foldl f x m = L.foldl f x (DM.elems m) +foldr1 f m = L.foldr1 f (DM.elems m) +foldl1 f m = L.foldl1 f (DM.elems m) +foldr' f x m = L.foldr' f x (DM.elems m) +foldl' f x m = L.foldl' f x (DM.elems m) +foldr1' f m = L.foldr1' f (DM.elems m) +foldl1' f m = L.foldl1' f (DM.elems m) +unsafeFromOrdSeq = DM.fromAscList . S.toList +unsafeAppend = DM.union +filterLT k = fst . DM.split k +filterGT k = snd . DM.split k +filterLE k m = let (lt, mx, _ ) = DM.splitLookup k m in maybe lt (\x -> insert k x lt) mx +filterGE k m = let (_ , mx, gt) = DM.splitLookup k m in maybe gt (\x -> insert k x gt) mx +partitionLT_GE k m = let (lt, mx, gt) = DM.splitLookup k m in (lt, maybe gt (\x -> insert k x gt) mx) +partitionLE_GT k m = let (lt, mx, gt) = DM.splitLookup k m in (maybe lt (\x -> insert k x lt) mx, gt) +partitionLT_GT = DM.split +fromSeqWith f s = DM.fromListWith f (S.toList s) +fromSeqWithKey f s = DM.fromListWithKey f (S.toList s) +insertWith = DM.insertWith +insertWithKey = insertWithKeyUsingInsertWith +insertSeqWith = insertSeqWithUsingInsertWith +insertSeqWithKey = insertSeqWithKeyUsingInsertWithKey +unionl = DM.union +unionr = flip DM.union +unionWith = DM.unionWith +unionSeqWith = unionSeqWithUsingReduce +intersectionWith = DM.intersectionWith +difference = DM.difference +properSubset = DM.isProperSubmapOfBy (\_ _ -> True) +subset = DM.isSubmapOfBy (\_ _ -> True) +properSubmapBy = DM.isProperSubmapOfBy +submapBy = DM.isSubmapOfBy +sameMapBy = sameMapByUsingOrdLists +properSubmap = A.properSubmap +submap = A.submap +sameMap = A.sameMap + +toSeq = toSeqUsingFoldWithKey +keys = keysUsingFoldWithKey +mapWithKey = DM.mapWithKey +foldWithKey = DM.foldWithKey +foldWithKey' f x m = L.foldl' (\b (k,a) -> f k a b) x (DM.toList m) +filterWithKey = DM.filterWithKey +partitionWithKey = DM.partitionWithKey + +minViewWithKey m = if DM.null m + then fail (moduleName ++ ".minViewWithKey: failed") + else return (DM.deleteFindMin m) +minElemWithKey = DM.findMin +maxViewWithKey m = if DM.null m + then fail (moduleName ++ ".maxViewWithKey: failed") + else return (DM.deleteFindMax m) +maxElemWithKey = DM.findMax +foldrWithKey = DM.foldWithKey +foldrWithKey' f x m = L.foldr' (\(k,a) b -> f k a b) x (DM.toAscList m) +foldlWithKey f x m = L.foldl (\b (k,a) -> f b k a) x (DM.toAscList m) +foldlWithKey' f x m = L.foldl' (\b (k,a) -> f b k a) x (DM.toAscList m) +toOrdSeq = S.fromList . DM.toAscList + +unionWithKey = DM.unionWithKey +unionSeqWithKey = unionSeqWithKeyUsingReduce +intersectionWithKey = DM.intersectionWithKey + + +instance Ord k => A.AssocX (FM k) k where + {empty = empty; singleton = singleton; fromSeq = fromSeq; insert = insert; + insertSeq = insertSeq; union = union; unionSeq = unionSeq; + delete = delete; deleteAll = deleteAll; deleteSeq = deleteSeq; + null = null; size = size; member = member; count = count; + lookup = lookup; lookupM = lookupM; lookupAll = lookupAll; + lookupAndDelete = lookupAndDelete; lookupAndDeleteM = lookupAndDeleteM; + lookupAndDeleteAll = lookupAndDeleteAll; + lookupWithDefault = lookupWithDefault; adjust = adjust; + adjustAll = adjustAll; adjustOrInsert = adjustOrInsert; + adjustAllOrInsert = adjustAllOrInsert; + adjustOrDelete = adjustOrDelete; adjustOrDeleteAll = adjustOrDeleteAll; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; elements = elements; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName m = moduleName} + +instance Ord k => A.OrdAssocX (FM k) k where + {minView = minView; minElem = minElem; deleteMin = deleteMin; + unsafeInsertMin = unsafeInsertMin; maxView = maxView; maxElem = maxElem; + deleteMax = deleteMax; unsafeInsertMax = unsafeInsertMax; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterGT = filterGT; filterLE = filterLE; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord k => A.FiniteMapX (FM k) k where + {fromSeqWith = fromSeqWith; fromSeqWithKey = fromSeqWithKey; + insertWith = insertWith; insertWithKey = insertWithKey; + insertSeqWith = insertSeqWith; insertSeqWithKey = insertSeqWithKey; + unionl = unionl; unionr = unionr; unionWith = unionWith; + unionSeqWith = unionSeqWith; intersectionWith = intersectionWith; + difference = difference; properSubset = properSubset; subset = subset; + properSubmapBy = properSubmapBy; submapBy = submapBy; + sameMapBy = sameMapBy} + +instance Ord k => A.OrdFiniteMapX (FM k) k + +instance Ord k => A.Assoc (FM k) k where + {toSeq = toSeq; keys = keys; mapWithKey = mapWithKey; + foldWithKey = foldWithKey; foldWithKey' = foldWithKey'; + filterWithKey = filterWithKey; + partitionWithKey = partitionWithKey} + +instance Ord k => A.OrdAssoc (FM k) k where + {minViewWithKey = minViewWithKey; minElemWithKey = minElemWithKey; + maxViewWithKey = maxViewWithKey; maxElemWithKey = maxElemWithKey; + foldrWithKey = foldrWithKey; foldrWithKey' = foldrWithKey'; + foldlWithKey = foldlWithKey; foldlWithKey' = foldlWithKey'; + toOrdSeq = toOrdSeq} + +instance Ord k => A.FiniteMap (FM k) k where + {unionWithKey = unionWithKey; unionSeqWithKey = unionSeqWithKey; + intersectionWithKey = intersectionWithKey} + +instance Ord k => A.OrdFiniteMap (FM k) k + +instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where + arbitrary = do xs <- arbitrary + return (Prelude.foldr (uncurry insert) empty xs) + + coarbitrary map = coarbitrary (A.toList map) diff --git a/src/Data/Edison/Assoc/TernaryTrie.hs b/src/Data/Edison/Assoc/TernaryTrie.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Assoc/TernaryTrie.hs @@ -0,0 +1,1149 @@ +-- | +-- Module : Data.Edison.Assoc.TernaryTrie +-- Copyright : Copyright (c) 2002 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 Data.Edison.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.Edison.Assoc.Defaults +import Test.QuickCheck (Arbitrary(..), variant) + +import Maybe (isNothing) + +-- 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 nk@(x:xs) E + = Nothing +lookupFMB nk@(x:xs) (I _ k v l m@(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 cont xs 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 cont [] (FM Nothing fmb) = onFail +lookupAndDelFromFM onFail 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 xs 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 n 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 r@(I _ kr vr rl rm rr) + = mkBalancedFMB kr vr (mkVBalancedFMB k v l m rl) rm rr +mkVBalancedFMB k v l@(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 size 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 y@(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 _ k v l (FMB' m) r) + = mapVFMB (\v -> f Nothing v) fmby + mergeVFMB' fmbx@(I _ k v l (FMB' m) r) 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' ks 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' ks E + = E + mergeKVFMBs' ks (I s 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 ks Nothing = id + foldMV ks (Just v) = f ks v + + foldFMB kf 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 ks Nothing = id + foldMV ks (Just v) = g ks v + + foldFMB kf 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 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' = foldl + +foldr1 f fm = + case maxView fm of + Just (z,fm') -> foldr f z fm' + Nothing -> error $ moduleName++".foldr1: empty map" + +foldl1 f fm = + case minView fm of + Just (z,fm') -> foldl f z fm' + Nothing -> error $ moduleName++".foldl1: empty map" + + +basecase Nothing = \j n -> n +basecase (Just x) = \j n -> j x + +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 + = \j 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' = 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 v fmb) = strictFMB fmb `seq` z + where strictFMB n@E = n + strictFMB n@(I i k v 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 i k 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 k Nothing = id + foldWithKeyB k (Just v) = op k v + + foldWithKeyFM ks 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 f = 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 i k Nothing E (FMB' E) r) f = error $ moduleName++".minView: bug!" +minViewFMB (I i k Nothing E (FMB' m) r) f = minViewFMB m (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) +minViewFMB (I 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 fk f = 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 i k Nothing E (FMB' E) r) kf f = error $ moduleName++".minViewWithKey: bug!" +minViewWithKeyFMB (I i k Nothing E (FMB' m) r) kf f = minViewWithKeyFMB m (kf . (k:)) + (\m' -> f (mkVBalancedFMB k Nothing E (FMB' m') r)) +minViewWithKeyFMB (I 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 i k (Just v) E m r) = v +minElemFMB (I i k Nothing E (FMB' m) r) = minElemFMB m +minElemFMB (I i k mv l m r) = minElemFMB l + +minElem (FM (Just v) fmb) = v +minElem (FM Nothing fmb) = minElemFMB fmb + + +minElemWithKeyFMB :: ([k] -> [k]) -> FMB k a -> ([k],a) +minElemWithKeyFMB kf E = error $ moduleName++".minElemWithKey: empty map" +minElemWithKeyFMB kf (I i k (Just v) E m r) = (kf [k],v) +minElemWithKeyFMB kf (I i k Nothing E (FMB' m) r) = minElemWithKeyFMB (kf . (k:)) m +minElemWithKeyFMB kf (I i k mv l m r) = minElemWithKeyFMB kf l + +minElemWithKey :: FM k a -> ([k],a) +minElemWithKey (FM (Just v) fmb) = ([],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 i k (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 i k Nothing l (FMB' E) E) f = 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 i k mv l m r) f = maxViewFMB r (\r' -> f (mkVBalancedFMB k mv l m r')) +maxViewFMB E f = 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 i k (Just v) l (FMB' E) E) kf f = return ((kf [k],v),f l) +maxViewWithKeyFMB (I i k Nothing l (FMB' E) E) kf f = 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 i k mv l m r) kf f = maxViewWithKeyFMB r kf + (\r' -> f (mkVBalancedFMB k mv l m r')) +maxViewWithKeyFMB E kf f = 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 i k (Just v) l (FMB' E) E) = v +maxElemFMB (I i k Nothing l (FMB' E) E) = error $ moduleName++".maxElem: bug!" +maxElemFMB (I i k mv l (FMB' m) E) = maxElemFMB m +maxElemFMB (I i k mv l m 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 i k (Just v) l (FMB' E) E) kf = (kf [k],v) +maxElemWithKeyFMB (I i k Nothing l (FMB' E) E) kf = error $ moduleName++".maxElemWithKey: bug!" +maxElemWithKeyFMB (I i k mv l (FMB' m) E) kf = maxElemWithKeyFMB m (kf . (k:)) +maxElemWithKeyFMB (I i k mv l m r) kf = maxElemWithKeyFMB r kf +maxElemWithKeyFMB E kf = 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 f k ks E = E +filterL_FMB f k ks (I 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 (\k mv 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 f k ks E = E +filterG_FMB f k ks (I 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 mv fmb) = FM Nothing (filterG_FMB (\k mv 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 mv 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 m = 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 p 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 k fmb) = structuralInvariantFMB fmb + + +instance (Ord k,Arbitrary k,Arbitrary a) => Arbitrary (FM k a) where + arbitrary = do xs <- arbitrary + return (Prelude.foldr (uncurry insert) empty xs) + + coarbitrary (FM x fmb) = coarbitrary_maybe x . coarbitrary_fmb fmb + + +coarbitrary_maybe Nothing = variant 0 +coarbitrary_maybe (Just x) = variant 1 . coarbitrary x + +coarbitrary_fmb E = variant 0 +coarbitrary_fmb (I _ k x l (FMB' m) r) = + variant 1 . coarbitrary k . coarbitrary_maybe x . + coarbitrary_fmb l . coarbitrary_fmb m . coarbitrary_fmb r + +instance Ord k => Monoid (FM k a) where + mempty = empty + mappend = union + mconcat = unionSeq + diff --git a/src/Data/Edison/Coll/Defaults.hs b/src/Data/Edison/Coll/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/Defaults.hs @@ -0,0 +1,244 @@ +-- | +-- Module : Data.Edison.Coll.Defaults +-- Copyright : Copyright (c) 1998 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@(x:xs) b@(y:ys) = + case compare x y of + LT -> disj xs b + EQ -> False + GT -> disj a ys + disj _ _ = True + +intersectWitnessUsingToOrdList :: + (OrdColl c a, Monad m) => c -> c -> m (a,a) +intersectWitnessUsingToOrdList xs ys = witness (toOrdList xs) (toOrdList ys) + 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 xs ++ ".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 y -> x) + +unionUsingUnionWith :: Set c a => c -> c -> c +unionUsingUnionWith = unionWith (\x y -> 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 y -> x) + +differenceUsingOrdLists :: OrdSet c a => c -> c -> c +differenceUsingOrdLists xs ys = unsafeFromOrdList (diff (toOrdList xs) (toOrdList ys)) + 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 [] [] = 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 [] _ = 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 y -> x) xs ys + +unionrUsingUnionWith :: Set c a => c -> c -> c +unionrUsingUnionWith xs ys = unionWith (\x y -> y) xs ys + +unionWithUsingOrdLists :: OrdSet c a => (a -> a -> a) -> c -> c -> c +unionWithUsingOrdLists c xs ys = unsafeFromOrdList (merge (toOrdList xs) (toOrdList ys)) + 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@(x:xs) [] = 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 xs ys = unsafeFromOrdList (inter (toOrdList xs) (toOrdList ys)) + 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 i xs = + let result = maybeParens p xs + p xs = tokenMatch ((instanceName x)++".fromSeq") 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 + +compareUsingToOrdList :: OrdColl c a => c -> c -> Ordering +compareUsingToOrdList xs ys = cmp (toOrdList xs) (toOrdList ys) + where + cmp [] [] = EQ + cmp [] _ = LT + cmp _ [] = GT + cmp (x:xs) (y:ys) = + case compare x y of + EQ -> cmp xs ys + c -> c + diff --git a/src/Data/Edison/Coll/EnumSet.hs b/src/Data/Edison/Coll/EnumSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/EnumSet.hs @@ -0,0 +1,798 @@ +----------------------------------------------------------------------------- +-- | +-- 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, 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 + , 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.Array + +import Data.Edison.Prelude +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Coll.Defaults +import Test.QuickCheck hiding (check) + +moduleName = "Data.Edison.Coll.EnumSet" + +{-------------------------------------------------------------------- + Sets are bit strings of width wordLength. +--------------------------------------------------------------------} +-- | A set of values @a@ implemented as bitwise operations. Useful +-- for members of class Enum with no more elements than there are bits +-- in @Word@. +newtype Set a = Set Word deriving (Eq) + +wordLength :: Int +wordLength = bitSize (0::Word) + +check :: String -> Int -> Int +check msg x + | x < wordLength = x + | otherwise = error $ "EnumSet."++msg++": element beyond word size." + + +-- no interesting structural invariants +structuralInvariant :: Set a -> Bool +structuralInvariant = const True + + +---------------------------------------------------- +-- bit twiddly magic + +countBits :: Word -> Int +countBits w = w `seq` bitcount 0 w + +bitcount :: Int -> Word -> Int +bitcount a 0 = a +bitcount a x = a `seq` bitcount (a+1) (x .&. (x-1)) + +-- stolen from http://aggregate.org/MAGIC/ +lsb :: Word -> Int +lsb x = countBits ((x-1) .&. (Bits.complement x)) + +msb :: Word -> Int +msb x0 = let + x1 = x0 .|. (x0 `shiftR` 1) + x2 = x1 .|. (x1 `shiftR` 2) + x3 = x2 .|. (x2 `shiftR` 4) + x4 = x3 .|. (x3 `shiftR` 8) + x5 = x4 .|. (x4 `shiftR` 16) + in countBits x5 - 1 + + +lowMask :: Int -> Word +lowMask x = bit x - 1 + +highMask :: Int -> Word +highMask x = Bits.complement (lowMask x) + +{-------------------------------------------------------------------- + Query +--------------------------------------------------------------------} +-- | /O(1)/. Is this the empty set? +null :: Set a -> Bool +null (Set 0) = True +null _ = False + +-- | /O(1)/. The number of elements in the set. +size :: Set a -> Int +size (Set w) = countBits w + +-- | /O(1)/. Is the element in the set? +member :: (Eq a, Enum a) => a -> Set a -> Bool +member x (Set w) = testBit w $ fromEnum x + +count :: (Eq a, Enum a) => a -> Set a -> Int +count = countUsingMember + +lookup :: (Eq a, Enum a) => a -> Set a -> a +lookup = lookupUsingLookupAll + +lookupM :: (Eq a, Enum a, Monad m) => a -> Set a -> m a +lookupM x s + | member x s = return x + | otherwise = fail (moduleName++".lookupM: lookup failed") + +lookupAll :: (Eq a, Enum a, S.Sequence s) => a -> Set a -> s a +lookupAll = lookupAllUsingLookupM + +lookupWithDefault :: (Eq a, Enum a) => a -> a -> Set a -> a +lookupWithDefault = lookupWithDefaultUsingLookupM + +{-------------------------------------------------------------------- + Construction +--------------------------------------------------------------------} +-- | /O(1)/. The empty set. +empty :: Set a +empty = Set 0 + +-- | /O(1)/. Create a singleton set. +singleton :: (Eq a, Enum a) => a -> Set a +singleton x = + Set $ setBit 0 $ check "singleton" $ fromEnum x + +{-------------------------------------------------------------------- + Insertion, Deletion +--------------------------------------------------------------------} +-- | /O(1)/. Insert an element in a set. +-- If the set already contains an element equal to the given value, +-- it is replaced with the new value. +insert :: (Eq a, Enum a) => a -> Set a -> Set a +insert x (Set w) = + Set $ setBit w $ check "insert" $ fromEnum x + +-- given the preconditions, we can just ignore the combining function +insertWith :: (Eq a, Enum a) => (a -> a -> a) -> a -> Set a -> Set a +insertWith f 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 f = union + +unionSeqWith :: (Eq a, Enum a, S.Sequence s) => (a -> a -> a) -> s (Set a) -> Set a +unionSeqWith f = 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 f = 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 z = f (toEnum i) z + +fold' :: (Eq a, Enum a) => (a -> c -> c) -> c -> Set a -> c +fold' f z (Set w) = foldrBits' folder z w + where folder i z = f (toEnum i) z + +fold1 :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a +fold1 f (Set 0) = error (moduleName++".fold1: empty set") +fold1 f (Set w) = foldrBits folder (toEnum max) (clearBit w max) + where + max = msb w + folder i z = f (toEnum i) z + +fold1' :: (Eq a, Enum a) => (a -> a -> a) -> Set a -> a +fold1' f (Set 0) = error (moduleName++".fold1': empty set") +fold1' f (Set w) = foldrBits folder (toEnum max) (clearBit w max) + where + max = 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 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 z = f (toEnum i) z + +foldr1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldr1 f (Set 0) = error (moduleName++".foldr1: empty set") +foldr1 f (Set w) = foldrBits folder (toEnum max) (clearBit w max) + where + max = msb w + folder i z = f (toEnum i) z + +foldr1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldr1' f (Set 0) = error (moduleName++".foldr1': empty set") +foldr1' f (Set w) = foldrBits folder (toEnum max) (clearBit w max) + where + max = 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 z i = f z (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 z i = f z (toEnum i) + +foldl1 :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldl1 f (Set 0) = error (moduleName++".foldl1: empty set") +foldl1 f (Set w) = foldlBits folder (toEnum min) (clearBit w min) + where + min = lsb w + folder z i = f z (toEnum i) + +foldl1' :: (Ord a, Enum a) => (a -> a -> a) -> Set a -> a +foldl1' f (Set 0) = error (moduleName++".foldl1': empty set") +foldl1' f (Set w) = foldlBits' folder (toEnum min) (clearBit w min) + where + min = 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 f = 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 f 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 f z i 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' f z i 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 f z i 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 z = foldlBits_aux f z (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' f z i 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 z = foldlBits_aux' f z (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 c = 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)) + + coarbitrary (Set w) = coarbitrary (fromIntegral w :: Int) + +instance (Eq a, Enum a) => Monoid (Set a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Ord a, Enum a) => Ord (Set a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Coll/LazyPairingHeap.hs b/src/Data/Edison/Coll/LazyPairingHeap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/LazyPairingHeap.hs @@ -0,0 +1,562 @@ +-- | +-- Module : Data.Edison.Coll.LazyPairingHeap +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), + Coll(..), OrdColl(..), toOrdList ) +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.List(sort) +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +moduleName = "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 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 x xs) 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 x a xs) 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 xs -> Just (H1 x xs) + 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 y 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 y ys 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 x xs) = 1 + size xs +size (H2 x h xs) = 1 + size h + size xs + +member :: Ord a => a -> Heap a -> Bool +member x 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 x 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 x xs) = xs +deleteMin (H2 x 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 y 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 y 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 h@(H1 x xs) rest + | x > y = union h rest + | otherwise = fgt xs rest + fgt h@(H2 x a xs) rest + | x > y = union h 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 h@(H1 x xs) rest + | x >= y = union h rest + | otherwise = fge xs rest + fge h@(H2 x a xs) rest + | x >= y = union h rest + | otherwise = fge a (fge xs rest) + +partitionLT_GE :: Ord a => a -> Heap a -> (Heap a, Heap a) +partitionLT_GE y 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 y 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 y 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 h xs) rest = S.lcons x (tol h (tol xs rest)) + +fold :: (a -> b -> b) -> b -> Heap a -> b +fold f 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' f 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 f 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' f 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 p 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 p 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 h xs) rest = + case compare x y of + LT -> look h (look xs rest) + EQ -> S.lcons x (look h (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 xs) = x +minElem (H2 x h xs) = 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' (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 x xs) = maxElem xs +maxElem (H2 x h E) = maxElem h +maxElem (H2 x h xs) = max (maxElem h) (maxElem xs) + +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr f 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' f 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 f 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' f 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 f E = error "LazyPairingHeap.foldr1: empty heap" +foldr1 f (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' f E = error "LazyPairingHeap.foldr1': empty heap" +foldr1' f (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 f 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' f 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 f 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 x xs) = strict xs `seq` h +strict h@(H2 x h' xs) = strict h' `seq` strict xs `seq` h + +strictWith :: (a -> b) -> Heap a -> Heap a +strictWith f 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 c = 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 x E = error "LazyPairingHeap.arbitrary: bug!" + + coarbitrary E = variant 0 + coarbitrary (H1 x a) = variant 1 . coarbitrary x . coarbitrary a + coarbitrary (H2 x a b) = + variant 2 . coarbitrary x . coarbitrary a . coarbitrary b + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Coll/LeftistHeap.hs b/src/Data/Edison/Coll/LeftistHeap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/LeftistHeap.hs @@ -0,0 +1,489 @@ +-- | +-- Module : Data.Edison.Coll.LeftistHeap +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Coll as C ( CollX(..), OrdCollX(..), Coll(..), OrdColl(..), + unionList, toOrdList ) +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +moduleName = "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 l r) = + i == rank t && isMin x t && checkLeftist t + + where rank E = 0 + rank (L _ _ _ r) = (rank r) + 1 + + isMin x E = True + isMin x (L _ y l r) = x <= y && (isMin y l) && (isMin y r) + + checkLeftist E = True + checkLeftist t@(L i _ l r) = + rank l >= rank r && checkLeftist l && checkLeftist r + + +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 m 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' h x a b E = h + union' hx x a b hy@(L _ y c d) + | x <= y = node x a (union' hy y c d b) + | otherwise = node y c (union' hx x a b 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 x 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 x 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 x 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 x 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 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 (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 f 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' f 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 f 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' f 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 p 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 p 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 _ x a b) = union a b + +deleteMax :: Ord a => Heap a -> Heap a +deleteMax h = case maxView h of + Nothing -> E + Just (x,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 y _ = 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 y _ = 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) 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 (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 a b) = 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 _ x a b) = findMax b (findLeaf a) + where findMax E m = m + findMax (L _ x E _) m + | m >= x = m + | otherwise = x + findMax (L _ x a b) m = findMax a (findMax b m) + + findLeaf E = error "LeftistHeap.maxElem: bug" + findLeaf (L _ x E _) = x + findLeaf (L _ x a b) = findMax b (findLeaf a) + +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr f 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' f 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 f 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' f 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 f E = error "LeftistHeap.foldr1: empty collection" +foldr1 f (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' f E = error "LeftistHeap.foldr1': empty collection" +foldr1' f (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 f 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' f 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 f 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 f h@E = h +strictWith f h@(L i 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 c = 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 r 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!" + + coarbitrary E = variant 0 + coarbitrary (L _ x a b) = + variant 1 . coarbitrary x . coarbitrary a . coarbitrary b + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Coll/MinHeap.hs b/src/Data/Edison/Coll/MinHeap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/MinHeap.hs @@ -0,0 +1,406 @@ +-- | +-- Module : Data.Edison.Coll.MinHeap +-- Copyright : Copyright (c) 1999 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 Data.Edison.Prelude +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Edison.Seq.Defaults (tokenMatch,maybeParens) +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +data Min h a = E | M a h deriving (Eq) + +moduleName = "Data.Edison.Coll.MinHeap" + +instanceName E = "MinHeap(empty)" +instanceName (M x h) = "MinHeap(" ++ C.instanceName h ++ ")" + +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 xs = case C.minView xs of + Nothing -> E + Just (x, xs') -> M x xs' + +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 x E = E +delete x m@(M y ys) + | x > y = M y (C.delete x ys) + | x == y = fromPrim ys + | otherwise = m + +deleteAll x 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 x xs) = False + +size E = 0 +size (M x xs) = 1 + C.size xs + + +member x E = False +member x (M y ys) + | x > y = C.member x ys + | otherwise = (x == y) + +count x 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 f e E = e +fold f e (M x xs) = f x (C.fold f e xs) + +fold' f e E = e +fold' f e (M x xs) = f x $! (C.fold' f e xs) + +fold1 f E = error "MinHeap.fold1: empty heap" +fold1 f (M x xs) = C.fold f x xs + +fold1' f E = error "MinHeap.fold1': empty heap" +fold1' f (M x xs) = C.fold' f x xs + +filter p E = E +filter p (M x xs) + | p x = M x (C.filter p xs) + | otherwise = fromPrim (C.filter p xs) + +partition p 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 x 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 x h = h + +filterGE x (M y ys) | y < x = fromPrim (C.filterGE x ys) +filterGE x 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 x 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 x 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 x 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 xs) = 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 f e E = e +foldr f e (M x xs) = f x (C.foldr f e xs) + +foldr' f e E = e +foldr' f e (M x xs) = f x $! (C.foldr' f e xs) + +foldl f e E = e +foldl f e (M x xs) = C.foldl f (f e x) xs + +foldl' f e E = e +foldl' f e (M x xs) = e `seq` C.foldl' f (f e x) xs + +foldr1 f E = error "MinHeap.foldr1: empty heap" +foldr1 f (M x xs) + | C.null xs = x + | otherwise = f x (C.foldr1 f xs) + +foldr1' f E = error "MinHeap.foldr1': empty heap" +foldr1' f (M x xs) + | C.null xs = x + | otherwise = f x $! (C.foldr1' f xs) + +foldl1 f E = error "MinHeap.foldl1: empty heap" +foldl1 f (M x xs) = C.foldl f x xs + +foldl1' f 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 x xs) = C.strict xs `seq` h + +strictWith f 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 c = 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 i xs = maybeParens p xs + where p xs = tokenMatch (moduleName++".fromColl") xs + >>= 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) + + coarbitrary E = variant 0 + coarbitrary (M x xs) = variant 1 . coarbitrary x . coarbitrary xs + +instance (C.OrdColl h a) => Monoid (Min h a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Eq h, C.OrdColl h a) => Ord (Min h a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Coll/SkewHeap.hs b/src/Data/Edison/Coll/SkewHeap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/SkewHeap.hs @@ -0,0 +1,457 @@ +-- | +-- Module : Data.Edison.Coll.SkewHeap +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +moduleName = "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 l r) = isMin x t + where isMin x 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 x a b 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 x 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 x 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 x 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 x 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 f 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' f 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 f 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' f 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 p 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 p 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 x a b) = union a b + +deleteMax :: Ord a => Heap a -> Heap a +deleteMax h = case maxView h of + Nothing -> E + Just (x,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 y _ = 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 y _ = 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 a b) = 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 x a E) = maxElem a +maxElem (T x E a) = maxElem a +maxElem (T x a b) = findMax b (findLeaf a) + where findMax E m = m + findMax (T x E E) m + | m >= x = m + | otherwise = x + findMax (T x a E) m = findMax a m + findMax (T x E a) m = findMax a m + findMax (T x a b) m = findMax a (findMax b m) + + findLeaf E = error "SkewHeap.maxElem: bug" + findLeaf (T x E E) = x + findLeaf (T x a E) = findLeaf a + findLeaf (T x E a) = findLeaf a + findLeaf (T x a b) = findMax b (findLeaf a) + +foldr :: Ord a => (a -> b -> b) -> b -> Heap a -> b +foldr f 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' f 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 f 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' f 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 f E = error "SkewHeap.foldr1: empty collection" +foldr1 f (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' f E = error "SkewHeap.foldr1': empty collection" +foldr1' f (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 f 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' f 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 f 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 x l r) = strict l `seq` strict r `seq` h + +strictWith :: (a -> b) -> Heap a -> Heap a +strictWith f 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 c = 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 s@(T y a b) E + | y < x = T y (sift x a b) E + sift x E s@(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 + + coarbitrary E = variant 0 + coarbitrary (T x a b) = + variant 1 . coarbitrary x . coarbitrary a . coarbitrary b + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Coll/SplayHeap.hs b/src/Data/Edison/Coll/SplayHeap.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/SplayHeap.hs @@ -0,0 +1,493 @@ +-- | +-- Module : Data.Edison.Coll.SplayHeap +-- Copyright : Copyright (c) 1999 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 Data.Edison.Prelude +import qualified Data.Edison.Coll as C +import qualified Data.Edison.Seq as S +import Data.Edison.Coll.Defaults +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +moduleName = "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 a x b) = False + +size = sz 0 + where sz n E = n + sz n (T a x b) = sz (sz (1+n) a) b + +member x 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 x 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 x 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 x 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 x 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 x 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 f e E = e +fold f e (T a x b) = f x (fold f (fold f e b) a) + +fold' f e E = e +fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e b) a) + +fold1 f E = error "SplayHeap.fold1: empty heap" +fold1 f (T a x b) = fold f (fold f x b) a + +fold1' f E = error "SplayHeap.fold1': empty heap" +fold1' f (T a x b) = fold' f (fold' f x b) a + +filter p 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 p 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 x b = b + del (T E x 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 x E = a + del a x (T b y 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 k 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 k 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 k 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 k 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 k 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 k 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 k 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 b) = minel a x + where minel E x = x + minel (T a x b) _ = 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 a x b) = maxel x b + where maxel x E = x + maxel _ (T a x b) = maxel x b + +foldr f e E = e +foldr f e (T a x b) = foldr f (f x (foldr f e b)) a + +foldr' f e E = e +foldr' f e (T a x b) = foldr' f (f x $! (foldr' f e b)) a + +foldl f e E = e +foldl f e (T a x b) = foldl f (f (foldl f e a) x) b + +foldl' f e E = e +foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b + +foldr1 f E = error "SplayHeap.foldr1: empty heap" +foldr1 f (T a x b) = foldr f (myfold f x b) a + where myfold f x E = x + myfold f x (T a y b) = f x (foldr f (myfold f y b) a) + +foldr1' f E = error "SplayHeap.foldr1': empty heap" +foldr1' f (T a x b) = foldr' f (myfold f x b) a + where myfold f x E = x + myfold f x (T a y b) = f x $! (foldr' f (myfold f y b) a) + +foldl1 f E = error "SplayHeap.foldl1: empty heap" +foldl1 f (T a x b) = foldl f (myfold f a x) b + where myfold f E x = x + myfold f (T a x b) y = f (foldl f (myfold f a x) b) y + +foldl1' f E = error "SplayHeap.foldl1': empty heap" +foldl1' f (T a x b) = foldl' f (myfold f a x) b + where myfold f 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 f 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 x r) = strict l `seq` strict r `seq` h + +strictWith f 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 c = 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) + + coarbitrary E = variant 0 + coarbitrary (T a x b) = + variant 1 . coarbitrary a . coarbitrary x . coarbitrary b + +instance (Ord a) => Monoid (Heap a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Ord a) => Ord (Heap a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Coll/StandardSet.hs b/src/Data/Edison/Coll/StandardSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/StandardSet.hs @@ -0,0 +1,272 @@ +-- | +-- Module : Data.Edison.Coll +-- Copyright : Copyright (c) 2006 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 Data.Edison.Prelude +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 seq = DS.unions (S.toList seq) +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 c = moduleName} + +instance Ord a => C.OrdCollX (Set a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Set a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Set a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; foldl = foldl; + foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic } + +instance Ord a => C.SetX (Set a) a where + {intersection = intersection; difference = difference; + symmetricDifference = symmetricDifference; + properSubset = properSubset; subset = subset} + +instance Ord a => C.Set (Set a) a where + {fromSeqWith = fromSeqWith; insertWith = insertWith; + insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; + unionWith = unionWith; unionSeqWith = unionSeqWith; + intersectionWith = intersectionWith} + +instance Ord a => C.OrdSetX (Set a) a + +instance Ord a => C.OrdSet (Set a) a + + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = do xs <- arbitrary + return (Prelude.foldr insert empty xs) + + coarbitrary set = coarbitrary (C.toList set) diff --git a/src/Data/Edison/Coll/UnbalancedSet.hs b/src/Data/Edison/Coll/UnbalancedSet.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Coll/UnbalancedSet.hs @@ -0,0 +1,439 @@ +-- | +-- Module : Data.Edison.Coll.UnbalancedSet +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +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 Data.Monoid +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Set a +singleton :: a -> Set a +fromSeq :: (Ord a,S.Sequence seq) => seq a -> Set a +insert :: Ord a => a -> Set a -> Set a +insertSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a +union :: Ord a => Set a -> Set a -> Set a +unionSeq :: (Ord a,S.Sequence seq) => seq (Set a) -> Set a +delete :: Ord a => a -> Set a -> Set a +deleteAll :: Ord a => a -> Set a -> Set a +deleteSeq :: (Ord a,S.Sequence seq) => seq a -> Set a -> Set a +null :: Set a -> Bool +size :: Set a -> Int +member :: Ord a => a -> Set a -> Bool +count :: Ord a => a -> Set a -> Int +strict :: Set a -> Set a + +toSeq :: (Ord a,S.Sequence seq) => Set a -> seq a +lookup :: Ord a => a -> Set a -> a +lookupM :: (Ord a,Monad m) => a -> Set a -> m a +lookupAll :: (Ord a,S.Sequence seq) => a -> Set a -> seq a +lookupWithDefault :: Ord a => a -> a -> Set a -> a +fold :: (a -> b -> b) -> b -> Set a -> b +fold1 :: (a -> a -> a) -> Set a -> a +fold' :: (a -> b -> b) -> b -> Set a -> b +fold1' :: (a -> a -> a) -> Set a -> a +filter :: Ord a => (a -> Bool) -> Set a -> Set a +partition :: Ord a => (a -> Bool) -> Set a -> (Set a, Set a) +strictWith :: (a -> b) -> Set a -> Set a + +deleteMin :: Ord a => Set a -> Set a +deleteMax :: Ord a => Set a -> Set a +unsafeInsertMin :: Ord a => a -> Set a -> Set a +unsafeInsertMax :: Ord a => a -> Set a -> Set a +unsafeFromOrdSeq :: (Ord a,S.Sequence seq) => seq a -> Set a +unsafeAppend :: Ord a => Set a -> Set a -> Set a +filterLT :: Ord a => a -> Set a -> Set a +filterLE :: Ord a => a -> Set a -> Set a +filterGT :: Ord a => a -> Set a -> Set a +filterGE :: Ord a => a -> Set a -> Set a +partitionLT_GE :: Ord a => a -> Set a -> (Set a, Set a) +partitionLE_GT :: Ord a => a -> Set a -> (Set a, Set a) +partitionLT_GT :: Ord a => a -> Set a -> (Set a, Set a) + +minView :: (Monad m) => Set a -> m (a, Set a) +minElem :: Set a -> a +maxView :: (Monad m) => Set a -> m (a, Set a) +maxElem :: Set a -> a +foldr :: (a -> b -> b) -> b -> Set a -> b +foldl :: (b -> a -> b) -> b -> Set a -> b +foldr1 :: (a -> a -> a) -> Set a -> a +foldl1 :: (a -> a -> a) -> Set a -> a +foldr' :: (a -> b -> b) -> b -> Set a -> b +foldl' :: (b -> a -> b) -> b -> Set a -> b +foldr1' :: (a -> a -> a) -> Set a -> a +foldl1' :: (a -> a -> a) -> Set a -> a +toOrdSeq :: (Ord a,S.Sequence seq) => Set a -> seq a + +intersection :: Ord a => Set a -> Set a -> Set a +difference :: Ord a => Set a -> Set a -> Set a +symmetricDifference :: Ord a => Set a -> Set a -> Set a +properSubset :: Ord a => Set a -> Set a -> Bool +subset :: Ord a => Set a -> Set a -> Bool + +fromSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a +insertWith :: Ord a => (a -> a -> a) -> a -> Set a -> Set a +insertSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq a -> Set a -> Set a +unionl :: Ord a => Set a -> Set a -> Set a +unionr :: Ord a => Set a -> Set a -> Set a +unionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a +unionSeqWith :: (Ord a,S.Sequence seq) => (a -> a -> a) -> seq (Set a) -> Set a +intersectionWith :: Ord a => (a -> a -> a) -> Set a -> Set a -> Set a +unsafeMapMonotonic :: Ord a => (a -> a) -> Set a -> Set a + +moduleName = "Data.Edison.Coll.UnbalancedSet" + +data Set a = E | T (Set a) a (Set a) + +-- invariants: +-- * Binary Search Tree order +structuralInvariant :: Ord a => Set a -> Bool +structuralInvariant t = bounded Nothing Nothing t + where bounded _ _ E = True + bounded lo hi (T l x r) = cmp_l lo x + && cmp_r x hi + && bounded lo (Just x) l + && bounded (Just x) hi r + + cmp_l Nothing _ = True + cmp_l (Just x) y = x < y + + cmp_r _ Nothing = True + cmp_r x (Just y) = x < y + + + +empty = E +singleton x = T E x E + +insertWith c x = ins + where ins E = T E x E + ins (T a y b) = + case compare x y of + LT -> T (ins a) y b + EQ -> T a (c x y) b + GT -> T a y (ins b) + +delete x 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 x b) i = sz a (sz b (i+1)) + +member x E = False +member x (T a y b) = + case compare x y of + LT -> member x a + EQ -> True + GT -> member x b + +lookupM x 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 f e E = e +fold f e (T a x b) = f x (fold f (fold f e a) b) + +fold' f e E = e +fold' f e (T a x b) = e `seq` f x $! (fold' f (fold' f e a) b) + +fold1 f E = error "UnbalancedSet.fold1: empty collection" +fold1 f (T a x b) = fold f (fold f x a) b + +fold1' f 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 x b) = b +deleteMin (T a x b) = T (deleteMin a) x b + +deleteMax E = E +deleteMax (T a x 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 xs 0 = (E,xs) + ins xs n = let m = n `div` 2 + (a,xs') = ins xs m + Just (x,xs'') = S.lview xs' + (b,xs''') = ins xs'' (n - m - 1) + in (T a x b,xs''') + +unsafeAppend a b = case minView b of + Nothing -> a + Just (x,b') -> T a x b' + +filterLT y 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 y 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 y 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 y 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 y 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 y 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 y 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 b) = x +minElem (T a x b) = 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 a x E) = x +maxElem (T a x b) = maxElem b + +foldr f e E = e +foldr f e (T a x b) = foldr f (f x (foldr f e b)) a + +foldr' f e E = e +foldr' f e (T a x b) = e `seq` foldr' f (f x $! (foldr' f e b)) a + +foldl f e E = e +foldl f e (T a x b) = foldl f (f (foldl f e a) x) b + +foldl' f e E = e +foldl' f e (T a x b) = e `seq` foldl' f ((f $! (foldl' f e a)) x) b + +foldr1 f 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' f 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 f 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' f 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 f 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 x r) = strict l `seq` strict r `seq` s + +strictWith f 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 c = moduleName} + +instance Ord a => C.OrdCollX (Set a) a where + {deleteMin = deleteMin; deleteMax = deleteMax; + unsafeInsertMin = unsafeInsertMin; unsafeInsertMax = unsafeInsertMax; + unsafeFromOrdSeq = unsafeFromOrdSeq; unsafeAppend = unsafeAppend; + filterLT = filterLT; filterLE = filterLE; filterGT = filterGT; + filterGE = filterGE; partitionLT_GE = partitionLT_GE; + partitionLE_GT = partitionLE_GT; partitionLT_GT = partitionLT_GT} + +instance Ord a => C.Coll (Set a) a where + {toSeq = toSeq; lookup = lookup; lookupM = lookupM; + lookupAll = lookupAll; lookupWithDefault = lookupWithDefault; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + filter = filter; partition = partition; strictWith = strictWith} + +instance Ord a => C.OrdColl (Set a) a where + {minView = minView; minElem = minElem; maxView = maxView; + maxElem = maxElem; foldr = foldr; foldr' = foldr'; + foldl = foldl; foldl' = foldl'; foldr1 = foldr1; foldr1' = foldr1'; + foldl1 = foldl1; foldl1' = foldl1'; toOrdSeq = toOrdSeq; + unsafeMapMonotonic = unsafeMapMonotonic} + +instance Ord a => C.SetX (Set a) a where + {intersection = intersection; difference = difference; + symmetricDifference = symmetricDifference; + properSubset = properSubset; subset = subset} + +instance Ord a => C.Set (Set a) a where + {fromSeqWith = fromSeqWith; insertWith = insertWith; + insertSeqWith = insertSeqWith; unionl = unionl; unionr = unionr; + unionWith = unionWith; unionSeqWith = unionSeqWith; + intersectionWith = intersectionWith} + +instance Ord a => C.OrdSetX (Set a) a + +instance Ord a => C.OrdSet (Set a) a + + +instance Ord a => Eq (Set a) where + xs == ys = C.toOrdList xs == C.toOrdList ys + +instance (Ord a, Show a) => Show (Set a) where + showsPrec = showsPrecUsingToList + +instance (Ord a, Read a) => Read (Set a) where + readsPrec = readsPrecUsingFromList + + +instance (Ord a, Arbitrary a) => Arbitrary (Set a) where + arbitrary = do xs <- arbitrary + return (Prelude.foldr insert empty xs) + + coarbitrary E = variant 0 + coarbitrary (T a x b) = + variant 1 . coarbitrary a . coarbitrary x . coarbitrary b + +instance (Ord a) => Monoid (Set a) where + mempty = empty + mappend = union + mconcat = unionSeq + +instance (Ord a) => Ord (Set a) where + compare = compareUsingToOrdList diff --git a/src/Data/Edison/Concrete/FingerTree.hs b/src/Data/Edison/Concrete/FingerTree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Concrete/FingerTree.hs @@ -0,0 +1,773 @@ +----------------------------------------------------------------------------- +-- | +-- 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, 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 + + +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 mapp 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 mapp 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 f 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 mapp _ Empty = mz +foldFT mz mapp 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 mapp Empty = error "FingerTree.reduce1: empty tree" +reduce1 mapp (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' mapp Empty = error "FingerTree.reduce1': empty tree" +reduce1' mapp (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 p 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) + + + +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) + ] + + 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) + ] + + 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) + ] + + 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 diff --git a/src/Data/Edison/Seq/BankersQueue.hs b/src/Data/Edison/Seq/BankersQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/BankersQueue.hs @@ -0,0 +1,419 @@ +-- | +-- Module : Data.Edison.Seq.BankersQueue +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Data.Edison.Seq.ListSeq as L +import Data.Monoid +import Control.Monad +import 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:xs) _ _) = x + +lheadM (Q _ [] _ _) = fail "BankersQueue.lheadM: empty sequence" +lheadM (Q _ (x:xs) _ _) = return x + +ltail (Q i (x:xs) ys j) = makeQ (i-1) xs ys j +ltail q = error "BankersQueue.ltail: empty sequence" + +ltailM (Q i (x:xs) ys j) = return (makeQ (i-1) xs ys j) +ltailM q = 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 i xs (y:ys) j) = y +rhead (Q _ [] [] _) = error "BankersQueue.rhead: empty sequence" +rhead (Q i xs [] _) = L.rhead xs + +rheadM (Q i xs (y:ys) j) = return y +rheadM (Q _ [] [] _) = fail "BankersQueue.rheadM: empty sequence" +rheadM (Q i xs [] _) = return (L.rhead xs) + +rtail (Q i xs (y:ys) j) = Q i xs ys (j-1) +rtail q@(Q _ [] [] _) = error "BankersQueue.rtail: empty sequence" +rtail (Q i xs [] _) = Q (i-1) (L.rtail xs) [] 0 + +rtailM (Q i xs (y:ys) j) = return (Q i xs ys (j-1)) +rtailM q@(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 xs ys 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 i 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 f e [] = e +revfoldr f e (x:xs) = revfoldr f (f x e) xs + +revfoldr' f e [] = e +revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs + +-- local fn on lists +revfoldl f e [] = e +revfoldl f e (x:xs) = f (revfoldl f e xs) x + +revfoldl' f e [] = e +revfoldl' f e (x:xs) = (\z -> f z x) $! (revfoldl f e xs) + +fold f e (Q i xs ys j) = L.foldr f (L.foldr f e ys) xs +fold' f e (Q i xs ys j) = (L.foldl' (flip f) $! (L.foldl' (flip f) e ys)) xs +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr f e (Q i xs ys j) = L.foldr f (revfoldr f e ys) xs +foldr' f e (Q i xs ys j) = L.foldr' f (revfoldr' f e ys) xs +foldl f e (Q i xs ys j) = revfoldl f (L.foldl f e xs) ys +foldl' f e (Q i xs ys j) = revfoldl' f (L.foldl' f e xs) ys + +foldr1 f (Q i xs (y:ys) j) = 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 i xs (y:ys) j) = 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 i (x:xs) ys j) = revfoldl f (L.foldl f x xs) ys +foldl1 f _ = error "BankersQueue.foldl1: empty sequence" + +foldl1' f (Q i (x:xs) ys j) = revfoldl' f (L.foldl' f x xs) ys +foldl1' f _ = 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 i xs ys j) = L.strict xs `seq` L.strict ys `seq` l +strictWith f l@(Q i xs ys j) = 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + q1 == q2 = + (size q1 == size q2) && (toList q1 == toList q2) + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = + do xs <- arbitrary + ys <- arbitrary + return (let i = L.size xs + j = L.size ys + in if i >= j then Q i xs ys j else Q j ys xs i) + + coarbitrary (Q i xs ys j) = coarbitrary xs . coarbitrary ys + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/BinaryRandList.hs b/src/Data/Edison/Seq/BinaryRandList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/BinaryRandList.hs @@ -0,0 +1,447 @@ +-- | +-- Module : Data.Edison.Seq.BinaryRandList +-- Copyright : Copyright (c) 1998-1999 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- Binary Random-Access lists. All functions have the standard running +-- times from "Data.Edison.Seq" except the following: +-- +-- * lcons, lhead, ltail*, lview*, rhead*, size, lookup*, update, adjust, drop @O( log n )@ +-- +-- * copy, inBounds @O( i )@ +-- +-- * append, reverseOnto @O( n1 + log n2 )@ +-- +-- * take, splitAt @O( i + log n )@ +-- +-- * subseq @O( log n + len )@ +-- +-- * zip @O( min( n1, n2 ) + log max( n1, n2 ) )@ +-- +-- /References:/ +-- +-- * Chris Okasaki. /Purely Functional Data Structures/. 1998. +-- Section 10.1.2. + +module Data.Edison.Seq.BinaryRandList ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import Control.Monad.Identity +import Data.Maybe + +import Data.Edison.Prelude +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Monad m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Monad m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Monad m) => Seq a -> m (Seq a) +rview :: (Monad m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Monad m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Monad m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Monad m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.BinaryRandList" + + +data Seq a = E | Even (Seq (a,a)) | Odd a (Seq (a,a)) deriving (Eq) + +-- not exported, rewrite as bit ops? +--even n = (n `mod` 2) == 0 +--odd n = (n `mod` 2) <> 0 +half n = n `div` 2 + +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 ps) = x + +lheadM E = fail "BinaryRandList.lheadM: empty sequence" +lheadM (Even ps) = return (fst (lhead ps)) +lheadM (Odd x ps) = return (x) + +ltail E = error "BinaryRandList.ltail: empty sequence" +ltail (Even ps) = case lview ps of + Just ((x,y), ps') -> Odd y ps' + Nothing -> error "BinaryRandList.ltail: bug!" +ltail (Odd x ps) = mkEven ps + +ltailM E = fail "BinaryRandList.ltailM: empty sequence" +ltailM (Even ps) = case lview ps of + Just ((x,y), ps') -> return (Odd y ps') + Nothing -> error "BinaryRandList.ltailM: bug!" +ltailM (Odd x ps) = return (mkEven ps) + +rhead E = error "BinaryRandList.rhead: empty sequence" +rhead (Even ps) = snd (rhead ps) +rhead (Odd x E) = x +rhead (Odd x 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 x ps) = return (snd (rhead ps)) + + +null E = True +null _ = False + +size E = 0 +size (Even ps) = 2 * size ps +size (Odd x ps) = 1 + 2 * size ps + +map f E = E +map f (Even ps) = Even (map (\(x,y) -> (f x,f y)) ps) +map f (Odd x ps) = Odd (f x) (map (\(x,y) -> (f x,f y)) ps) + +fold = foldr +fold' = foldr' +fold1 = fold1UsingFold +fold1' = fold1'UsingFold' + +foldr f 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' f 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 f 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' f 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 f E = error "BinaryRandList.reduce1: empty seq" +reduce1 f (Even ps) = reduce1 f (map (uncurry f) ps) +reduce1 f (Odd x E) = x +reduce1 f (Odd x ps) = f x (reduce1 f (map (uncurry f) ps)) + +reduce1' f E = error "BinaryRandList.reduce1': empty seq" +reduce1' f (Even ps) = reduce1' f (map (uncurry f) ps) +reduce1' f (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 i = False + inb (Even ps) i = inb ps (half i) + inb (Odd x 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 i f = 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 f i 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 f (x,y) = (f x,y) +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 xs = E + tak i 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 i 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 x l') = strict l' `seq` l + +strictWith f l@E = l +strictWith f l@(Even l') = strictWith (\ (x,y) -> f x `seq` f y) l' `seq` l +strictWith f l@(Odd x l') = 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +-- instance Eq (Seq a) is derived + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + return (fromList xs) + + coarbitrary E = variant 0 + coarbitrary (Even ps) = variant 1 . coarbitrary ps + coarbitrary (Odd x ps) = variant 2 . coarbitrary x . coarbitrary ps + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/BraunSeq.hs b/src/Data/Edison/Seq/BraunSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/BraunSeq.hs @@ -0,0 +1,548 @@ +-- | +-- Module : Data.Edison.Seq.BraunSeq +-- Copyright : Copyright (c) 1998-1999 Chris Okasaki +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) +-- +-- One-sided Braun sequences. All running times are as listed in +-- "Data.Edison.Seq" except the following: +-- +-- * lview, lcons, ltail* @O( log n )@ +-- +-- * rcons, rview, rhead*, rtail*, size @O( log^2 n )@ +-- +-- * copy, inBounds, lookup*, update, adjust @O( log i )@ +-- +-- * append @O( n1 log n2 )@ +-- +-- * concat @O( n + m log m )@ +-- +-- * drop, splitAt @O( i log n )@ +-- +-- * subseq @O( i log n + len )@ +-- +-- * reverseOnto @O( n1 log n2 )@ +-- +-- * concatMap, (>>=) @O( n * t + m log m )@, where @n@ is the length of the input sequence +-- @m@ is the length of the output sequence and @t@ +-- is the running time of @f@ +-- +-- By keeping track of the size, we could get rcons, rview, rhead*, and rtail* +-- down to @O(log n)@ as well; furthermore, size would be @O( 1 )@. +-- +-- /References:/ +-- +-- * Rob Hoogerwoord. \"A symmetric set of efficient list operations\". +-- /Journal of Functional Programming/, 2(4):505--513, 1992. +-- +-- * Rob Hoogerwoord. \"A Logarithmic Implementation of Flexible Arrays\". +-- /Mathematics of Program Construction/ (MPC'92), pages 191-207. +-- +-- * Chris Okasaki. \"Three algorithms on Braun Trees\". +-- /Journal of Function Programming/ 7(6):661-666. Novemebr 1997. + +module Data.Edison.Seq.BraunSeq ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldrWithIndex',foldlWithIndex,foldlWithIndex', + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import Control.Monad +import Control.Monad.Identity +import Data.Maybe +import Data.Monoid +import Test.QuickCheck + +import Data.Edison.Prelude +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 xs ys = ys + app n 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 E _ = E +combine (B x a b) c = B x c (combine a b) + +lhead E = error "BraunSeq.lhead: empty sequence" +lhead (B x a b) = x + +lheadM E = fail "BraunSeq.lheadM: empty sequence" +lheadM (B x a b) = return x + +ltail E = error "BraunSeq.ltail: empty sequence" +ltail (B x a b) = combine a b + +ltailM E = fail "BraunSeq.ltailM: empty sequence" +ltailM (B x a b) = return (combine a b) + +-- not exported +-- precondition: i >= 0 +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 x a b) = 1 + n + n + diff n a + where n = size b + + diff 0 E = 0 + diff 0 (B x a b) = 1 + diff i (B x 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 n 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 n 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 n 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 k [] = [] + 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 x E _ : ts) = ([],[]) + children (B x a E : ts) = (a : leftChildren ts, []) + children (B x a b : ts) = (a : ts1, b : ts2) + where (ts1, ts2) = children ts + children _ = error "BraunSeq.toList: bug!" + + leftChildren [] = [] + leftChildren (B x E _ : ts) = [] + leftChildren (B x a b : ts) = a : leftChildren ts + leftChildren _ = error "BraunSeq.toList: bug!" + + root (B x a b) = x + root _ = error "BraunSeq.toList: bug!" + + left (B x a b) = a + left _ = error "BraunSeq.toList: bug!" + +map f 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 i = False + inb (B x 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 i = 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 i = 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 i 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 i 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 i d 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 n 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 n E = E + dr n t@(B x 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 f _ _ = 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 fn _ _ _ = 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 f g 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 f g h 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 x l r) = strict l `seq` strict r `seq` s + +strictWith f 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 E = True +structuralInvariant (B _ l r) = isJust (check l r) + + where 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +-- instance Eq (Seq a) is derived + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = arbitrary >>= (return . fromList) + coarbitrary xs = coarbitrary (toList xs) + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/Defaults.hs b/src/Data/Edison/Seq/Defaults.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/Defaults.hs @@ -0,0 +1,513 @@ +-- | +-- Module : Data.Edison.Seq.Defaults +-- Copyright : Copyright (c) 1998 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.Prelude +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 x -> 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 i 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 diff --git a/src/Data/Edison/Seq/FingerSeq.hs b/src/Data/Edison/Seq/FingerSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/FingerSeq.hs @@ -0,0 +1,375 @@ +-- | +-- Module : Data.Edison.Seq.FingerSeq +-- Copyright : Copyright (c) 2006 Robert Dockins +-- License : MIT; see COPYRIGHT file for terms and conditions +-- +-- Maintainer : robdockins AT fastmail DOT fm +-- Stability : stable +-- Portability : GHC, Hugs (MPTC and FD) + + +module Data.Edison.Seq.FingerSeq ( + -- * Sequence Type + Seq, -- instance of Sequence, Functor, Monad, MonadPlus + + -- * Sequence Operations + empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail, + lheadM,ltailM,rheadM,rtailM, + null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap, + fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1', + reducer,reducer',reducel,reducel',reduce1,reduce1', + copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust, + mapWithIndex,foldrWithIndex,foldlWithIndex, + take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile, + zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3, + strict, strictWith, + + -- * Unit testing + structuralInvariant, + + -- * Documentation + moduleName +) where + +import qualified Prelude +import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1, + filter,takeWhile,dropWhile,lookup,take,drop,splitAt, + zip,zip3,zipWith,zipWith3,unzip,unzip3,null) + +import Data.Edison.Prelude +import qualified Data.Edison.Seq as S +import Data.Edison.Seq.Defaults +import Control.Monad +import Control.Monad.Identity +import Data.Monoid +import Test.QuickCheck + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base (unsafeCoerce#) +#endif + + +import qualified Data.Edison.Concrete.FingerTree as FT + +moduleName :: String +moduleName = "Data.Edison.Seq.FingerSeq" + + +newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show) +unSizeM (SizeM x) = x + +instance Monoid SizeM where + mempty = 0 + mappend = (+) + + +newtype Elem a = Elem a +unElem (Elem x) = x + +instance Measured SizeM (Elem a) where + measure _ = 1 + +newtype Seq a = Seq (FT.FingerTree SizeM (Elem a)) +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 = 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + xs == ys = toList xs == toList ys + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Elem a) where + arbitrary = arbitrary >>= return . Elem + coarbitrary = coarbitrary . unElem + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = arbitrary >>= return . Seq + coarbitrary = coarbitrary . unSeq + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/JoinList.hs b/src/Data/Edison/Seq/JoinList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/JoinList.hs @@ -0,0 +1,427 @@ +-- | +-- Module : Data.Edison.Seq.JoinList +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import Control.Monad +import Data.Monoid +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Monad m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Monad m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Monad m) => Seq a -> m (Seq a) +rview :: (Monad m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Monad m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Monad m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Monad m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.JoinList" + +data Seq a = E | L a | A (Seq a) (Seq a) + -- invariant: E never a child of A + +half :: Int -> Int +half n = n `div` 2 + +empty = E +singleton = L + +lcons x E = L x +lcons x xs = A (L x) xs + +rcons x E = L x +rcons x xs = A xs (L x) + +append E ys = ys +append xs E = xs +append xs ys = A xs ys + + +-- path reversal on lview/ltail + +lview E = fail "JoinList.lview: empty sequence" +lview (L x) = return (x, E) +lview (A xs ys) = lvw xs ys + where lvw E zs = 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 ys) = lhead xs + +lheadM E = fail "JoinList.lheadM: empty sequence" +lheadM (L x) = return x +lheadM (A xs ys) = lheadM xs + +ltail E = error "JoinList.ltail: empty sequence" +ltail (L x) = E +ltail (A xs ys) = ltl xs ys + where ltl E zs = error "JoinList.ltl: bug" + ltl (L x) zs = zs + ltl (A xs ys) zs = ltl xs (A ys zs) + +ltailM E = fail "JoinList.ltailM: empty sequence" +ltailM (L x) = return E +ltailM (A xs ys) = return (ltl xs ys) + where ltl E zs = error "JoinList.ltl: bug" + ltl (L x) 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 xs _ = error "JoinList.rvw: bug" + +rhead E = error "JoinList.rhead: empty sequence" +rhead (L x) = x +rhead (A xs ys) = rhead ys + +rheadM E = fail "JoinList.rheadM: empty sequence" +rheadM (L x) = return x +rheadM (A xs ys) = rheadM ys + +rtail E = error "JoinList.rtail: empty sequence" +rtail (L x) = 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 x) = xs + rtl xs _ = error "JoinList.rtl: bug" + +rtailM E = fail "JoinList.rtailM: empty sequence" +rtailM (L x) = 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 x) = xs + rtl xs _ = error "JoinList.rtl: bug" + +null E = True +null _ = False + +size xs = sz xs (0::Int) + where sz E n = n + sz (L x) 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 f 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 f 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' f 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 f 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' f 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 f E = error "JoinList.foldr1: empty sequence" +foldr1 f (L x) = x +foldr1 f (A xs ys) = foldr f (foldr1 f ys) xs + +foldr1' f E = error "JoinLis.foldr1': empty sequence" +foldr1' f (L x) = x +foldr1' f (A xs ys) = foldr' f (foldr1' f ys) xs + +foldl1 f E = error "JoinList.foldl1: empty sequence" +foldl1 f (L x) = x +foldl1 f (A xs ys) = foldl f (foldl1 f xs) ys + +foldl1' f E = error "JoinList.foldl1': empty sequence" +foldl1' f (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 x) = s +strict s@(A l r) = strict l `seq` strict r `seq` s + +strictWith f s@E = s +strictWith f s@(L x) = f x `seq` s +strictWith f s@(A l r) = 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + xs == ys = toList xs == toList ys + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = sized arbTree + where arbTree 0 = return E + arbTree 1 = liftM L arbitrary + arbTree n = + frequency [(1, liftM L arbitrary), + (4, liftM2 A (arbTree (n `div` 2)) + (arbTree (n `div` 2)))] + + coarbitrary E = variant 0 + coarbitrary (L x) = variant 1 . coarbitrary x + coarbitrary (A xs ys) = variant 2 . coarbitrary xs . coarbitrary ys + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/MyersStack.hs b/src/Data/Edison/Seq/MyersStack.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/MyersStack.hs @@ -0,0 +1,438 @@ +-- | +-- Module : Data.Edison.Seq.MyersStack +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import Control.Monad +import Control.Monad.Identity +import Data.Monoid +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Monad m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Monad m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Monad m) => Seq a -> m (Seq a) +rview :: (Monad m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Monad m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Monad m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Monad m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.MyersStack" + + +data Seq a = E | C !Int a (Seq a) (Seq a) + -- what about strictness flags on tail and jump-tail? + +-- auxiliary function +jump (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 xs _) = x + +lheadM E = fail "MyersStack.lheadM: empty sequence" +lheadM (C _ x xs _) = return x + +ltail E = error "MyersStack.ltail: empty sequence" +ltail (C _ x xs _) = xs + +ltailM E = fail "MyersStack.ltailM: empty sequence" +ltailM (C _ x 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 x xs (C _ y ys ys') = rh y ys ys' + rh x (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 x xs (C _ y ys ys') = rh y ys ys' + rh x (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 y 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 y 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 x xs xs') = j + size xs' + +reverseOnto E ys = ys +reverseOnto (C _ x xs _) ys = reverseOnto xs (lcons x ys) + +map f E = E +map f (C j x xs 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 f e E = e +foldr f e (C _ x xs _) = f x (foldr f e xs) + +foldr' f e E = e +foldr' f e (C _ x xs _) = f x $! (foldr' f e xs) + +foldl f e E = e +foldl f e (C _ x xs _) = foldl f (f e x) xs + +foldl' f e E = e +foldl' f e (C _ x xs _) = e `seq` foldl' f (f e x) xs + +foldr1 f 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' f 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 f E = error "MyersStack.foldl1: empty sequence" +foldl1 f (C _ x xs _) = foldl f x xs + +foldl1' f E = error "MyersStack.foldl1': empty sequence" +foldl1' f (C _ x xs _ ) = foldl' f x xs + +inBounds i xs = inb xs i + where inb E i = False + inb (C j x xs 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 i = 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 i = 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 i E = E + upd 0 (C j x 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 i 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 n E = E + drp n (C j x xs xs') + | n < j = drp (n - 1) xs + | otherwise = drp (n - j) xs' + +unzip E = (E, E) +unzip (C j (x,y) ps 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 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 f g 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 f g h 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 i x xs _) = strict xs `seq` s + +strictWith f s@E = s +strictWith f s@(C i 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + xs == ys = + (size xs == size ys) && (toList xs == toList ys) + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + return (fromList xs) + + coarbitrary xs = coarbitrary (toList xs) + +instance Monoid (Seq a) where + mempty = empty + mappend = append + + +------------- + +{- +questions: + - any benefit to + E | C1 x xs | CJ Int# x xs xs' + + - any benefit to length instead of delta? + + - any benefit to delta not counting x (i.e., base 0 instead of base 1)? + +I don't believe any will do any better, except possibly the first +-} + diff --git a/src/Data/Edison/Seq/RandList.hs b/src/Data/Edison/Seq/RandList.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/RandList.hs @@ -0,0 +1,481 @@ +-- | +-- Module : Data.Edison.Seq.RandList +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S( Sequence(..) ) +import Data.Edison.Seq.Defaults +import Control.Monad +import Control.Monad.Identity +import Data.Monoid +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Monad m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Monad m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Monad m) => Seq a -> m (Seq a) +rview :: (Monad m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Monad m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Monad m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Monad m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +moduleName = "Data.Edison.Seq.RandList" + + +data Tree a = L a | T a (Tree a) (Tree a) deriving (Eq) +data Seq a = E | C !Int (Tree a) (Seq a) deriving (Eq) + +half :: Int -> Int +half n = n `quot` 2 -- use a shift? + +empty = E +singleton x = C 1 (L x) E + +lcons x xs@(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 x s 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) xs) = x +lhead (C _ (T x s t) xs) = x + +lheadM E = fail "RandList.lheadM: empty sequence" +lheadM (C _ (L x) xs) = return x +lheadM (C _ (T x s t) xs) = return x + +ltail E = error "RandList.ltail: empty sequence" +ltail (C _ (L x) xs) = xs +ltail (C i (T x s t) xs) = C j s (C j t xs) + where j = half i + +ltailM E = fail "RandList.ltailM: empty sequence" +ltailM (C _ (L x) xs) = return xs +ltailM (C i (T x 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 x s t) = treeLast t +rhead (C _ t xs) = rhead xs + +rheadM E = fail "RandList.rhead: empty sequence" +rheadM (C _ t E) = return(treeLast t) + where treeLast (L x) = x + treeLast (T x s t) = treeLast t +rheadM (C _ t xs) = rheadM xs + + +null E = True +null _ = False + +size xs = sz xs + where sz E = (0::Int) + sz (C j t 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 f 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 f 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' f 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 f 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' f 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 j 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 j 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 i = False + inb (C j t 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 i = 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 i = 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 i 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 j t@(L x) + | 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 i 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 j 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 i 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 i j (L x) xs = error "RandList.drop: bug. Impossible case!" + drpTree i j (T x 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 j t xs) = strictTree t `seq` strict xs `seq` s + +strictTree t@(L x) = t +strictTree t@(T x l r) = strictTree l `seq` strictTree r `seq` t + +strictWith f s@E = s +strictWith f s@(C j t xs) = strictWithTree f t `seq` strictWith f xs `seq` s + +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 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 x 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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + return (fromList xs) + + coarbitrary xs = coarbitrary (toList xs) + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/RevSeq.hs b/src/Data/Edison/Seq/RevSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/RevSeq.hs @@ -0,0 +1,382 @@ +-- | +-- Module : Data.Edison.Seq.RevSeq +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults -- only used by concatMap +import Control.Monad +import Data.Monoid +import Test.QuickCheck + + +-- signatures for exported functions +moduleName :: String +instanceName :: S.Sequence s => Rev s a -> String +empty :: S.Sequence s => Rev s a +singleton :: S.Sequence s => a -> Rev s a +lcons :: S.Sequence s => a -> Rev s a -> Rev s a +rcons :: S.Sequence s => a -> Rev s a -> Rev s a +append :: S.Sequence s => Rev s a -> Rev s a -> Rev s a +lview :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a) +lhead :: S.Sequence s => Rev s a -> a +lheadM :: (S.Sequence s, Monad m) => Rev s a -> m a +ltail :: S.Sequence s => Rev s a -> Rev s a +ltailM :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a) +rview :: (S.Sequence s, Monad m) => Rev s a -> m (a, Rev s a) +rhead :: S.Sequence s => Rev s a -> a +rheadM :: (S.Sequence s, Monad m) => Rev s a -> m a +rtail :: S.Sequence s => Rev s a -> Rev s a +rtailM :: (S.Sequence s, Monad m) => Rev s a -> m (Rev s a) +null :: S.Sequence s => Rev s a -> Bool +size :: S.Sequence s => Rev s a -> Int +concat :: S.Sequence s => Rev s (Rev s a) -> Rev s a +reverse :: S.Sequence s => Rev s a -> Rev s a +reverseOnto :: S.Sequence s => Rev s a -> Rev s a -> Rev s a +fromList :: S.Sequence s => [a] -> Rev s a +toList :: S.Sequence s => Rev s a -> [a] +map :: S.Sequence s => (a -> b) -> Rev s a -> Rev s b +concatMap :: S.Sequence s => (a -> Rev s b) -> Rev s a -> Rev s b +fold :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +fold' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +fold1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +fold1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldr :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +foldl :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b +foldr1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldl1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +reducer :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reducel :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reduce1 :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldr' :: S.Sequence s => (a -> b -> b) -> b -> Rev s a -> b +foldl' :: S.Sequence s => (b -> a -> b) -> b -> Rev s a -> b +foldr1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +foldl1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +reducer' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reducel' :: S.Sequence s => (a -> a -> a) -> a -> Rev s a -> a +reduce1' :: S.Sequence s => (a -> a -> a) -> Rev s a -> a +copy :: S.Sequence s => Int -> a -> Rev s a +inBounds :: S.Sequence s => Int -> Rev s a -> Bool +lookup :: S.Sequence s => Int -> Rev s a -> a +lookupM :: (S.Sequence s, Monad m) => Int -> Rev s a -> m a +lookupWithDefault :: S.Sequence s => a -> Int -> Rev s a -> a +update :: S.Sequence s => Int -> a -> Rev s a -> Rev s a +adjust :: S.Sequence s => (a -> a) -> Int -> Rev s a -> Rev s a +mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Rev s a -> Rev s b +foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b +foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b +foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Rev s a -> b +foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Rev s a -> b +take :: S.Sequence s => Int -> Rev s a -> Rev s a +drop :: S.Sequence s => Int -> Rev s a -> Rev s a +splitAt :: S.Sequence s => Int -> Rev s a -> (Rev s a, Rev s a) +subseq :: S.Sequence s => Int -> Int -> Rev s a -> Rev s a +filter :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a +partition :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a) +takeWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a +dropWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> Rev s a +splitWhile :: S.Sequence s => (a -> Bool) -> Rev s a -> (Rev s a, Rev s a) +zip :: S.Sequence s => Rev s a -> Rev s b -> Rev s (a,b) +zip3 :: S.Sequence s => Rev s a -> Rev s b -> Rev s c -> Rev s (a,b,c) +zipWith :: S.Sequence s => (a -> b -> c) -> Rev s a -> Rev s b -> Rev s c +zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Rev s a -> Rev s b -> Rev s c -> Rev s d +unzip :: S.Sequence s => Rev s (a,b) -> (Rev s a, Rev s b) +unzip3 :: S.Sequence s => Rev s (a,b,c) -> (Rev s a, Rev s b, Rev s c) +unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Rev s a -> (Rev s b, Rev s c) +unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Rev s a -> (Rev s b, Rev s c, Rev s d) +strict :: S.Sequence s => Rev s a -> Rev s a +strictWith :: S.Sequence s => (a -> b) -> Rev s a -> Rev s a +structuralInvariant :: S.Sequence s => Rev s a -> Bool + +-- bonus functions, not in Sequence signature +fromSeq :: S.Sequence s => s a -> Rev s a +toSeq :: S.Sequence s => Rev s a -> s a + + +moduleName = "Data.Edison.Seq.RevSeq" +instanceName (N m 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 m 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 m xs) = S.rhead xs + +lheadM (N m xs) = S.rheadM xs + +ltail (N (-1) xs) = error "RevSeq.ltail: empty sequence" +ltail (N m xs) = N (m-1) (S.rtail xs) + +ltailM (N (-1) xs) = 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 m xs) = S.lhead xs + +rheadM (N m xs) = S.lheadM xs + +rtail (N (-1) xs) = error "RevSeq.rtail: empty sequence" +rtail (N m xs) = N (m-1) (S.ltail xs) + +rtailM (N (-1) xs) = fail "RevSeq.rtailM: empty sequence" +rtailM (N m xs) = return (N (m-1) (S.ltail xs)) + +null (N m xs) = m == -1 +size (N m xs) = m+1 +concat (N m 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 m 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 m xs) = S.fold f e xs +fold' f e (N m xs) = S.fold' f e xs +fold1 f (N m xs) = S.fold1 f xs +fold1' f (N m xs) = S.fold1' f xs +foldr f e (N m xs) = S.foldl (flip f) e xs +foldr' f e (N m xs) = S.foldl' (flip f) e xs +foldl f e (N m xs) = S.foldr (flip f) e xs +foldl' f e (N m xs) = S.foldr' (flip f) e xs +foldr1 f (N m xs) = S.foldl1 (flip f) xs +foldr1' f (N m xs) = S.foldl1' (flip f) xs +foldl1 f (N m xs) = S.foldr1 (flip f) xs +foldl1' f (N m xs) = S.foldr1' (flip f) xs +reducer f e (N m xs) = S.reducel (flip f) e xs +reducer' f e (N m xs) = S.reducel' (flip f) e xs +reducel f e (N m xs) = S.reducer (flip f) e xs +reducel' f e (N m xs) = S.reducer' (flip f) e xs +reduce1 f (N m xs) = S.reduce1 (flip f) xs +reduce1' f (N m xs) = S.reduce1' (flip f) xs + +copy n x + | n <= 0 = empty + | otherwise = N (n-1) (S.copy n x) + +inBounds i (N m xs) = (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 i s') = S.strict s' `seq` s +strictWith f s@(N i s') = S.strictWith f s' `seq` s + +structuralInvariant (N i s) = i == ((S.size s) - 1) + +-- instances + +instance S.Sequence s => S.Sequence (Rev s) where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName = instanceName} + +instance S.Sequence s => Functor (Rev s) where + fmap = map + +instance S.Sequence s => Monad (Rev s) where + return = singleton + xs >>= k = concatMap k xs + +instance S.Sequence s => MonadPlus (Rev s) where + mplus = append + mzero = empty + +instance Eq (s a) => Eq (Rev s a) where + (N m xs) == (N n ys) = (m == n) && (xs == ys) + +instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Rev s a) where + compare = defaultCompare + +instance (S.Sequence s, Show (s a)) => Show (Rev s a) where + showsPrec i xs rest + | i == 0 = L.concat [ moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest] + | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)] + +instance (S.Sequence s, Read (s a)) => Read (Rev s a) where + readsPrec i 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) + + coarbitrary xs = coarbitrary (toSeq xs) + +instance S.Sequence s => Monoid (Rev s a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/SimpleQueue.hs b/src/Data/Edison/Seq/SimpleQueue.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/SimpleQueue.hs @@ -0,0 +1,369 @@ +-- | +-- Module : Data.Edison.Seq.SimpleQueue +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S ( Sequence(..) ) +import Data.Edison.Seq.Defaults +import qualified Data.Edison.Seq.ListSeq as L +import Data.Monoid +import Control.Monad +import Test.QuickCheck + +-- signatures for exported functions +moduleName :: String +empty :: Seq a +singleton :: a -> Seq a +lcons :: a -> Seq a -> Seq a +rcons :: a -> Seq a -> Seq a +append :: Seq a -> Seq a -> Seq a +lview :: (Monad m) => Seq a -> m (a, Seq a) +lhead :: Seq a -> a +lheadM :: (Monad m) => Seq a -> m a +ltail :: Seq a -> Seq a +ltailM :: (Monad m) => Seq a -> m (Seq a) +rview :: (Monad m) => Seq a -> m (a, Seq a) +rhead :: Seq a -> a +rheadM :: (Monad m) => Seq a -> m a +rtail :: Seq a -> Seq a +rtailM :: (Monad m) => Seq a -> m (Seq a) +null :: Seq a -> Bool +size :: Seq a -> Int +concat :: Seq (Seq a) -> Seq a +reverse :: Seq a -> Seq a +reverseOnto :: Seq a -> Seq a -> Seq a +fromList :: [a] -> Seq a +toList :: Seq a -> [a] +map :: (a -> b) -> Seq a -> Seq b +concatMap :: (a -> Seq b) -> Seq a -> Seq b +fold :: (a -> b -> b) -> b -> Seq a -> b +fold' :: (a -> b -> b) -> b -> Seq a -> b +fold1 :: (a -> a -> a) -> Seq a -> a +fold1' :: (a -> a -> a) -> Seq a -> a +foldr :: (a -> b -> b) -> b -> Seq a -> b +foldl :: (b -> a -> b) -> b -> Seq a -> b +foldr1 :: (a -> a -> a) -> Seq a -> a +foldl1 :: (a -> a -> a) -> Seq a -> a +reducer :: (a -> a -> a) -> a -> Seq a -> a +reducel :: (a -> a -> a) -> a -> Seq a -> a +reduce1 :: (a -> a -> a) -> Seq a -> a +foldr' :: (a -> b -> b) -> b -> Seq a -> b +foldl' :: (b -> a -> b) -> b -> Seq a -> b +foldr1' :: (a -> a -> a) -> Seq a -> a +foldl1' :: (a -> a -> a) -> Seq a -> a +reducer' :: (a -> a -> a) -> a -> Seq a -> a +reducel' :: (a -> a -> a) -> a -> Seq a -> a +reduce1' :: (a -> a -> a) -> Seq a -> a +copy :: Int -> a -> Seq a +inBounds :: Int -> Seq a -> Bool +lookup :: Int -> Seq a -> a +lookupM :: (Monad m) => Int -> Seq a -> m a +lookupWithDefault :: a -> Int -> Seq a -> a +update :: Int -> a -> Seq a -> Seq a +adjust :: (a -> a) -> Int -> Seq a -> Seq a +mapWithIndex :: (Int -> a -> b) -> Seq a -> Seq b +foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b +foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b +foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b +take :: Int -> Seq a -> Seq a +drop :: Int -> Seq a -> Seq a +splitAt :: Int -> Seq a -> (Seq a, Seq a) +subseq :: Int -> Int -> Seq a -> Seq a +filter :: (a -> Bool) -> Seq a -> Seq a +partition :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +takeWhile :: (a -> Bool) -> Seq a -> Seq a +dropWhile :: (a -> Bool) -> Seq a -> Seq a +splitWhile :: (a -> Bool) -> Seq a -> (Seq a, Seq a) +zip :: Seq a -> Seq b -> Seq (a,b) +zip3 :: Seq a -> Seq b -> Seq c -> Seq (a,b,c) +zipWith :: (a -> b -> c) -> Seq a -> Seq b -> Seq c +zipWith3 :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d +unzip :: Seq (a,b) -> (Seq a, Seq b) +unzip3 :: Seq (a,b,c) -> (Seq a, Seq b, Seq c) +unzipWith :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c) +unzipWith3 :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d) +strict :: Seq a -> Seq a +strictWith :: (a -> b) -> Seq a -> Seq a +structuralInvariant :: Seq a -> Bool + +moduleName = "Data.Edison.Seq.SimpleQueue" + + +data Seq a = Q [a] [a] + -- invariant: front empty only if rear also empty + +-- not exported +makeQ [] 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:xs) _) = x + +lheadM (Q [] _) = fail "SimpleQueue.lheadM: empty sequence" +lheadM (Q (x:xs) _) = return x + +ltail (Q [x] ys) = Q (L.reverse ys) [] +ltail (Q (x:xs) ys) = Q xs ys +ltail q@(Q [] _) = error "SimpleQueue.ltail: empty sequence" + +ltailM (Q [x] ys) = return (Q (L.reverse ys) []) +ltailM (Q (x:xs) ys) = return (Q xs ys) +ltailM q@(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 xs (y:ys)) = y +rhead (Q [] []) = error "SimpleQueue.rhead: empty sequence" +rhead (Q xs []) = L.rhead xs + +rheadM (Q xs (y:ys)) = return y +rheadM (Q [] []) = fail "SimpleQueue.rheadM: empty sequence" +rheadM (Q xs []) = return (L.rhead xs) + +rtail (Q xs (y:ys)) = Q xs ys +rtail q@(Q [] []) = error "SimpleQueue.rtail: empty sequence" +rtail (Q xs []) = Q (L.rtail xs) [] + +rtailM (Q xs (y:ys)) = return (Q xs ys) +rtailM q@(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 f e [] = e +revfoldr f e (x:xs) = revfoldr f (f x e) xs + +revfoldr' f e [] = e +revfoldr' f e (x:xs) = e `seq` revfoldr' f (f x e) xs + +-- local fn on lists +revfoldl f e [] = e +revfoldl f e (x:xs) = f (revfoldl f e xs) x + +revfoldl' f 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 f (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' f (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 f (Q [] _) = error "SimpleQueue.foldl1: empty sequence" + +foldl1' f (Q (x:xs) ys) = revfoldl' f (L.foldl' f x xs) ys +foldl1' f (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 s = moduleName} + +instance Functor Seq where + fmap = map + +instance Monad Seq where + return = singleton + xs >>= k = concatMap k xs + +instance MonadPlus Seq where + mplus = append + mzero = empty + +instance Eq a => Eq (Seq a) where + q1 == q2 = toList q1 == toList q2 + +instance Ord a => Ord (Seq a) where + compare = defaultCompare + +instance Show a => Show (Seq a) where + showsPrec = showsPrecUsingToList + +instance Read a => Read (Seq a) where + readsPrec = readsPrecUsingFromList + +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = do xs <- arbitrary + ys <- arbitrary + return (if L.null xs then Q ys [] else Q xs ys) + + coarbitrary (Q xs ys) = coarbitrary xs . coarbitrary ys + +instance Monoid (Seq a) where + mempty = empty + mappend = append diff --git a/src/Data/Edison/Seq/SizedSeq.hs b/src/Data/Edison/Seq/SizedSeq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Edison/Seq/SizedSeq.hs @@ -0,0 +1,355 @@ +-- | +-- Module : Data.Edison.Seq.SizedSeq +-- Copyright : Copyright (c) 1998-1999 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 Data.Edison.Prelude +import qualified Data.Edison.Seq as S +import qualified Data.Edison.Seq.ListSeq as L +import Data.Edison.Seq.Defaults -- only used by concatMap +import Data.Monoid +import Control.Monad +import Test.QuickCheck + + +-- signatures for exported functions +moduleName :: String +instanceName :: S.Sequence s => Sized s a -> String +empty :: S.Sequence s => Sized s a +singleton :: S.Sequence s => a -> Sized s a +lcons :: S.Sequence s => a -> Sized s a -> Sized s a +rcons :: S.Sequence s => a -> Sized s a -> Sized s a +append :: S.Sequence s => Sized s a -> Sized s a -> Sized s a +lview :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a) +lhead :: S.Sequence s => Sized s a -> a +lheadM :: (S.Sequence s, Monad m) => Sized s a -> m a +ltail :: S.Sequence s => Sized s a -> Sized s a +ltailM :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a) +rview :: (S.Sequence s, Monad m) => Sized s a -> m (a, Sized s a) +rhead :: S.Sequence s => Sized s a -> a +rheadM :: (S.Sequence s, Monad m) => Sized s a -> m a +rtail :: S.Sequence s => Sized s a -> Sized s a +rtailM :: (S.Sequence s, Monad m) => Sized s a -> m (Sized s a) +null :: S.Sequence s => Sized s a -> Bool +size :: S.Sequence s => Sized s a -> Int +concat :: S.Sequence s => Sized s (Sized s a) -> Sized s a +reverse :: S.Sequence s => Sized s a -> Sized s a +reverseOnto :: S.Sequence s => Sized s a -> Sized s a -> Sized s a +fromList :: S.Sequence s => [a] -> Sized s a +toList :: S.Sequence s => Sized s a -> [a] +map :: S.Sequence s => (a -> b) -> Sized s a -> Sized s b +concatMap :: S.Sequence s => (a -> Sized s b) -> Sized s a -> Sized s b +fold :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +fold' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +fold1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +fold1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldr :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +foldl :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b +foldr1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldl1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +reducer :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reducel :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reduce1 :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldr' :: S.Sequence s => (a -> b -> b) -> b -> Sized s a -> b +foldl' :: S.Sequence s => (b -> a -> b) -> b -> Sized s a -> b +foldr1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +foldl1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +reducer' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reducel' :: S.Sequence s => (a -> a -> a) -> a -> Sized s a -> a +reduce1' :: S.Sequence s => (a -> a -> a) -> Sized s a -> a +copy :: S.Sequence s => Int -> a -> Sized s a +inBounds :: S.Sequence s => Int -> Sized s a -> Bool +lookup :: S.Sequence s => Int -> Sized s a -> a +lookupM :: (S.Sequence s, Monad m) => Int -> Sized s a -> m a +lookupWithDefault :: S.Sequence s => a -> Int -> Sized s a -> a +update :: S.Sequence s => Int -> a -> Sized s a -> Sized s a +adjust :: S.Sequence s => (a -> a) -> Int -> Sized s a -> Sized s a +mapWithIndex :: S.Sequence s => (Int -> a -> b) -> Sized s a -> Sized s b +foldrWithIndex :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b +foldlWithIndex :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b +foldrWithIndex' :: S.Sequence s => (Int -> a -> b -> b) -> b -> Sized s a -> b +foldlWithIndex' :: S.Sequence s => (b -> Int -> a -> b) -> b -> Sized s a -> b +take :: S.Sequence s => Int -> Sized s a -> Sized s a +drop :: S.Sequence s => Int -> Sized s a -> Sized s a +splitAt :: S.Sequence s => Int -> Sized s a -> (Sized s a, Sized s a) +subseq :: S.Sequence s => Int -> Int -> Sized s a -> Sized s a +filter :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a +partition :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a) +takeWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a +dropWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> Sized s a +splitWhile :: S.Sequence s => (a -> Bool) -> Sized s a -> (Sized s a, Sized s a) +zip :: S.Sequence s => Sized s a -> Sized s b -> Sized s (a,b) +zip3 :: S.Sequence s => Sized s a -> Sized s b -> Sized s c -> Sized s (a,b,c) +zipWith :: S.Sequence s => (a -> b -> c) -> Sized s a -> Sized s b -> Sized s c +zipWith3 :: S.Sequence s => (a -> b -> c -> d) -> Sized s a -> Sized s b -> Sized s c -> Sized s d +unzip :: S.Sequence s => Sized s (a,b) -> (Sized s a, Sized s b) +unzip3 :: S.Sequence s => Sized s (a,b,c) -> (Sized s a, Sized s b, Sized s c) +unzipWith :: S.Sequence s => (a -> b) -> (a -> c) -> Sized s a -> (Sized s b, Sized s c) +unzipWith3 :: S.Sequence s => (a -> b) -> (a -> c) -> (a -> d) -> Sized s a -> (Sized s b, Sized s c, Sized s d) +strict :: S.Sequence s => Sized s a -> Sized s a +strictWith :: S.Sequence s => (a -> b) -> Sized s a -> Sized s a +structuralInvariant :: S.Sequence s => Sized s a -> Bool + +-- bonus functions, not in Sequence signature +fromSeq :: S.Sequence s => s a -> Sized s a +toSeq :: S.Sequence s => Sized s a -> s a + + + +moduleName = "Data.Edison.Seq.SizedSeq" +instanceName (N n s) = "SizedSeq(" ++ S.instanceName s ++ ")" + +data Sized s a = N !Int (s a) + +fromSeq xs = N (S.size xs) xs +toSeq (N 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 n xs) = S.lhead xs + +lheadM (N n xs) = S.lheadM xs + +ltail (N 0 xs) = error "SizedSeq.ltail: empty sequence" +ltail (N n xs) = N (n-1) (S.ltail xs) + +ltailM (N 0 xs) = 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 n xs) = S.rhead xs + +rheadM (N n xs) = S.rheadM xs + +rtail (N 0 xs) = error "SizedSeq.rtail: empty sequence" +rtail (N n xs) = N (n-1) (S.rtail xs) + +rtailM (N 0 xs) = fail "SizedSeq.rtailM: empty sequence" +rtailM (N n xs) = return (N (n-1) (S.rtail xs)) + +null (N n xs) = n == 0 +size (N n xs) = n +concat (N 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 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 n xs) = S.fold f e xs +fold' f e (N n xs) = S.fold' f e xs +fold1 f (N n xs) = S.fold1 f xs +fold1' f (N n xs) = S.fold1' f xs +foldr f e (N n xs) = S.foldr f e xs +foldr' f e (N n xs) = S.foldr' f e xs +foldl f e (N n xs) = S.foldl f e xs +foldl' f e (N n xs) = S.foldl' f e xs +foldr1 f (N n xs) = S.foldr1 f xs +foldr1' f (N n xs) = S.foldr1' f xs +foldl1 f (N n xs) = S.foldl1 f xs +foldl1' f (N n xs) = S.foldl1' f xs +reducer f e (N n xs) = S.reducer f e xs +reducer' f e (N n xs) = S.reducer' f e xs +reducel f e (N n xs) = S.reducel f e xs +reducel' f e (N n xs) = S.reducel' f e xs +reduce1 f (N n xs) = S.reduce1 f xs +reduce1' f (N n xs) = S.reduce1' f xs + +copy n x + | n <= 0 = empty + | otherwise = N n (S.copy n x) + +inBounds i (N n xs) = (i >= 0) && (i < n) +lookup i (N n xs) = S.lookup i xs +lookupM i (N n xs) = S.lookupM i xs +lookupWithDefault d i (N 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 n xs) = S.foldrWithIndex f e xs +foldrWithIndex' f e (N n xs) = S.foldrWithIndex' f e xs +foldlWithIndex f e (N n xs) = S.foldlWithIndex f e xs +foldlWithIndex' f e (N 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 i s') = S.strict s' `seq` s +strictWith f s@(N i s') = S.strictWith f s' `seq` s + +structuralInvariant (N i s) = i == S.size s + +-- instances + +instance S.Sequence s => S.Sequence (Sized s) where + {lcons = lcons; rcons = rcons; + lview = lview; lhead = lhead; ltail = ltail; + lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM; + rview = rview; rhead = rhead; rtail = rtail; null = null; + size = size; concat = concat; reverse = reverse; + reverseOnto = reverseOnto; fromList = fromList; toList = toList; + fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1'; + foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl'; + foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1'; + reducer = reducer; reducer' = reducer'; reducel = reducel; + reducel' = reducel'; reduce1 = reduce1; reduce1' = reduce1'; + copy = copy; inBounds = inBounds; lookup = lookup; + lookupM = lookupM; lookupWithDefault = lookupWithDefault; + update = update; adjust = adjust; mapWithIndex = mapWithIndex; + foldrWithIndex = foldrWithIndex; foldrWithIndex' = foldrWithIndex'; + foldlWithIndex = foldlWithIndex; foldlWithIndex' = foldlWithIndex'; + take = take; drop = drop; splitAt = splitAt; subseq = subseq; + filter = filter; partition = partition; takeWhile = takeWhile; + dropWhile = dropWhile; splitWhile = splitWhile; zip = zip; + zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip; + unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3; + strict = strict; strictWith = strictWith; + structuralInvariant = structuralInvariant; instanceName = instanceName} + +instance S.Sequence s => Functor (Sized s) where + fmap = map + +instance S.Sequence s => Monad (Sized s) where + return = singleton + xs >>= k = concatMap k xs + +instance S.Sequence s => MonadPlus (Sized s) where + mplus = append + mzero = empty + + +instance Eq (s a) => Eq (Sized s a) where + (N m xs) == (N n ys) = (m == n) && (xs == ys) + -- this is probably identical to the code that would be + -- generated by "deriving (Eq)", but I wanted to be *sure* + -- that the sizes were compared before the inner sequences + +instance (S.Sequence s, Ord a, Eq (s a)) => Ord (Sized s a) where + compare = defaultCompare + +instance (S.Sequence s, Show (s a)) => Show (Sized s a) where + showsPrec i xs rest + | i == 0 = L.concat [ moduleName,".fromSeq ",showsPrec 10 (toSeq xs) rest] + | otherwise = L.concat ["(",moduleName,".fromSeq ",showsPrec 10 (toSeq xs) (')':rest)] + +instance (S.Sequence s, Read (s a)) => Read (Sized s a) where + readsPrec i 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) + + coarbitrary xs = coarbitrary (toSeq xs) + +instance S.Sequence s => Monoid (Sized s a) where + mempty = empty + mappend = append