------------------------------------------------------------------------ |-- Module : Unbound.Perm-- License : BSD-like (see LICENSE)-- Maintainer : Stephanie Weirich <sweirich@cis.upenn.edu>-- Portability : portable---- A slow, but hopefully correct implementation of permutations.------------------------------------------------------------------------moduleUnbound.PermM(Perm,single,compose,apply,support,isid,join,empty,restrict,mkPerm)whereimportData.MonoidimportData.ListimportData.Map(Map)importqualifiedData.MapasMapimportSystem.IO.Unsafe(<>)::Monoidm=>m->m->m(<>)=mappend-- | A /permutation/ is a bijective function from names to names-- which is the identity on all but a finite set of names. They-- form the basis for nominal approaches to binding, but can-- also be useful in general.newtypePerma=Perm(Mapaa)instanceOrda=>Eq(Perma)where(Permp1)==(Permp2)=all(\x->Map.findWithDefaultxxp1==Map.findWithDefaultxxp2)(Map.keysp1)&&all(\x->Map.findWithDefaultxxp1==Map.findWithDefaultxxp2)(Map.keysp2)instanceShowa=>Show(Perma)whereshow(Permp)=showp-- | Apply a permutation to an element of the domain.apply::Orda=>Perma->a->aapply(Permp)x=Map.findWithDefaultxxp-- | Create a permutation which swaps two elements.single::Orda=>a->a->Permasinglexy=ifx==ythenPermMap.emptyelsePerm(Map.insertxy(Map.insertyxMap.empty))-- | The empty (identity) permutation.empty::Permaempty=PermMap.empty-- | Compose two permutations. The right-hand permutation will be-- applied first.compose::Orda=>Perma->Perma->Permacompose(Permb)(Perma)=Perm(Map.fromList([(x,Map.findWithDefaultyyb)|(x,y)<-Map.toLista]++[(x,Map.findWithDefaultxxb)|x<-Map.keysb,Map.notMemberxa]))-- | Permutations form a monoid under composition.instanceOrda=>Monoid(Perma)wheremempty=emptymappend=compose-- | Is this the identity permutation?isid::Orda=>Perma->Boolisid(Permp)=Map.foldrWithKey(\abr->r&&a==b)Truep-- | /Join/ two permutations by taking the union of their relation-- graphs. Fail if they are inconsistent, i.e. map the same element-- to two different elements.join::Orda=>Perma->Perma->Maybe(Perma)join(Permp1)(Permp2)=letoverlap=Map.intersectionWith(==)p1p2inifMap.fold(&&)TrueoverlapthenJust(Perm(Map.unionp1p2))elseNothing-- | The /support/ of a permutation is the set of elements which are-- not fixed.support::Orda=>Perma->[a]support(Permp)=[x|x<-Map.keysp,Map.findWithDefaultxxp/=x]-- | Restrict a permutation to a certain domain.restrict::Orda=>Perma->[a]->Permarestrict(Permp)l=Perm(foldl'(\p'k->Map.deletekp')pl)-- | @mkPerm l1 l2@ creates a permutation that sends @l1@ to @l2@.-- Fail if there is no such permutation, either because the lists-- have different lengths or because they are inconsistent (which-- can only happen if @l1@ or @l2@ have repeated elements).mkPerm::Orda=>[a]->[a]->Maybe(Perma)mkPermxsys|lengthxs==lengthys=foldl'(\mpp->mp>>=joinp)(Justempty)(zipWithsinglexsys)|otherwise=Nothing---------------------------------------------------------------------seteq::Orda=>[a]->[a]->Boolseteqxy=nub(sortx)==nub(sorty)assert::String->Bool->IO()assertsTrue=return()assertsFalse=print("Assertion "++s++" failed")do_tests::()do_tests=unsafePerformIO$dotests_applytests_isidtests_supporttests_jointests_join=doassert"j1"$joinempty(empty::PermInt)==Justemptyassert"j2"$join(single12)empty==Just(single12)assert"j3"$join(single12)(single21)==Just(single12)assert"j4"$join(single12)(single13)==Nothingtests_apply=doassert"a1"$applyempty1==1assert"a2"$apply(single12)1==2assert"a3"$apply(single21)1==2assert"a4"$apply((single12)<>(single21))1==1tests_isid=doassert"i1"$isid(empty::PermInt)==Trueassert"i2"$isid(single12)==Falseassert"i3"$isid(single11)==Trueassert"i4"$isid((single12)<>(single12))==Trueassert"i5"$isid((single12)<>(single21))==Trueassert"i6"$isid((single12)<>(single32))==Falsetests_support=doassert"s1"$support(empty::PermInt)`seteq`[]assert"s2"$support(single12)`seteq`[1,2]assert"s3"$support(single11)`seteq`[]assert"s4"$support((single12)<>(single12))`seteq`[]assert"s5"$support((single12)<>(single21))`seteq`[]assert"s6"$support((single12)<>(single32))`seteq`[1,2,3]