{-#LANGUAGE DeriveDataTypeable, TemplateHaskell #-}-- | Basic combinators for building enumerations-- most users will want to use the type class -- based combinators in "Test.Feat.Class" instead. moduleTest.Feat.Enumerate(Index,Enumerate(..),parts,fromParts,-- ** Reversed listsRevList(..),toRev,-- ** Finite ordered setsFinite(..),fromFinite,-- ** Combinators for building enumerationsmoduleData.Monoid,union,moduleControl.Applicative,cartesian,singleton,pay,-- *** Polymorphic sharingmoduleData.Typeable,Tag(Source),tag,eShare,noOptim,optimise)where-- testing-featimportControl.Monad.TagShare(Sharing,runSharing,share)importTest.Feat.Internals.Tag(Tag(Source))-- baseimportControl.ApplicativeimportControl.MonadimportData.FunctionimportData.MonoidimportData.TypeableimportLanguage.Haskell.THimportData.List(transpose)typePart=InttypeIndex=Integer-- | A functional enumeration of type @t@ is a partition of-- @t@ into finite numbered sets called Parts. Each parts contains values-- of a certain cost (typically the size of the value).dataEnumeratea=Enumerate{revParts::RevList(Finitea),optimiser::SharingTag(Enumeratea)-- Should be RevList a?}derivingTypeableparts::Enumeratea->[Finitea]parts=fromRev.revPartsfromParts::[Finitea]->EnumerateafromPartsps=Enumerate(toRevps)(return$fromPartsps)-- | Only use fmap with bijective functions (e.g. data constructors)instanceFunctorEnumeratewherefmapfe=Enumerate(fmap(fmapf)$revPartse)(fmap(noOptim.fmapf)$optimisere)-- | Pure is 'singleton' and '<*>' corresponds to cartesian product (as with lists)instanceApplicativeEnumeratewherepure=singletonf<*>a=fmap(uncurry($))(cartesianfa)-- | The @'mappend'@ is (disjoint) @'union'@instanceMonoid(Enumeratea)wheremempty=Enumeratemempty(returnmempty)mappend=unionmconcat=econcat-- | Optimal 'mconcat' on enumerations.econcat::[Enumeratea]->Enumerateaeconcat[]=memptyeconcat[a]=aeconcat[a,b]=unionabeconcatxs=Enumerate(toRev.mapmconcat.transpose$mappartsxs)(fmap(noOptim.econcat)$mapMoptimiserxs)-- Product of two enumerationscartesian(Enumeratexs1o1)(Enumeratexs2o2)=Enumerate(xs1`prod`xs2)(fmapnoOptim$liftM2cartesiano1o2)prod::RevList(Finitea)->RevList(Finiteb)->RevList(Finite(a,b))prod(RevList[]_)_=memptyprod(RevListxs0@(_:xst)_)(RevList_rys0)=toRev$prod'rys0where-- We need to thread carefully here, making sure that guarded recursion is safeprod'[]=[]prod'(ry:rys)=goryryswheregoryrys=mergexs0ry:caserysof(ry':rys')->gory'rys'[]->prod''ryxst-- rys0 is exhausted, slide a window over xs0 until it is exhaustedprod''::[Finiteb]->[Finitea]->[Finite(a,b)]prod''ry=gowherego[]=[]goxs@(_:xs')=mergexsry:goxs'merge::[Finitea]->[Finiteb]->Finite(a,b)mergexsys=Finite(sum$zipWith(*)(mapfCardxs)(mapfCardys))(prodSelxsys)prodSel::[Finitea]->[Finiteb]->(Index->(a,b))prodSel(f1:f1s)(f2:f2s)=\i->letmul=fCardf1*fCardf2inifi<multhenlet(q,r)=(i`quotRem`fCardf2)in(fIndexf1q,fIndexf2r)elseprodSelf1sf2s(i-mul)prodSel__=\i->error"index out of bounds"union::Enumeratea->Enumeratea->Enumerateaunion(Enumeratexs1o1)(Enumeratexs2o2)=Enumerate(xs1`mappend`xs2)(fmapnoOptim$liftM2uniono1o2)-- | The definition of @pure@ for the applicative instance. singleton::a->Enumerateasingletona=Enumerate(revPure$finPurea)(return(singletona))-- | Increases the cost of all values in an enumeration by one.pay::Enumeratea->Enumerateapaye=Enumerate(revConsmempty$revPartse)(fmap(noOptim.pay)$optimisere)-------------------------------------------------------------------- Reverse lists-- | A data structure that contains a list and the reversals of all initial -- segments of the list. Intuitively ---- @reversals xs !! n = reverse (take (n+1) (fromRev xs))@---- Any operation on a @RevList@ typically discards the reversals and constructs-- new reversals on demand.dataRevLista=RevList{fromRev::[a],reversals::[[a]]}derivingShowinstanceFunctorRevListwherefmapf=toRev.fmapf.fromRev-- Maybe this should be append instead?-- | Padded zipinstanceMonoida=>Monoid(RevLista)wheremempty=toRev[]mappendxsys=toRev$zipMon(fromRevxs)(fromRevys)wherezipMon::Monoida=>[a]->[a]->[a]zipMon(x:xs)(y:ys)=x<>y:zipMonxsyszipMonxsys=xs++ys-- | Constructs a reversable variant of a given list. In a sensible -- Haskell implementation evaluating any inital segment of -- @reversals (toRevxs)@ uses linear memory in the size of the segment.toRev::[a]->RevListatoRevxs=RevListxs$go[]xswherego_[]=[]gorev(x:xs)=letrev'=x:revinrev':gorev'xs-- | Adds an element to the head of a @RevList@. Constant memory iff the -- the reversals of the resulting list are not evaluated (which is frequently -- the case in @Feat@).revConsa=toRev.(a:).fromRevrevPurea=RevList[a][[a]]--------------------------------------------------------- Polymorphic sharingeShare::Typeablea=>Tag->Enumeratea->EnumerateaeSharete=e{optimiser=sharet(optimisere)}-- Automatically generates a unique tag based on the source position.tag::QExp-- :: Tagtag=location>>=makeTagwheremakeTagLoc{loc_package=p,loc_module=m,loc_start=(r,c)}=[|Sourcepmrc|]optimise::Enumeratea->Enumerateaoptimisee=lete'=runSharing(optimisere)ine'{optimiser=returne'}noOptim::Enumeratea->EnumerateanoOptime=e{optimiser=returne}---------------------------------------------------------- Operations on finite setsdataFinitea=Finite{fCard::Index,fIndex::Index->a}finEmpty=Finite0(\i->error"index: Empty")finUnion::Finitea->Finitea->FiniteafinUnionf1f2|fCardf1==0=f2|fCardf2==0=f1|otherwise=Finitecarselwherecar=fCardf1+fCardf2seli=ifi<fCardf1thenfIndexf1ielsefIndexf2(i-fCardf1)instanceFunctorFinitewherefmapffin=fin{fIndex=f.fIndexfin}instanceMonoid(Finitea)wheremempty=finEmptymappend=finUnionmconcatxs=Finite(sum$mapfCardxs)(sumSel$filter((>0).fCard)xs)sumSel::[Finitea]->(Index->a)sumSel(f:rest)=\i->ifi<fCardfthenfIndexfielsesumSelrest(i-fCardf)sumSel_=error"Index out of bounds"finCart::Finitea->Finiteb->Finite(a,b)finCartf1f2=Finitecarselwherecar=fCardf1*fCardf2seli=let(q,r)=(i`quotRem`fCardf2)in(fIndexf1q,fIndexf2r)finPure::a->FiniteafinPurea=Finite1onewhereone0=aone_=error"index: index out of bounds"fromFinite::Finitea->(Index,[a])fromFinite(Finitecix)=(c,mapix[0..c-1])instanceShowa=>Show(Finitea)whereshow=show.fromFinite