123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623(**************************************************************************)(* *)(* OCaml *)(* *)(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)(* *)(* Copyright 1996 Institut National de Recherche en Informatique et *)(* en Automatique. *)(* *)(* All rights reserved. This file is distributed under the terms of *)(* the GNU Lesser General Public License version 2.1, with the *)(* special exception on linking described in the file LICENSE. *)(* *)(**************************************************************************)(* Sets over ordered types *)moduletypeOrderedType=sigtypetvalcompare:t->t->intendmoduletypeS=sigtypeelttypetvalempty:tvaladd:elt->t->tvalsingleton:elt->tvalremove:elt->t->tvalunion:t->t->tvalinter:t->t->tvaldisjoint:t->t->boolvaldiff:t->t->tvalcardinal:t->intvalelements:t->eltlistvalmin_elt:t->eltvalmin_elt_opt:t->eltoptionvalmax_elt:t->eltvalmax_elt_opt:t->eltoptionvalchoose:t->eltvalchoose_opt:t->eltoptionvalfind:elt->t->eltvalfind_opt:elt->t->eltoptionvalfind_first:(elt->bool)->t->eltvalfind_first_opt:(elt->bool)->t->eltoptionvalfind_last:(elt->bool)->t->eltvalfind_last_opt:(elt->bool)->t->eltoptionvaliter:(elt->unit)->t->unitvalfold:(elt->'a->'a)->t->'a->'avalmap:(elt->elt)->t->tvalfilter:(elt->bool)->t->tvalfilter_map:(elt->eltoption)->t->tvalpartition:(elt->bool)->t->t*tvalsplit:elt->t->t*bool*tvalis_empty:t->boolvalmem:elt->t->boolvalequal:t->t->boolvalcompare:t->t->intvalsubset:t->t->boolvalfor_all:(elt->bool)->t->boolvalexists:(elt->bool)->t->boolvalto_list:t->eltlistvalof_list:eltlist->tvalto_seq_from:elt->t->eltSeq.tvalto_seq:t->eltSeq.tvalto_rev_seq:t->eltSeq.tvaladd_seq:eltSeq.t->t->tvalof_seq:eltSeq.t->tendmoduleMake(Ord:OrderedType)=structtypeelt=Ord.ttypet=Empty|Nodeof{l:t;v:elt;r:t;h:int}(* Sets are represented by balanced binary trees (the heights of the
children differ by at most 2 *)letheight=functionEmpty->0|Node{h}->h(* Creates a new node with left son l, value v and right son r.
We must have all elements of l < v < all elements of r.
l and r must be balanced and | height l - height r | <= 2.
Inline expansion of height for better speed. *)letcreatelvr=lethl=matchlwithEmpty->0|Node{h}->hinlethr=matchrwithEmpty->0|Node{h}->hinNode{l;v;r;h=(ifhl>=hrthenhl+1elsehr+1)}(* Same as create, but performs one step of rebalancing if necessary.
Assumes l and r balanced and | height l - height r | <= 3.
Inline expansion of create for better speed in the most frequent case
where no rebalancing is required. *)letballvr=lethl=matchlwithEmpty->0|Node{h}->hinlethr=matchrwithEmpty->0|Node{h}->hinifhl>hr+2thenbeginmatchlwithEmpty->invalid_arg"Set.bal"|Node{l=ll;v=lv;r=lr}->ifheightll>=heightlrthencreatelllv(createlrvr)elsebeginmatchlrwithEmpty->invalid_arg"Set.bal"|Node{l=lrl;v=lrv;r=lrr}->create(createlllvlrl)lrv(createlrrvr)endendelseifhr>hl+2thenbeginmatchrwithEmpty->invalid_arg"Set.bal"|Node{l=rl;v=rv;r=rr}->ifheightrr>=heightrlthencreate(createlvrl)rvrrelsebeginmatchrlwithEmpty->invalid_arg"Set.bal"|Node{l=rll;v=rlv;r=rlr}->create(createlvrll)rlv(createrlrrvrr)endendelseNode{l;v;r;h=(ifhl>=hrthenhl+1elsehr+1)}(* Insertion of one element *)letrecaddx=functionEmpty->Node{l=Empty;v=x;r=Empty;h=1}|Node{l;v;r}ast->letc=Ord.comparexvinifc=0thentelseifc<0thenletll=addxlinifl==llthentelseballlvrelseletrr=addxrinifr==rrthentelseballvrrletsingletonx=Node{l=Empty;v=x;r=Empty;h=1}(* Beware: those two functions assume that the added v is *strictly*
smaller (or bigger) than all the present elements in the tree; it
does not test for equality with the current min (or max) element.
Indeed, they are only used during the "join" operation which
respects this precondition.
*)letrecadd_min_elementx=function|Empty->singletonx|Node{l;v;r}->bal(add_min_elementxl)vrletrecadd_max_elementx=function|Empty->singletonx|Node{l;v;r}->ballv(add_max_elementxr)(* Same as create and bal, but no assumptions are made on the
relative heights of l and r. *)letrecjoinlvr=match(l,r)with(Empty,_)->add_min_elementvr|(_,Empty)->add_max_elementvl|(Node{l=ll;v=lv;r=lr;h=lh},Node{l=rl;v=rv;r=rr;h=rh})->iflh>rh+2thenballllv(joinlrvr)elseifrh>lh+2thenbal(joinlvrl)rvrrelsecreatelvr(* Smallest and greatest element of a set *)letrecmin_elt=functionEmpty->raiseNot_found|Node{l=Empty;v}->v|Node{l}->min_eltlletrecmin_elt_opt=functionEmpty->None|Node{l=Empty;v}->Somev|Node{l}->min_elt_optlletrecmax_elt=functionEmpty->raiseNot_found|Node{v;r=Empty}->v|Node{r}->max_eltrletrecmax_elt_opt=functionEmpty->None|Node{v;r=Empty}->Somev|Node{r}->max_elt_optr(* Remove the smallest element of the given set *)letrecremove_min_elt=functionEmpty->invalid_arg"Set.remove_min_elt"|Node{l=Empty;r}->r|Node{l;v;r}->bal(remove_min_eltl)vr(* Merge two trees l and r into one.
All elements of l must precede the elements of r.
Assume | height l - height r | <= 2. *)letmerget1t2=match(t1,t2)with(Empty,t)->t|(t,Empty)->t|(_,_)->balt1(min_eltt2)(remove_min_eltt2)(* Merge two trees l and r into one.
All elements of l must precede the elements of r.
No assumption on the heights of l and r. *)letconcatt1t2=match(t1,t2)with(Empty,t)->t|(t,Empty)->t|(_,_)->joint1(min_eltt2)(remove_min_eltt2)(* Splitting. split x s returns a triple (l, present, r) where
- l is the set of elements of s that are < x
- r is the set of elements of s that are > x
- present is false if s contains no element equal to x,
or true if s contains an element equal to x. *)letrecsplitx=functionEmpty->(Empty,false,Empty)|Node{l;v;r}->letc=Ord.comparexvinifc=0then(l,true,r)elseifc<0thenlet(ll,pres,rl)=splitxlin(ll,pres,joinrlvr)elselet(lr,pres,rr)=splitxrin(joinlvlr,pres,rr)(* Implementation of the set operations *)letempty=Emptyletis_empty=functionEmpty->true|_->falseletrecmemx=functionEmpty->false|Node{l;v;r}->letc=Ord.comparexvinc=0||memx(ifc<0thenlelser)letrecremovex=functionEmpty->Empty|(Node{l;v;r}ast)->letc=Ord.comparexvinifc=0thenmergelrelseifc<0thenletll=removexlinifl==llthentelseballlvrelseletrr=removexrinifr==rrthentelseballvrrletrecunions1s2=match(s1,s2)with(Empty,t2)->t2|(t1,Empty)->t1|(Node{l=l1;v=v1;r=r1;h=h1},Node{l=l2;v=v2;r=r2;h=h2})->ifh1>=h2thenifh2=1thenaddv2s1elsebeginlet(l2,_,r2)=splitv1s2injoin(unionl1l2)v1(unionr1r2)endelseifh1=1thenaddv1s2elsebeginlet(l1,_,r1)=splitv2s1injoin(unionl1l2)v2(unionr1r2)endletrecinters1s2=match(s1,s2)with(Empty,_)->Empty|(_,Empty)->Empty|(Node{l=l1;v=v1;r=r1},t2)->matchsplitv1t2with(l2,false,r2)->concat(interl1l2)(interr1r2)|(l2,true,r2)->join(interl1l2)v1(interr1r2)(* Same as split, but compute the left and right subtrees
only if the pivot element is not in the set. The right subtree
is computed on demand. *)typesplit_bis=|Found|NotFoundoft*(unit->t)letrecsplit_bisx=functionEmpty->NotFound(Empty,(fun()->Empty))|Node{l;v;r;_}->letc=Ord.comparexvinifc=0thenFoundelseifc<0thenmatchsplit_bisxlwith|Found->Found|NotFound(ll,rl)->NotFound(ll,(fun()->join(rl())vr))elsematchsplit_bisxrwith|Found->Found|NotFound(lr,rr)->NotFound(joinlvlr,rr)letrecdisjoints1s2=match(s1,s2)with(Empty,_)|(_,Empty)->true|(Node{l=l1;v=v1;r=r1},t2)->ifs1==s2thenfalseelsematchsplit_bisv1t2withNotFound(l2,r2)->disjointl1l2&&disjointr1(r2())|Found->falseletrecdiffs1s2=match(s1,s2)with(Empty,_)->Empty|(t1,Empty)->t1|(Node{l=l1;v=v1;r=r1},t2)->matchsplitv1t2with(l2,false,r2)->join(diffl1l2)v1(diffr1r2)|(l2,true,r2)->concat(diffl1l2)(diffr1r2)typeenumeration=End|Moreofelt*t*enumerationletreccons_enumse=matchswithEmpty->e|Node{l;v;r}->cons_enuml(More(v,r,e))letreccompare_auxe1e2=match(e1,e2)with(End,End)->0|(End,_)->-1|(_,End)->1|(More(v1,r1,e1),More(v2,r2,e2))->letc=Ord.comparev1v2inifc<>0thencelsecompare_aux(cons_enumr1e1)(cons_enumr2e2)letcompares1s2=compare_aux(cons_enums1End)(cons_enums2End)letequals1s2=compares1s2=0letrecsubsets1s2=match(s1,s2)withEmpty,_->true|_,Empty->false|Node{l=l1;v=v1;r=r1},(Node{l=l2;v=v2;r=r2}ast2)->letc=Ord.comparev1v2inifc=0thensubsetl1l2&&subsetr1r2elseifc<0thensubset(Node{l=l1;v=v1;r=Empty;h=0})l2&&subsetr1t2elsesubset(Node{l=Empty;v=v1;r=r1;h=0})r2&&subsetl1t2letreciterf=functionEmpty->()|Node{l;v;r}->iterfl;fv;iterfrletrecfoldfsaccu=matchswithEmpty->accu|Node{l;v;r}->foldfr(fv(foldflaccu))letrecfor_allp=functionEmpty->true|Node{l;v;r}->pv&&for_allpl&&for_allprletrecexistsp=functionEmpty->false|Node{l;v;r}->pv||existspl||existsprletrecfilterp=functionEmpty->Empty|(Node{l;v;r})ast->(* call [p] in the expected left-to-right order *)letl'=filterplinletpv=pvinletr'=filterprinifpvthenifl==l'&&r==r'thentelsejoinl'vr'elseconcatl'r'letrecpartitionp=functionEmpty->(Empty,Empty)|Node{l;v;r}->(* call [p] in the expected left-to-right order *)let(lt,lf)=partitionplinletpv=pvinlet(rt,rf)=partitionprinifpvthen(joinltvrt,concatlfrf)else(concatltrt,joinlfvrf)letreccardinal=functionEmpty->0|Node{l;r}->cardinall+1+cardinalrletrecelements_auxaccu=functionEmpty->accu|Node{l;v;r}->elements_aux(v::elements_auxaccur)lletelementss=elements_aux[]sletchoose=min_eltletchoose_opt=min_elt_optletrecfindx=functionEmpty->raiseNot_found|Node{l;v;r}->letc=Ord.comparexvinifc=0thenvelsefindx(ifc<0thenlelser)letrecfind_first_auxv0f=functionEmpty->v0|Node{l;v;r}->iffvthenfind_first_auxvflelsefind_first_auxv0frletrecfind_firstf=functionEmpty->raiseNot_found|Node{l;v;r}->iffvthenfind_first_auxvflelsefind_firstfrletrecfind_first_opt_auxv0f=functionEmpty->Somev0|Node{l;v;r}->iffvthenfind_first_opt_auxvflelsefind_first_opt_auxv0frletrecfind_first_optf=functionEmpty->None|Node{l;v;r}->iffvthenfind_first_opt_auxvflelsefind_first_optfrletrecfind_last_auxv0f=functionEmpty->v0|Node{l;v;r}->iffvthenfind_last_auxvfrelsefind_last_auxv0flletrecfind_lastf=functionEmpty->raiseNot_found|Node{l;v;r}->iffvthenfind_last_auxvfrelsefind_lastflletrecfind_last_opt_auxv0f=functionEmpty->Somev0|Node{l;v;r}->iffvthenfind_last_opt_auxvfrelsefind_last_opt_auxv0flletrecfind_last_optf=functionEmpty->None|Node{l;v;r}->iffvthenfind_last_opt_auxvfrelsefind_last_optflletrecfind_optx=functionEmpty->None|Node{l;v;r}->letc=Ord.comparexvinifc=0thenSomevelsefind_optx(ifc<0thenlelser)lettry_joinlvr=(* [join l v r] can only be called when (elements of l < v <
elements of r); use [try_join l v r] when this property may
not hold, but you hope it does hold in the common case *)if(l=Empty||Ord.compare(max_eltl)v<0)&&(r=Empty||Ord.comparev(min_eltr)<0)thenjoinlvrelseunionl(addvr)letrecmapf=function|Empty->Empty|Node{l;v;r}ast->(* enforce left-to-right evaluation order *)letl'=mapflinletv'=fvinletr'=mapfrinifl==l'&&v==v'&&r==r'thentelsetry_joinl'v'r'lettry_concatt1t2=match(t1,t2)with(Empty,t)->t|(t,Empty)->t|(_,_)->try_joint1(min_eltt2)(remove_min_eltt2)letrecfilter_mapf=function|Empty->Empty|Node{l;v;r}ast->(* enforce left-to-right evaluation order *)letl'=filter_mapflinletv'=fvinletr'=filter_mapfrinbeginmatchv'with|Somev'->ifl==l'&&v==v'&&r==r'thentelsetry_joinl'v'r'|None->try_concatl'r'endletof_sorted_listl=letrecsubnl=matchn,lwith|0,l->Empty,l|1,x0::l->Node{l=Empty;v=x0;r=Empty;h=1},l|2,x0::x1::l->Node{l=Node{l=Empty;v=x0;r=Empty;h=1};v=x1;r=Empty;h=2},l|3,x0::x1::x2::l->Node{l=Node{l=Empty;v=x0;r=Empty;h=1};v=x1;r=Node{l=Empty;v=x2;r=Empty;h=1};h=2},l|n,l->letnl=n/2inletleft,l=subnllinmatchlwith|[]->assertfalse|mid::l->letright,l=sub(n-nl-1)lincreateleftmidright,linfst(sub(List.lengthl)l)letto_list=elementsletof_listl=matchlwith|[]->empty|[x0]->singletonx0|[x0;x1]->addx1(singletonx0)|[x0;x1;x2]->addx2(addx1(singletonx0))|[x0;x1;x2;x3]->addx3(addx2(addx1(singletonx0)))|[x0;x1;x2;x3;x4]->addx4(addx3(addx2(addx1(singletonx0))))|_->of_sorted_list(List.sort_uniqOrd.comparel)letadd_seqim=Seq.fold_left(funsx->addxs)miletof_seqi=add_seqiemptyletrecseq_of_enum_c()=matchcwith|End->Seq.Nil|More(x,t,rest)->Seq.Cons(x,seq_of_enum_(cons_enumtrest))letto_seqc=seq_of_enum_(cons_enumcEnd)letrecsnoc_enumse=matchswithEmpty->e|Node{l;v;r}->snoc_enumr(More(v,l,e))letrecrev_seq_of_enum_c()=matchcwith|End->Seq.Nil|More(x,t,rest)->Seq.Cons(x,rev_seq_of_enum_(snoc_enumtrest))letto_rev_seqc=rev_seq_of_enum_(snoc_enumcEnd)letto_seq_fromlows=letrecauxlowsc=matchswith|Empty->c|Node{l;r;v;_}->beginmatchOrd.comparevlowwith|0->More(v,r,c)|nwhenn<0->auxlowrc|_->auxlowl(More(v,r,c))endinseq_of_enum_(auxlowsEnd)end