{-# LANGUAGE CPP #-}#if __GLASGOW_HASKELL__{-# LANGUAGE MagicHash, BangPatterns, DeriveDataTypeable, StandaloneDeriving #-}#endif#if !defined(TESTING) && __GLASGOW_HASKELL__ >= 703{-# LANGUAGE Trustworthy #-}#endif------------------------------------------------------------------------------- |-- Module : Data.IntSet.Base-- Copyright : (c) Daan Leijen 2002-- (c) Joachim Breitner 2011-- License : BSD-style-- Maintainer : libraries@haskell.org-- Stability : provisional-- Portability : portable---- An efficient implementation of integer sets.---- These modules are intended to be imported qualified, to avoid name-- clashes with Prelude functions, e.g.---- > import Data.IntSet (IntSet)-- > import qualified Data.IntSet as IntSet---- The implementation is based on /big-endian patricia trees/. This data-- structure performs especially well on binary operations like 'union'-- and 'intersection'. However, my benchmarks show that it is also-- (much) faster on insertions and deletions when compared to a generic-- size-balanced set implementation (see "Data.Set").---- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\",-- Workshop on ML, September 1998, pages 77-86,-- <http://citeseer.ist.psu.edu/okasaki98fast.html>---- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4),-- October 1968, pages 514-534.---- Additionally, this implementation places bitmaps in the leaves of the tree.-- Their size is the natural size of a machine word (32 or 64 bits) and greatly-- reduce memory footprint and execution times for dense sets, e.g. sets where-- it is likely that many values lie close to each other. The asymptotics are-- not affected by this optimization.---- Many operations have a worst-case complexity of /O(min(n,W))/.-- This means that the operation can become linear in the number of-- elements with a maximum of /W/ -- the number of bits in an 'Int'-- (32 or 64).------------------------------------------------------------------------------- [Note: INLINE bit fiddling]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~-- It is essential that the bit fiddling functions like mask, zero, branchMask-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC-- usually gets it right, but it is disastrous if it does not. Therefore we-- explicitly mark these functions INLINE.-- [Note: Local 'go' functions and capturing]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- Care must be taken when using 'go' function which captures an argument.-- Sometimes (for example when the argument is passed to a data constructor,-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code-- must be checked for increased allocation when creating and modifying such-- functions.-- [Note: Order of constructors]-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-- The order of constructors of IntSet matters when considering performance.-- Currently in GHC 7.0, when type has 3 constructors, they are matched from-- the first to the last -- the best performance is achieved when the-- constructors are ordered by frequency.-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil-- improves the benchmark by circa 10%.moduleData.IntSet.Base(-- * Set typeIntSet(..),Key-- instance Eq,Show-- * Operators,(\\)-- * Query,null,size,member,notMember,lookupLT,lookupGT,lookupLE,lookupGE,isSubsetOf,isProperSubsetOf-- * Construction,empty,singleton,insert,delete-- * Combine,union,unions,difference,intersection-- * Filter,filter,partition,split,splitMember-- * Map,map-- * Folds,foldr,foldl-- ** Strict folds,foldr',foldl'-- ** Legacy folds,fold-- * Min\/Max,findMin,findMax,deleteMin,deleteMax,deleteFindMin,deleteFindMax,maxView,minView-- * Conversion-- ** List,elems,toList,fromList-- ** Ordered list,toAscList,toDescList,fromAscList,fromDistinctAscList-- * Debugging,showTree,showTreeWith-- * Internals,match,suffixBitMask,prefixBitMask,bitmapOf)whereimportPreludehiding(filter,foldr,foldl,null,map)importData.BitsimportqualifiedData.ListasListimportData.Monoid(Monoid(..))importData.Maybe(fromMaybe)importData.TypeableimportControl.DeepSeq(NFData)importData.StrictPair#if __GLASGOW_HASKELL__importText.ReadimportData.Data(Data(..),mkNoRepType)#endif#if __GLASGOW_HASKELL__importGHC.Exts(Word(..),Int(..),build)importGHC.Prim(uncheckedShiftL#,uncheckedShiftRL#,indexInt8OffAddr#)#elseimportData.Word#endif-- On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.#if defined(__GLASGOW_HASKELL__)#include "MachDeps.h"#endif-- Use macros to define strictness of functions.-- STRICT_x_OF_y denotes an y-ary function strict in the x-th parameter.-- We do not use BangPatterns, because they are not in any standard and we-- want the compilers to be compiled by as many compilers as possible.#define STRICT_1_OF_2(fn) fn arg _ | arg `seq` False = undefined#define STRICT_2_OF_2(fn) fn _ arg | arg `seq` False = undefined#define STRICT_1_OF_3(fn) fn arg _ _ | arg `seq` False = undefined#define STRICT_2_OF_3(fn) fn _ arg _ | arg `seq` False = undefinedinfixl9\\{-This comment teaches CPP correct behaviour -}-- A "Nat" is a natural machine word (an unsigned Int)typeNat=WordnatFromInt::Int->NatnatFromInti=fromIntegrali{-# INLINE natFromInt #-}intFromNat::Nat->IntintFromNatw=fromIntegralw{-# INLINE intFromNat #-}-- Right and left logical shifts.shiftRL,shiftLL::Nat->Int->Nat#if __GLASGOW_HASKELL__{--------------------------------------------------------------------
GHC: use unboxing to get @shiftRL@ and @shiftLL@ inlined.
--------------------------------------------------------------------}shiftRL(W#x)(I#i)=W#(uncheckedShiftRL#xi)shiftLL(W#x)(I#i)=W#(uncheckedShiftL#xi)#elseshiftRLxi=shiftRxishiftLLxi=shiftLxi#endif{-# INLINE shiftRL #-}{-# INLINE shiftLL #-}{--------------------------------------------------------------------
Operators
--------------------------------------------------------------------}-- | /O(n+m)/. See 'difference'.(\\)::IntSet->IntSet->IntSetm1\\m2=differencem1m2{--------------------------------------------------------------------
Types
--------------------------------------------------------------------}-- | A set of integers.-- See Note: Order of constructorsdataIntSet=Bin{-# UNPACK #-}!Prefix{-# UNPACK #-}!Mask!IntSet!IntSet-- Invariant: Nil is never found as a child of Bin.-- Invariant: The Mask is a power of 2. It is the largest bit position at which-- two elements of the set differ.-- Invariant: Prefix is the common high-order bits that all elements share to-- the left of the Mask bit.-- Invariant: In Bin prefix mask left right, left consists of the elements that-- don't have the mask bit set; right is all the elements that do.|Tip{-# UNPACK #-}!Prefix{-# UNPACK #-}!BitMap-- Invariant: The Prefix is zero for all but the last 5 (on 32 bit arches) or 6-- bits (on 64 bit arches). The values of the map represented by a tip-- are the prefix plus the indices of the set bits in the bit map.|Nil-- A number stored in a set is stored as-- * Prefix (all but last 5-6 bits) and-- * BitMap (last 5-6 bits stored as a bitmask)-- Last 5-6 bits are called a Suffix.typePrefix=InttypeMask=InttypeBitMap=WordtypeKey=IntinstanceMonoidIntSetwheremempty=emptymappend=unionmconcat=unions#if __GLASGOW_HASKELL__{--------------------------------------------------------------------
A Data instance
--------------------------------------------------------------------}-- This instance preserves data abstraction at the cost of inefficiency.-- We omit reflection services for the sake of data abstraction.instanceDataIntSetwheregfoldlfzis=zfromList`f`(toListis)toConstr_=error"toConstr"gunfold__=error"gunfold"dataTypeOf_=mkNoRepType"Data.IntSet.IntSet"#endif{--------------------------------------------------------------------
Query
--------------------------------------------------------------------}-- | /O(1)/. Is the set empty?null::IntSet->BoolnullNil=Truenull_=False{-# INLINE null #-}-- | /O(n)/. Cardinality of the set.size::IntSet->Intsizet=casetofBin__lr->sizel+sizerTip_bm->bitcount0bmNil->0-- | /O(min(n,W))/. Is the value a member of the set?-- See Note: Local 'go' functions and capturing]member::Key->IntSet->Boolmemberx=x`seq`gowherego(Binpmlr)|nomatchxpm=False|zeroxm=gol|otherwise=gorgo(Tipybm)=prefixOfx==y&&bitmapOfx.&.bm/=0goNil=False-- | /O(min(n,W))/. Is the element not in the set?notMember::Key->IntSet->BoolnotMemberk=not.memberk-- | /O(log n)/. Find largest element smaller than the given one.---- > lookupLT 3 (fromList [3, 5]) == Nothing-- > lookupLT 5 (fromList [3, 5]) == Just 3-- See Note: Local 'go' functions and capturing.lookupLT::Key->IntSet->MaybeKeylookupLTxt=x`seq`casetofBin_mlr|m<0->ifx>=0thengorlelsegoNilr_->goNiltwheregodef(Binpmlr)|nomatchxpm=ifx<pthenunsafeFindMaxdefelseunsafeFindMaxr|zeroxm=godefl|otherwise=golrgodef(Tipkxbm)|prefixOfx>kx=Just$kx+highestBitSetbm|prefixOfx==kx&&maskLT/=0=Just$kx+highestBitSetmaskLT|otherwise=unsafeFindMaxdefwheremaskLT=(bitmapOfx-1).&.bmgodefNil=unsafeFindMaxdef-- | /O(log n)/. Find smallest element greater than the given one.---- > lookupGT 4 (fromList [3, 5]) == Just 5-- > lookupGT 5 (fromList [3, 5]) == Nothing-- See Note: Local 'go' functions and capturing.lookupGT::Key->IntSet->MaybeKeylookupGTxt=x`seq`casetofBin_mlr|m<0->ifx>=0thengoNillelsegolr_->goNiltwheregodef(Binpmlr)|nomatchxpm=ifx<pthenunsafeFindMinlelseunsafeFindMindef|zeroxm=gorl|otherwise=godefrgodef(Tipkxbm)|prefixOfx<kx=Just$kx+lowestBitSetbm|prefixOfx==kx&&maskGT/=0=Just$kx+lowestBitSetmaskGT|otherwise=unsafeFindMindefwheremaskGT=(-((bitmapOfx)`shiftLL`1)).&.bmgodefNil=unsafeFindMindef-- | /O(log n)/. Find largest element smaller or equal to the given one.---- > lookupLE 2 (fromList [3, 5]) == Nothing-- > lookupLE 4 (fromList [3, 5]) == Just 3-- > lookupLE 5 (fromList [3, 5]) == Just 5-- See Note: Local 'go' functions and capturing.lookupLE::Key->IntSet->MaybeKeylookupLExt=x`seq`casetofBin_mlr|m<0->ifx>=0thengorlelsegoNilr_->goNiltwheregodef(Binpmlr)|nomatchxpm=ifx<pthenunsafeFindMaxdefelseunsafeFindMaxr|zeroxm=godefl|otherwise=golrgodef(Tipkxbm)|prefixOfx>kx=Just$kx+highestBitSetbm|prefixOfx==kx&&maskLE/=0=Just$kx+highestBitSetmaskLE|otherwise=unsafeFindMaxdefwheremaskLE=(((bitmapOfx)`shiftLL`1)-1).&.bmgodefNil=unsafeFindMaxdef-- | /O(log n)/. Find smallest element greater or equal to the given one.---- > lookupGE 3 (fromList [3, 5]) == Just 3-- > lookupGE 4 (fromList [3, 5]) == Just 5-- > lookupGE 6 (fromList [3, 5]) == Nothing-- See Note: Local 'go' functions and capturing.lookupGE::Key->IntSet->MaybeKeylookupGExt=x`seq`casetofBin_mlr|m<0->ifx>=0thengoNillelsegolr_->goNiltwheregodef(Binpmlr)|nomatchxpm=ifx<pthenunsafeFindMinlelseunsafeFindMindef|zeroxm=gorl|otherwise=godefrgodef(Tipkxbm)|prefixOfx<kx=Just$kx+lowestBitSetbm|prefixOfx==kx&&maskGE/=0=Just$kx+lowestBitSetmaskGE|otherwise=unsafeFindMindefwheremaskGE=(-(bitmapOfx)).&.bmgodefNil=unsafeFindMindef-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is-- given, it has m > 0.unsafeFindMin::IntSet->MaybeKeyunsafeFindMinNil=NothingunsafeFindMin(Tipkxbm)=Just$kx+lowestBitSetbmunsafeFindMin(Bin__l_)=unsafeFindMinl-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is-- given, it has m > 0.unsafeFindMax::IntSet->MaybeKeyunsafeFindMaxNil=NothingunsafeFindMax(Tipkxbm)=Just$kx+highestBitSetbmunsafeFindMax(Bin___r)=unsafeFindMaxr{--------------------------------------------------------------------
Construction
--------------------------------------------------------------------}-- | /O(1)/. The empty set.empty::IntSetempty=Nil{-# INLINE empty #-}-- | /O(1)/. A set of one element.singleton::Key->IntSetsingletonx=Tip(prefixOfx)(bitmapOfx){-# INLINE singleton #-}{--------------------------------------------------------------------
Insert
--------------------------------------------------------------------}-- | /O(min(n,W))/. Add a value to the set. There is no left- or right bias for-- IntSets.insert::Key->IntSet->IntSetinsertx=x`seq`insertBM(prefixOfx)(bitmapOfx)-- Helper function for insert and union.insertBM::Prefix->BitMap->IntSet->IntSetinsertBMkxbmt=kx`seq`bm`seq`casetofBinpmlr|nomatchkxpm->joinkx(Tipkxbm)pt|zerokxm->Binpm(insertBMkxbml)r|otherwise->Binpml(insertBMkxbmr)Tipkx'bm'|kx'==kx->Tipkx'(bm.|.bm')|otherwise->joinkx(Tipkxbm)kx'tNil->Tipkxbm-- | /O(min(n,W))/. Delete a value in the set. Returns the-- original set when the value was not present.delete::Key->IntSet->IntSetdeletex=x`seq`deleteBM(prefixOfx)(bitmapOfx)-- Deletes all values mentioned in the BitMap from the set.-- Helper function for delete and difference.deleteBM::Prefix->BitMap->IntSet->IntSetdeleteBMkxbmt=kx`seq`bm`seq`casetofBinpmlr|nomatchkxpm->t|zerokxm->binpm(deleteBMkxbml)r|otherwise->binpml(deleteBMkxbmr)Tipkx'bm'|kx'==kx->tipkx(bm'.&.complementbm)|otherwise->tNil->Nil{--------------------------------------------------------------------
Union
--------------------------------------------------------------------}-- | The union of a list of sets.unions::[IntSet]->IntSetunionsxs=foldlStrictunionemptyxs-- | /O(n+m)/. The union of two sets.union::IntSet->IntSet->IntSetuniont1@(Binp1m1l1r1)t2@(Binp2m2l2r2)|shorterm1m2=union1|shorterm2m1=union2|p1==p2=Binp1m1(unionl1l2)(unionr1r2)|otherwise=joinp1t1p2t2whereunion1|nomatchp2p1m1=joinp1t1p2t2|zerop2m1=Binp1m1(unionl1t2)r1|otherwise=Binp1m1l1(unionr1t2)union2|nomatchp1p2m2=joinp1t1p2t2|zerop1m2=Binp2m2(uniont1l2)r2|otherwise=Binp2m2l2(uniont1r2)uniont@(Bin____)(Tipkxbm)=insertBMkxbmtuniont@(Bin____)Nil=tunion(Tipkxbm)t=insertBMkxbmtunionNilt=t{--------------------------------------------------------------------
Difference
--------------------------------------------------------------------}-- | /O(n+m)/. Difference between two sets.difference::IntSet->IntSet->IntSetdifferencet1@(Binp1m1l1r1)t2@(Binp2m2l2r2)|shorterm1m2=difference1|shorterm2m1=difference2|p1==p2=binp1m1(differencel1l2)(differencer1r2)|otherwise=t1wheredifference1|nomatchp2p1m1=t1|zerop2m1=binp1m1(differencel1t2)r1|otherwise=binp1m1l1(differencer1t2)difference2|nomatchp1p2m2=t1|zerop1m2=differencet1l2|otherwise=differencet1r2differencet@(Bin____)(Tipkxbm)=deleteBMkxbmtdifferencet@(Bin____)Nil=tdifferencet1@(Tipkxbm)t2=differenceTipt2wheredifferenceTip(Binp2m2l2r2)|nomatchkxp2m2=t1|zerokxm2=differenceTipl2|otherwise=differenceTipr2differenceTip(Tipkx2bm2)|kx==kx2=tipkx(bm.&.complementbm2)|otherwise=t1differenceTipNil=t1differenceNil_=Nil{--------------------------------------------------------------------
Intersection
--------------------------------------------------------------------}-- | /O(n+m)/. The intersection of two sets.intersection::IntSet->IntSet->IntSetintersectiont1@(Binp1m1l1r1)t2@(Binp2m2l2r2)|shorterm1m2=intersection1|shorterm2m1=intersection2|p1==p2=binp1m1(intersectionl1l2)(intersectionr1r2)|otherwise=Nilwhereintersection1|nomatchp2p1m1=Nil|zerop2m1=intersectionl1t2|otherwise=intersectionr1t2intersection2|nomatchp1p2m2=Nil|zerop1m2=intersectiont1l2|otherwise=intersectiont1r2intersectiont1@(Bin____)(Tipkx2bm2)=intersectBMt1whereintersectBM(Binp1m1l1r1)|nomatchkx2p1m1=Nil|zerokx2m1=intersectBMl1|otherwise=intersectBMr1intersectBM(Tipkx1bm1)|kx1==kx2=tipkx1(bm1.&.bm2)|otherwise=NilintersectBMNil=Nilintersection(Bin____)Nil=Nilintersection(Tipkx1bm1)t2=intersectBMt2whereintersectBM(Binp2m2l2r2)|nomatchkx1p2m2=Nil|zerokx1m2=intersectBMl2|otherwise=intersectBMr2intersectBM(Tipkx2bm2)|kx1==kx2=tipkx1(bm1.&.bm2)|otherwise=NilintersectBMNil=NilintersectionNil_=Nil{--------------------------------------------------------------------
Subset
--------------------------------------------------------------------}-- | /O(n+m)/. Is this a proper subset? (ie. a subset but not equal).isProperSubsetOf::IntSet->IntSet->BoolisProperSubsetOft1t2=casesubsetCmpt1t2ofLT->True_->FalsesubsetCmp::IntSet->IntSet->OrderingsubsetCmpt1@(Binp1m1l1r1)(Binp2m2l2r2)|shorterm1m2=GT|shorterm2m1=casesubsetCmpLtofGT->GT_->LT|p1==p2=subsetCmpEq|otherwise=GT-- disjointwheresubsetCmpLt|nomatchp1p2m2=GT|zerop1m2=subsetCmpt1l2|otherwise=subsetCmpt1r2subsetCmpEq=case(subsetCmpl1l2,subsetCmpr1r2)of(GT,_)->GT(_,GT)->GT(EQ,EQ)->EQ_->LTsubsetCmp(Bin____)_=GTsubsetCmp(Tipkx1bm1)(Tipkx2bm2)|kx1/=kx2=GT-- disjoint|bm1==bm2=EQ|bm1.&.complementbm2==0=LT|otherwise=GTsubsetCmpt1@(Tipkx_)(Binpmlr)|nomatchkxpm=GT|zerokxm=casesubsetCmpt1lofGT->GT;_->LT|otherwise=casesubsetCmpt1rofGT->GT;_->LTsubsetCmp(Tip__)Nil=GT-- disjointsubsetCmpNilNil=EQsubsetCmpNil_=LT-- | /O(n+m)/. Is this a subset?-- @(s1 `isSubsetOf` s2)@ tells whether @s1@ is a subset of @s2@.isSubsetOf::IntSet->IntSet->BoolisSubsetOft1@(Binp1m1l1r1)(Binp2m2l2r2)|shorterm1m2=False|shorterm2m1=matchp1p2m2&&(ifzerop1m2thenisSubsetOft1l2elseisSubsetOft1r2)|otherwise=(p1==p2)&&isSubsetOfl1l2&&isSubsetOfr1r2isSubsetOf(Bin____)_=FalseisSubsetOf(Tipkx1bm1)(Tipkx2bm2)=kx1==kx2&&bm1.&.complementbm2==0isSubsetOft1@(Tipkx_)(Binpmlr)|nomatchkxpm=False|zerokxm=isSubsetOft1l|otherwise=isSubsetOft1risSubsetOf(Tip__)Nil=FalseisSubsetOfNil_=True{--------------------------------------------------------------------
Filter
--------------------------------------------------------------------}-- | /O(n)/. Filter all elements that satisfy some predicate.filter::(Key->Bool)->IntSet->IntSetfilterpredicatet=casetofBinpmlr->binpm(filterpredicatel)(filterpredicater)Tipkxbm->tipkx(foldl'Bits0(bitPredkx)0bm)Nil->NilwherebitPredkxbmbi|predicate(kx+bi)=bm.|.bitmapOfSuffixbi|otherwise=bm{-# INLINE bitPred #-}-- | /O(n)/. partition the set according to some predicate.partition::(Key->Bool)->IntSet->(IntSet,IntSet)partitionpredicate0t0=toPair$gopredicate0t0wheregopredicatet=casetofBinpmlr->let(l1:*:l2)=gopredicatel(r1:*:r2)=gopredicaterinbinpml1r1:*:binpml2r2Tipkxbm->letbm1=foldl'Bits0(bitPredkx)0bmintipkxbm1:*:tipkx(bm`xor`bm1)Nil->(Nil:*:Nil)wherebitPredkxbmbi|predicate(kx+bi)=bm.|.bitmapOfSuffixbi|otherwise=bm{-# INLINE bitPred #-}-- | /O(min(n,W))/. The expression (@'split' x set@) is a pair @(set1,set2)@-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@-- comprises the elements of @set@ greater than @x@.---- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])split::Key->IntSet->(IntSet,IntSet)splitxt=casetofBin_mlr|m<0->ifx>=0-- handle negative numbers.thencasegoxlof(lt:*:gt)->letlt'=unionltrinlt'`seq`(lt',gt)elsecasegoxrof(lt:*:gt)->letgt'=uniongtlingt'`seq`(lt,gt')_->casegoxtof(lt:*:gt)->(lt,gt)wherego!x't'@(Binpmlr)|matchx'pm=ifzerox'mthencasegox'lof(lt:*:gt)->lt:*:uniongtrelsecasegox'rof(lt:*:gt)->unionltl:*:gt|otherwise=ifx'<pthen(Nil:*:t')else(t':*:Nil)gox't'@(Tipkx'bm)|kx'>x'=(Nil:*:t')-- equivalent to kx' > prefixOf x'|kx'<prefixOfx'=(t':*:Nil)|otherwise=tipkx'(bm.&.lowerBitmap):*:tipkx'(bm.&.higherBitmap)wherelowerBitmap=bitmapOfx'-1higherBitmap=complement(lowerBitmap+bitmapOfx')go_Nil=(Nil:*:Nil)-- | /O(min(n,W))/. Performs a 'split' but also returns whether the pivot-- element was found in the original set.splitMember::Key->IntSet->(IntSet,Bool,IntSet)splitMemberxt=casetofBin_mlr|m<0->ifx>=0thencasegoxlof(lt,fnd,gt)->letlt'=unionltrinlt'`seq`(lt',fnd,gt)elsecasegoxrof(lt,fnd,gt)->letgt'=uniongtlingt'`seq`(lt,fnd,gt')_->goxtwheregox't'@(Binpmlr)|matchx'pm=ifzerox'mthencasegox'lof(lt,fnd,gt)->(lt,fnd,uniongtr)elsecasegox'rof(lt,fnd,gt)->(unionltl,fnd,gt)|otherwise=ifx'<pthen(Nil,False,t')else(t',False,Nil)gox't'@(Tipkx'bm)|kx'>x'=(Nil,False,t')-- equivalent to kx' > prefixOf x'|kx'<prefixOfx'=(t',False,Nil)|otherwise=letlt=tipkx'(bm.&.lowerBitmap)found=(bm.&.bitmapOfx')/=0gt=tipkx'(bm.&.higherBitmap)inlt`seq`found`seq`gt`seq`(lt,found,gt)wherebitmapOfx'=bitmapOfx'lowerBitmap=bitmapOfx'-1higherBitmap=complement(lowerBitmap+bitmapOfx')go_Nil=(Nil,False,Nil){----------------------------------------------------------------------
Min/Max
----------------------------------------------------------------------}-- | /O(min(n,W))/. Retrieves the maximal key of the set, and the set-- stripped of that element, or 'Nothing' if passed an empty set.maxView::IntSet->Maybe(Key,IntSet)maxViewt=casetofNil->NothingBinpmlr|m<0->casegolof(result,l')->Just(result,binpml'r)_->Just(got)wherego(Binpmlr)=casegorof(result,r')->(result,binpmlr')go(Tipkxbm)=casehighestBitSetbmofbi->(kx+bi,tipkx(bm.&.complement(bitmapOfSuffixbi)))goNil=error"maxView Nil"-- | /O(min(n,W))/. Retrieves the minimal key of the set, and the set-- stripped of that element, or 'Nothing' if passed an empty set.minView::IntSet->Maybe(Key,IntSet)minViewt=casetofNil->NothingBinpmlr|m<0->casegorof(result,r')->Just(result,binpmlr')_->Just(got)wherego(Binpmlr)=casegolof(result,l')->(result,binpml'r)go(Tipkxbm)=caselowestBitSetbmofbi->(kx+bi,tipkx(bm.&.complement(bitmapOfSuffixbi)))goNil=error"minView Nil"-- | /O(min(n,W))/. Delete and find the minimal element.---- > deleteFindMin set = (findMin set, deleteMin set)deleteFindMin::IntSet->(Key,IntSet)deleteFindMin=fromMaybe(error"deleteFindMin: empty set has no minimal element").minView-- | /O(min(n,W))/. Delete and find the maximal element.---- > deleteFindMax set = (findMax set, deleteMax set)deleteFindMax::IntSet->(Key,IntSet)deleteFindMax=fromMaybe(error"deleteFindMax: empty set has no maximal element").maxView-- | /O(min(n,W))/. The minimal element of the set.findMin::IntSet->KeyfindMinNil=error"findMin: empty set has no minimal element"findMin(Tipkxbm)=kx+lowestBitSetbmfindMin(Bin_mlr)|m<0=findr|otherwise=findlwherefind(Tipkxbm)=kx+lowestBitSetbmfind(Bin__l'_)=findl'findNil=error"findMin Nil"-- | /O(min(n,W))/. The maximal element of a set.findMax::IntSet->KeyfindMaxNil=error"findMax: empty set has no maximal element"findMax(Tipkxbm)=kx+highestBitSetbmfindMax(Bin_mlr)|m<0=findl|otherwise=findrwherefind(Tipkxbm)=kx+highestBitSetbmfind(Bin___r')=findr'findNil=error"findMax Nil"-- | /O(min(n,W))/. Delete the minimal element.deleteMin::IntSet->IntSetdeleteMin=maybeNilsnd.minView-- | /O(min(n,W))/. Delete the maximal element.deleteMax::IntSet->IntSetdeleteMax=maybeNilsnd.maxView{----------------------------------------------------------------------
Map
----------------------------------------------------------------------}-- | /O(n*min(n,W))/.-- @'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::(Key->Key)->IntSet->IntSetmapf=fromList.List.mapf.toList{--------------------------------------------------------------------
Fold
--------------------------------------------------------------------}-- | /O(n)/. Fold the elements in the set using the given right-associative-- binary operator. This function is an equivalent of 'foldr' and is present-- for compatibility only.---- /Please note that fold will be deprecated in the future and removed./fold::(Key->b->b)->b->IntSet->bfold=foldr{-# INLINE fold #-}-- | /O(n)/. Fold the elements in the set using the given right-associative-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.---- For example,---- > toAscList set = foldr (:) [] setfoldr::(Key->b->b)->b->IntSet->bfoldrfz=\t->-- Use lambda t to be inlinable with two arguments only.casetofBin_mlr|m<0->go(gozl)r-- put negative numbers before|otherwise->go(gozr)l_->goztwheregoz'Nil=z'goz'(Tipkxbm)=foldrBitskxfz'bmgoz'(Bin__lr)=go(goz'r)l{-# INLINE foldr #-}-- | /O(n)/. A strict version of 'foldr'. Each application of the operator is-- evaluated before using the result in the next application. This-- function is strict in the starting value.foldr'::(Key->b->b)->b->IntSet->bfoldr'fz=\t->-- Use lambda t to be inlinable with two arguments only.casetofBin_mlr|m<0->go(gozl)r-- put negative numbers before|otherwise->go(gozr)l_->goztwhereSTRICT_1_OF_2(go)goz'Nil=z'goz'(Tipkxbm)=foldr'Bitskxfz'bmgoz'(Bin__lr)=go(goz'r)l{-# INLINE foldr' #-}-- | /O(n)/. Fold the elements in the set using the given left-associative-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.---- For example,---- > toDescList set = foldl (flip (:)) [] setfoldl::(a->Key->a)->a->IntSet->afoldlfz=\t->-- Use lambda t to be inlinable with two arguments only.casetofBin_mlr|m<0->go(gozr)l-- put negative numbers before|otherwise->go(gozl)r_->goztwhereSTRICT_1_OF_2(go)goz'Nil=z'goz'(Tipkxbm)=foldlBitskxfz'bmgoz'(Bin__lr)=go(goz'l)r{-# INLINE foldl #-}-- | /O(n)/. A strict version of 'foldl'. Each application of the operator is-- evaluated before using the result in the next application. This-- function is strict in the starting value.foldl'::(a->Key->a)->a->IntSet->afoldl'fz=\t->-- Use lambda t to be inlinable with two arguments only.casetofBin_mlr|m<0->go(gozr)l-- put negative numbers before|otherwise->go(gozl)r_->goztwhereSTRICT_1_OF_2(go)goz'Nil=z'goz'(Tipkxbm)=foldl'Bitskxfz'bmgoz'(Bin__lr)=go(goz'l)r{-# INLINE foldl' #-}{--------------------------------------------------------------------
List variations
--------------------------------------------------------------------}-- | /O(n)/. An alias of 'toAscList'. The elements of a set in ascending order.-- Subject to list fusion.elems::IntSet->[Key]elems=toAscList{--------------------------------------------------------------------
Lists
--------------------------------------------------------------------}-- | /O(n)/. Convert the set to a list of elements. Subject to list fusion.toList::IntSet->[Key]toList=toAscList-- | /O(n)/. Convert the set to an ascending list of elements. Subject to list-- fusion.toAscList::IntSet->[Key]toAscList=foldr(:)[]-- | /O(n)/. Convert the set to a descending list of elements. Subject to list-- fusion.toDescList::IntSet->[Key]toDescList=foldl(flip(:))[]-- List fusion for the list generating functions.#if __GLASGOW_HASKELL__-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.foldrFB::(Key->b->b)->b->IntSet->bfoldrFB=foldr{-# INLINE[0] foldrFB #-}foldlFB::(a->Key->a)->a->IntSet->afoldlFB=foldl{-# INLINE[0] foldlFB #-}-- Inline elems and toList, so that we need to fuse only toAscList.{-# INLINE elems #-}{-# INLINE toList #-}-- The fusion is enabled up to phase 2 included. If it does not succeed,-- convert in phase 1 the expanded to{Asc,Desc}List calls back to-- to{Asc,Desc}List. In phase 0, we inline fold{lr}FB (which were used in-- a list fusion, otherwise it would go away in phase 1), and let compiler do-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it-- before phase 0, otherwise the fusion rules would not fire at all.{-# NOINLINE[0] toAscList #-}{-# NOINLINE[0] toDescList #-}{-# RULES "IntSet.toAscList" [~1] forall s . toAscList s = build (\c n -> foldrFB c n s) #-}{-# RULES "IntSet.toAscListBack" [1] foldrFB (:) [] = toAscList #-}{-# RULES "IntSet.toDescList" [~1] forall s . toDescList s = build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}{-# RULES "IntSet.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}#endif-- | /O(n*min(n,W))/. Create a set from a list of integers.fromList::[Key]->IntSetfromListxs=foldlStrictinsemptyxswhereinstx=insertxt-- | /O(n)/. Build a set from an ascending list of elements.-- /The precondition (input list is ascending) is not checked./fromAscList::[Key]->IntSetfromAscList[]=NilfromAscList(x0:xs0)=fromDistinctAscList(combineEqx0xs0)wherecombineEqx'[]=[x']combineEqx'(x:xs)|x==x'=combineEqx'xs|otherwise=x':combineEqxxs-- | /O(n)/. Build a set from an ascending list of distinct elements.-- /The precondition (input list is strictly ascending) is not checked./fromDistinctAscList::[Key]->IntSetfromDistinctAscList[]=NilfromDistinctAscList(z0:zs0)=work(prefixOfz0)(bitmapOfz0)zs0Nadawhere-- 'work' accumulates all values that go into one tip, before passing this Tip-- to 'reduce'workkxbm[]stk=finishkx(Tipkxbm)stkworkkxbm(z:zs)stk|kx==prefixOfz=workkx(bm.|.bitmapOfz)zsstkworkkxbm(z:zs)stk=reducezzs(branchMaskzkx)kx(Tipkxbm)stkreducezzs_pxtxNada=work(prefixOfz)(bitmapOfz)zs(PushpxtxNada)reducezzsmpxtxstk@(Pushpytystk')=letmxy=branchMaskpxpypxy=maskpxmxyinifshortermmxythenreducezzsmpxy(Binpxymxytytx)stk'elsework(prefixOfz)(bitmapOfz)zs(Pushpxtxstk)finish_tNada=tfinishpxtx(Pushpytystk)=finishp(joinpytypxtx)stkwherem=branchMaskpxpyp=maskpxmdataStack=Push{-# UNPACK #-}!Prefix!IntSet!Stack|Nada{--------------------------------------------------------------------
Eq
--------------------------------------------------------------------}instanceEqIntSetwheret1==t2=equalt1t2t1/=t2=nequalt1t2equal::IntSet->IntSet->Boolequal(Binp1m1l1r1)(Binp2m2l2r2)=(m1==m2)&&(p1==p2)&&(equall1l2)&&(equalr1r2)equal(Tipkx1bm1)(Tipkx2bm2)=kx1==kx2&&bm1==bm2equalNilNil=Trueequal__=Falsenequal::IntSet->IntSet->Boolnequal(Binp1m1l1r1)(Binp2m2l2r2)=(m1/=m2)||(p1/=p2)||(nequall1l2)||(nequalr1r2)nequal(Tipkx1bm1)(Tipkx2bm2)=kx1/=kx2||bm1/=bm2nequalNilNil=Falsenequal__=True{--------------------------------------------------------------------
Ord
--------------------------------------------------------------------}instanceOrdIntSetwherecompares1s2=compare(toAscLists1)(toAscLists2)-- tentative implementation. See if more efficient exists.{--------------------------------------------------------------------
Show
--------------------------------------------------------------------}instanceShowIntSetwhereshowsPrecpxs=showParen(p>10)$showString"fromList ".shows(toListxs){--------------------------------------------------------------------
Read
--------------------------------------------------------------------}instanceReadIntSetwhere#ifdef __GLASGOW_HASKELL__readPrec=parens$prec10$doIdent"fromList"<-lexPxs<-readPrecreturn(fromListxs)readListPrec=readListPrecDefault#elsereadsPrecp=readParen(p>10)$\r->do("fromList",s)<-lexr(xs,t)<-readssreturn(fromListxs,t)#endif{--------------------------------------------------------------------
Typeable
--------------------------------------------------------------------}#include "Typeable.h"INSTANCE_TYPEABLE0(IntSet,intSetTc,"IntSet"){--------------------------------------------------------------------
NFData
--------------------------------------------------------------------}-- The IntSet constructors consist only of strict fields of Ints and-- IntSets, thus the default NFData instance which evaluates to whnf-- should sufficeinstanceNFDataIntSet{--------------------------------------------------------------------
Debugging
--------------------------------------------------------------------}-- | /O(n)/. Show the tree that implements the set. The tree is shown-- in a compressed, hanging format.showTree::IntSet->StringshowTrees=showTreeWithTrueFalses{- | /O(n)/. The expression (@'showTreeWith' hang wide map@) shows
the tree that implements the set. If @hang@ is
'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If
@wide@ is 'True', an extra wide version is shown.
-}showTreeWith::Bool->Bool->IntSet->StringshowTreeWithhangwidet|hang=(showsTreeHangwide[]t)""|otherwise=(showsTreewide[][]t)""showsTree::Bool->[String]->[String]->IntSet->ShowSshowsTreewidelbarsrbarst=casetofBinpmlr->showsTreewide(withBarrbars)(withEmptyrbars)r.showWidewiderbars.showsBarslbars.showString(showBinpm).showString"\n".showWidewidelbars.showsTreewide(withEmptylbars)(withBarlbars)lTipkxbm->showsBarslbars.showString" ".showskx.showString" + ".showsBitMapbm.showString"\n"Nil->showsBarslbars.showString"|\n"showsTreeHang::Bool->[String]->IntSet->ShowSshowsTreeHangwidebarst=casetofBinpmlr->showsBarsbars.showString(showBinpm).showString"\n".showWidewidebars.showsTreeHangwide(withBarbars)l.showWidewidebars.showsTreeHangwide(withEmptybars)rTipkxbm->showsBarsbars.showString" ".showskx.showString" + ".showsBitMapbm.showString"\n"Nil->showsBarsbars.showString"|\n"showBin::Prefix->Mask->StringshowBin__="*"-- ++ show (p,m)showWide::Bool->[String]->String->StringshowWidewidebars|wide=showString(concat(reversebars)).showString"|\n"|otherwise=idshowsBars::[String]->ShowSshowsBarsbars=casebarsof[]->id_->showString(concat(reverse(tailbars))).showStringnodeshowsBitMap::Word->ShowSshowsBitMap=showString.showBitMapshowBitMap::Word->StringshowBitMapw=show$foldrBits0(:)[]wnode::Stringnode="+--"withBar,withEmpty::[String]->[String]withBarbars="| ":barswithEmptybars=" ":bars{--------------------------------------------------------------------
Helpers
--------------------------------------------------------------------}{--------------------------------------------------------------------
Join
--------------------------------------------------------------------}join::Prefix->IntSet->Prefix->IntSet->IntSetjoinp1t1p2t2|zerop1m=Binpmt1t2|otherwise=Binpmt2t1wherem=branchMaskp1p2p=maskp1m{-# INLINE join #-}{--------------------------------------------------------------------
@bin@ assures that we never have empty trees within a tree.
--------------------------------------------------------------------}bin::Prefix->Mask->IntSet->IntSet->IntSetbin__lNil=lbin__Nilr=rbinpmlr=Binpmlr{-# INLINE bin #-}{--------------------------------------------------------------------
@tip@ assures that we never have empty bitmaps within a tree.
--------------------------------------------------------------------}tip::Prefix->BitMap->IntSettip_0=Niltipkxbm=Tipkxbm{-# INLINE tip #-}{----------------------------------------------------------------------
Functions that generate Prefix and BitMap of a Key or a Suffix.
----------------------------------------------------------------------}suffixBitMask::IntsuffixBitMask=bitSize(undefined::Word)-1{-# INLINE suffixBitMask #-}prefixBitMask::IntprefixBitMask=complementsuffixBitMask{-# INLINE prefixBitMask #-}prefixOf::Int->PrefixprefixOfx=x.&.prefixBitMask{-# INLINE prefixOf #-}suffixOf::Int->IntsuffixOfx=x.&.suffixBitMask{-# INLINE suffixOf #-}bitmapOfSuffix::Int->BitMapbitmapOfSuffixs=1`shiftLL`s{-# INLINE bitmapOfSuffix #-}bitmapOf::Int->BitMapbitmapOfx=bitmapOfSuffix(suffixOfx){-# INLINE bitmapOf #-}{--------------------------------------------------------------------
Endian independent bit twiddling
--------------------------------------------------------------------}zero::Int->Mask->Boolzeroim=(natFromInti).&.(natFromIntm)==0{-# INLINE zero #-}nomatch,match::Int->Prefix->Mask->Boolnomatchipm=(maskim)/=p{-# INLINE nomatch #-}matchipm=(maskim)==p{-# INLINE match #-}-- Suppose a is largest such that 2^a divides 2*m.-- Then mask i m is i with the low a bits zeroed out.mask::Int->Mask->Prefixmaskim=maskW(natFromInti)(natFromIntm){-# INLINE mask #-}{--------------------------------------------------------------------
Big endian operations
--------------------------------------------------------------------}maskW::Nat->Nat->PrefixmaskWim=intFromNat(i.&.(complement(m-1)`xor`m)){-# INLINE maskW #-}shorter::Mask->Mask->Boolshorterm1m2=(natFromIntm1)>(natFromIntm2){-# INLINE shorter #-}branchMask::Prefix->Prefix->MaskbranchMaskp1p2=intFromNat(highestBitMask(natFromIntp1`xor`natFromIntp2)){-# INLINE branchMask #-}{----------------------------------------------------------------------
Finding the highest bit (mask) in a word [x] can be done efficiently in
three ways:
* convert to a floating point value and the mantissa tells us the
[log2(x)] that corresponds with the highest bit position. The mantissa
is retrieved either via the standard C function [frexp] or by some bit
twiddling on IEEE compatible numbers (float). Note that one needs to
use at least [double] precision for an accurate mantissa of 32 bit
numbers.
* use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit).
* use processor specific assembler instruction (asm).
The most portable way would be [bit], but is it efficient enough?
I have measured the cycle counts of the different methods on an AMD
Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction:
highestBitMask: method cycles
--------------
frexp 200
float 33
bit 11
asm 12
highestBit: method cycles
--------------
frexp 195
float 33
bit 11
asm 11
Wow, the bit twiddling is on today's RISC like machines even faster
than a single CISC instruction (BSR)!
----------------------------------------------------------------------}{----------------------------------------------------------------------
[highestBitMask] returns a word where only the highest bit is set.
It is found by first setting all bits in lower positions than the
highest bit and than taking an exclusive or with the original value.
Allthough the function may look expensive, GHC compiles this into
excellent C code that subsequently compiled into highly efficient
machine code. The algorithm is derived from Jorg Arndt's FXT library.
----------------------------------------------------------------------}highestBitMask::Nat->NathighestBitMaskx0=case(x0.|.shiftRLx01)ofx1->case(x1.|.shiftRLx12)ofx2->case(x2.|.shiftRLx24)ofx3->case(x3.|.shiftRLx38)ofx4->case(x4.|.shiftRLx416)of#if !(defined(__GLASGOW_HASKELL__) && WORD_SIZE_IN_BITS==32)x5->case(x5.|.shiftRLx532)of-- for 64 bit platforms#endifx6->(x6`xor`(shiftRLx61)){-# INLINE highestBitMask #-}{----------------------------------------------------------------------
To get best performance, we provide fast implementations of
lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.
If the intel bsf and bsr instructions ever become GHC primops,
this code should be reimplemented using these.
Performance of this code is crucial for folds, toList, filter, partition.
The signatures of methods in question are placed after this comment.
----------------------------------------------------------------------}lowestBitSet::Nat->InthighestBitSet::Nat->IntfoldlBits::Int->(a->Int->a)->a->Nat->afoldl'Bits::Int->(a->Int->a)->a->Nat->afoldrBits::Int->(Int->a->a)->a->Nat->afoldr'Bits::Int->(Int->a->a)->a->Nat->a{-# INLINE lowestBitSet #-}{-# INLINE highestBitSet #-}{-# INLINE foldlBits #-}{-# INLINE foldl'Bits #-}{-# INLINE foldrBits #-}{-# INLINE foldr'Bits #-}#if defined(__GLASGOW_HASKELL__) && (WORD_SIZE_IN_BITS==32 || WORD_SIZE_IN_BITS==64){----------------------------------------------------------------------
For lowestBitSet we use wordsize-dependant implementation based on
multiplication and DeBrujn indeces, which was proposed by Edward Kmett
<http://haskell.org/pipermail/libraries/2011-September/016749.html>
The core of this implementation is fast indexOfTheOnlyBit,
which is given a Nat with exactly one bit set, and returns
its index.
Lot of effort was put in these implementations, please benchmark carefully
before changing this code.
----------------------------------------------------------------------}indexOfTheOnlyBit::Nat->Int{-# INLINE indexOfTheOnlyBit #-}indexOfTheOnlyBitbitmask=I#(lsbArray`indexInt8OffAddr#`unboxInt(intFromNat((bitmask*magic)`shiftRL`offset)))whereunboxInt(I#i)=i#if WORD_SIZE_IN_BITS==32magic=0x077CB531offset=27!lsbArray="\0\1\28\2\29\14\24\3\30\22\20\15\25\17\4\8\31\27\13\23\21\19\16\7\26\12\18\6\11\5\10\9"##elsemagic=0x07EDD5E59A4E28C2offset=58!lsbArray="\63\0\58\1\59\47\53\2\60\39\48\27\54\33\42\3\61\51\37\40\49\18\28\20\55\30\34\11\43\14\22\4\62\57\46\52\38\26\32\41\50\36\17\19\29\10\13\21\56\45\25\31\35\16\9\12\44\24\15\8\23\7\6\5"##endif-- The lsbArray gets inlined to every call site of indexOfTheOnlyBit.-- That cannot be easily avoided, as GHC forbids top-level Addr# literal.-- One could go around that by supplying getLsbArray :: () -> Addr# marked-- as NOINLINE. But the code size of calling it and processing the result-- is 48B on 32-bit and 56B on 64-bit architectures -- so the 32B and 64B array-- is actually improvement on 32-bit and only a 8B size increase on 64-bit.lowestBitMask::Nat->NatlowestBitMaskx=x.&.negatex{-# INLINE lowestBitMask #-}-- Reverse the order of bits in the Nat.revNat::Nat->Nat#if WORD_SIZE_IN_BITS==32revNatx1=case((x1`shiftRL`1).&.0x55555555).|.((x1.&.0x55555555)`shiftLL`1)ofx2->case((x2`shiftRL`2).&.0x33333333).|.((x2.&.0x33333333)`shiftLL`2)ofx3->case((x3`shiftRL`4).&.0x0F0F0F0F).|.((x3.&.0x0F0F0F0F)`shiftLL`4)ofx4->case((x4`shiftRL`8).&.0x00FF00FF).|.((x4.&.0x00FF00FF)`shiftLL`8)ofx5->(x5`shiftRL`16).|.(x5`shiftLL`16);#elserevNatx1=case((x1`shiftRL`1).&.0x5555555555555555).|.((x1.&.0x5555555555555555)`shiftLL`1)ofx2->case((x2`shiftRL`2).&.0x3333333333333333).|.((x2.&.0x3333333333333333)`shiftLL`2)ofx3->case((x3`shiftRL`4).&.0x0F0F0F0F0F0F0F0F).|.((x3.&.0x0F0F0F0F0F0F0F0F)`shiftLL`4)ofx4->case((x4`shiftRL`8).&.0x00FF00FF00FF00FF).|.((x4.&.0x00FF00FF00FF00FF)`shiftLL`8)ofx5->case((x5`shiftRL`16).&.0x0000FFFF0000FFFF).|.((x5.&.0x0000FFFF0000FFFF)`shiftLL`16)ofx6->(x6`shiftRL`32).|.(x6`shiftLL`32);#endiflowestBitSetx=indexOfTheOnlyBit(lowestBitMaskx)highestBitSetx=indexOfTheOnlyBit(highestBitMaskx)foldlBitsprefixfzbitmap=gobitmapzwheregobmacc|bm==0=acc|otherwise=caselowestBitMaskbmofbitmask->bitmask`seq`caseindexOfTheOnlyBitbitmaskofbi->bi`seq`go(bm`xor`bitmask)((facc)$!(prefix+bi))foldl'Bitsprefixfzbitmap=gobitmapzwhereSTRICT_2_OF_2(go)gobmacc|bm==0=acc|otherwise=caselowestBitMaskbmofbitmask->bitmask`seq`caseindexOfTheOnlyBitbitmaskofbi->bi`seq`go(bm`xor`bitmask)((facc)$!(prefix+bi))foldrBitsprefixfzbitmap=go(revNatbitmap)zwheregobmacc|bm==0=acc|otherwise=caselowestBitMaskbmofbitmask->bitmask`seq`caseindexOfTheOnlyBitbitmaskofbi->bi`seq`go(bm`xor`bitmask)((f$!(prefix+(WORD_SIZE_IN_BITS-1)-bi))acc)foldr'Bitsprefixfzbitmap=go(revNatbitmap)zwhereSTRICT_2_OF_2(go)gobmacc|bm==0=acc|otherwise=caselowestBitMaskbmofbitmask->bitmask`seq`caseindexOfTheOnlyBitbitmaskofbi->bi`seq`go(bm`xor`bitmask)((f$!(prefix+(WORD_SIZE_IN_BITS-1)-bi))acc)#else{----------------------------------------------------------------------
In general case we use logarithmic implementation of
lowestBitSet and highestBitSet, which works up to bit sizes of 64.
Folds are linear scans.
----------------------------------------------------------------------}lowestBitSetn0=let(n1,b1)=ifn0.&.0xFFFFFFFF/=0then(n0,0)else(n0`shiftRL`32,32)(n2,b2)=ifn1.&.0xFFFF/=0then(n1,b1)else(n1`shiftRL`16,16+b1)(n3,b3)=ifn2.&.0xFF/=0then(n2,b2)else(n2`shiftRL`8,8+b2)(n4,b4)=ifn3.&.0xF/=0then(n3,b3)else(n3`shiftRL`4,4+b3)(n5,b5)=ifn4.&.0x3/=0then(n4,b4)else(n4`shiftRL`2,2+b4)b6=ifn5.&.0x1/=0thenb5else1+b5inb6highestBitSetn0=let(n1,b1)=ifn0.&.0xFFFFFFFF00000000/=0then(n0`shiftRL`32,32)else(n0,0)(n2,b2)=ifn1.&.0xFFFF0000/=0then(n1`shiftRL`16,16+b1)else(n1,b1)(n3,b3)=ifn2.&.0xFF00/=0then(n2`shiftRL`8,8+b2)else(n2,b2)(n4,b4)=ifn3.&.0xF0/=0then(n3`shiftRL`4,4+b3)else(n3,b3)(n5,b5)=ifn4.&.0xC/=0then(n4`shiftRL`2,2+b4)else(n4,b4)b6=ifn5.&.0x2/=0then1+b5elseb5inb6foldlBitsprefixfzbm=letlb=lowestBitSetbmingo(prefix+lb)z(bm`shiftRL`lb)whereSTRICT_1_OF_3(go)go_acc0=accgobiaccn|n`testBit`0=go(bi+1)(faccbi)(n`shiftRL`1)|otherwise=go(bi+1)acc(n`shiftRL`1)foldl'Bitsprefixfzbm=letlb=lowestBitSetbmingo(prefix+lb)z(bm`shiftRL`lb)whereSTRICT_1_OF_3(go)STRICT_2_OF_3(go)go_acc0=accgobiaccn|n`testBit`0=go(bi+1)(faccbi)(n`shiftRL`1)|otherwise=go(bi+1)acc(n`shiftRL`1)foldrBitsprefixfzbm=letlb=lowestBitSetbmingo(prefix+lb)(bm`shiftRL`lb)whereSTRICT_1_OF_2(go)go_0=zgobin|n`testBit`0=fbi(go(bi+1)(n`shiftRL`1))|otherwise=go(bi+1)(n`shiftRL`1)foldr'Bitsprefixfzbm=letlb=lowestBitSetbmingo(prefix+lb)(bm`shiftRL`lb)whereSTRICT_1_OF_2(go)go_0=zgobin|n`testBit`0=fbi$!go(bi+1)(n`shiftRL`1)|otherwise=go(bi+1)(n`shiftRL`1)#endif{----------------------------------------------------------------------
[bitcount] as posted by David F. Place to haskell-cafe on April 11, 2006,
based on the code on
http://graphics.stanford.edu/~seander/bithacks.html#CountBitsSetKernighan, where the following source is given:
Published in 1988, the C Programming Language 2nd Ed. (by Brian W.
Kernighan and Dennis M. Ritchie) mentions this in exercise 2-9. On April
19, 2006 Don Knuth pointed out to me that this method "was first published
by Peter Wegner in CACM 3 (1960), 322. (Also discovered independently by
Derrick Lehmer and published in 1964 in a book edited by Beckenbach.)"
----------------------------------------------------------------------}bitcount::Int->Word->Int#if MIN_VERSION_base(4,5,0)bitcountax=a+popCountx#elsebitcounta0x0=goa0x0wheregoa0=agoax=go(a+1)(x.&.(x-1))#endif{-# INLINE bitcount #-}{--------------------------------------------------------------------
Utilities
--------------------------------------------------------------------}foldlStrict::(a->b->a)->a->[b]->afoldlStrictf=gowheregoz[]=zgoz(x:xs)=letz'=fzxinz'`seq`goz'xs{-# INLINE foldlStrict #-}