123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547(**************************************************************************)(* *)(* 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. *)(* *)(**************************************************************************)moduletypeOrderedType=sigtypetvalcompare:t->t->intendmoduletypeS=sigtypekeytype!+'atvalempty:'atvaladd:key->'a->'at->'atvaladd_to_list:key->'a->'alistt->'alisttvalupdate:key->('aoption->'aoption)->'at->'atvalsingleton:key->'a->'atvalremove:key->'at->'atvalmerge:(key->'aoption->'boption->'coption)->'at->'bt->'ctvalunion:(key->'a->'a->'aoption)->'at->'at->'atvalcardinal:'at->intvalbindings:'at->(key*'a)listvalmin_binding:'at->(key*'a)valmin_binding_opt:'at->(key*'a)optionvalmax_binding:'at->(key*'a)valmax_binding_opt:'at->(key*'a)optionvalchoose:'at->(key*'a)valchoose_opt:'at->(key*'a)optionvalfind:key->'at->'avalfind_opt:key->'at->'aoptionvalfind_first:(key->bool)->'at->key*'avalfind_first_opt:(key->bool)->'at->(key*'a)optionvalfind_last:(key->bool)->'at->key*'avalfind_last_opt:(key->bool)->'at->(key*'a)optionvaliter:(key->'a->unit)->'at->unitvalfold:(key->'a->'b->'b)->'at->'b->'bvalmap:('a->'b)->'at->'btvalmapi:(key->'a->'b)->'at->'btvalfilter:(key->'a->bool)->'at->'atvalfilter_map:(key->'a->'boption)->'at->'btvalpartition:(key->'a->bool)->'at->'at*'atvalsplit:key->'at->'at*'aoption*'atvalis_empty:'at->boolvalmem:key->'at->boolvalequal:('a->'a->bool)->'at->'at->boolvalcompare:('a->'a->int)->'at->'at->intvalfor_all:(key->'a->bool)->'at->boolvalexists:(key->'a->bool)->'at->boolvalto_list:'at->(key*'a)listvalof_list:(key*'a)list->'atvalto_seq:'at->(key*'a)Seq.tvalto_rev_seq:'at->(key*'a)Seq.tvalto_seq_from:key->'at->(key*'a)Seq.tvaladd_seq:(key*'a)Seq.t->'at->'atvalof_seq:(key*'a)Seq.t->'atendmoduleMake(Ord:OrderedType)=structtypekey=Ord.ttype'at=Empty|Nodeof{l:'at;v:key;d:'a;r:'at;h:int}letheight=functionEmpty->0|Node{h}->hletcreatelxdr=lethl=heightlandhr=heightrinNode{l;v=x;d;r;h=(ifhl>=hrthenhl+1elsehr+1)}letsingletonxd=Node{l=Empty;v=x;d;r=Empty;h=1}letballxdr=lethl=matchlwithEmpty->0|Node{h}->hinlethr=matchrwithEmpty->0|Node{h}->hinifhl>hr+2thenbeginmatchlwithEmpty->invalid_arg"Map.bal"|Node{l=ll;v=lv;d=ld;r=lr}->ifheightll>=heightlrthencreatelllvld(createlrxdr)elsebeginmatchlrwithEmpty->invalid_arg"Map.bal"|Node{l=lrl;v=lrv;d=lrd;r=lrr}->create(createlllvldlrl)lrvlrd(createlrrxdr)endendelseifhr>hl+2thenbeginmatchrwithEmpty->invalid_arg"Map.bal"|Node{l=rl;v=rv;d=rd;r=rr}->ifheightrr>=heightrlthencreate(createlxdrl)rvrdrrelsebeginmatchrlwithEmpty->invalid_arg"Map.bal"|Node{l=rll;v=rlv;d=rld;r=rlr}->create(createlxdrll)rlvrld(createrlrrvrdrr)endendelseNode{l;v=x;d;r;h=(ifhl>=hrthenhl+1elsehr+1)}letempty=Emptyletis_empty=functionEmpty->true|_->falseletrecaddxdata=functionEmpty->Node{l=Empty;v=x;d=data;r=Empty;h=1}|Node{l;v;d;r;h}asm->letc=Ord.comparexvinifc=0thenifd==datathenmelseNode{l;v=x;d=data;r;h}elseifc<0thenletll=addxdatalinifl==llthenmelseballlvdrelseletrr=addxdatarinifr==rrthenmelseballvdrrletrecfindx=functionEmpty->raiseNot_found|Node{l;v;d;r}->letc=Ord.comparexvinifc=0thendelsefindx(ifc<0thenlelser)letrecfind_first_auxv0d0f=functionEmpty->(v0,d0)|Node{l;v;d;r}->iffvthenfind_first_auxvdflelsefind_first_auxv0d0frletrecfind_firstf=functionEmpty->raiseNot_found|Node{l;v;d;r}->iffvthenfind_first_auxvdflelsefind_firstfrletrecfind_first_opt_auxv0d0f=functionEmpty->Some(v0,d0)|Node{l;v;d;r}->iffvthenfind_first_opt_auxvdflelsefind_first_opt_auxv0d0frletrecfind_first_optf=functionEmpty->None|Node{l;v;d;r}->iffvthenfind_first_opt_auxvdflelsefind_first_optfrletrecfind_last_auxv0d0f=functionEmpty->(v0,d0)|Node{l;v;d;r}->iffvthenfind_last_auxvdfrelsefind_last_auxv0d0flletrecfind_lastf=functionEmpty->raiseNot_found|Node{l;v;d;r}->iffvthenfind_last_auxvdfrelsefind_lastflletrecfind_last_opt_auxv0d0f=functionEmpty->Some(v0,d0)|Node{l;v;d;r}->iffvthenfind_last_opt_auxvdfrelsefind_last_opt_auxv0d0flletrecfind_last_optf=functionEmpty->None|Node{l;v;d;r}->iffvthenfind_last_opt_auxvdfrelsefind_last_optflletrecfind_optx=functionEmpty->None|Node{l;v;d;r}->letc=Ord.comparexvinifc=0thenSomedelsefind_optx(ifc<0thenlelser)letrecmemx=functionEmpty->false|Node{l;v;r}->letc=Ord.comparexvinc=0||memx(ifc<0thenlelser)letrecmin_binding=functionEmpty->raiseNot_found|Node{l=Empty;v;d}->(v,d)|Node{l}->min_bindinglletrecmin_binding_opt=functionEmpty->None|Node{l=Empty;v;d}->Some(v,d)|Node{l}->min_binding_optlletrecmax_binding=functionEmpty->raiseNot_found|Node{v;d;r=Empty}->(v,d)|Node{r}->max_bindingrletrecmax_binding_opt=functionEmpty->None|Node{v;d;r=Empty}->Some(v,d)|Node{r}->max_binding_optrletrecremove_min_binding=functionEmpty->invalid_arg"Map.remove_min_elt"|Node{l=Empty;r}->r|Node{l;v;d;r}->bal(remove_min_bindingl)vdrletmerget1t2=match(t1,t2)with(Empty,t)->t|(t,Empty)->t|(_,_)->let(x,d)=min_bindingt2inbalt1xd(remove_min_bindingt2)letrecremovex=functionEmpty->Empty|(Node{l;v;d;r}asm)->letc=Ord.comparexvinifc=0thenmergelrelseifc<0thenletll=removexlinifl==llthenmelseballlvdrelseletrr=removexrinifr==rrthenmelseballvdrrletrecupdatexf=functionEmpty->beginmatchfNonewith|None->Empty|Somedata->Node{l=Empty;v=x;d=data;r=Empty;h=1}end|Node{l;v;d;r;h}asm->letc=Ord.comparexvinifc=0thenbeginmatchf(Somed)with|None->mergelr|Somedata->ifd==datathenmelseNode{l;v=x;d=data;r;h}endelseifc<0thenletll=updatexflinifl==llthenmelseballlvdrelseletrr=updatexfrinifr==rrthenmelseballvdrrletadd_to_listxdatam=letadd=functionNone->Some[data]|Somel->Some(data::l)inupdatexaddmletreciterf=functionEmpty->()|Node{l;v;d;r}->iterfl;fvd;iterfrletrecmapf=functionEmpty->Empty|Node{l;v;d;r;h}->letl'=mapflinletd'=fdinletr'=mapfrinNode{l=l';v;d=d';r=r';h}letrecmapif=functionEmpty->Empty|Node{l;v;d;r;h}->letl'=mapiflinletd'=fvdinletr'=mapifrinNode{l=l';v;d=d';r=r';h}letrecfoldfmaccu=matchmwithEmpty->accu|Node{l;v;d;r}->foldfr(fvd(foldflaccu))letrecfor_allp=functionEmpty->true|Node{l;v;d;r}->pvd&&for_allpl&&for_allprletrecexistsp=functionEmpty->false|Node{l;v;d;r}->pvd||existspl||existspr(* Beware: those two functions assume that the added k is *strictly*
smaller (or bigger) than all the present keys in the tree; it
does not test for equality with the current min (or max) key.
Indeed, they are only used during the "join" operation which
respects this precondition.
*)letrecadd_min_bindingkx=function|Empty->singletonkx|Node{l;v;d;r}->bal(add_min_bindingkxl)vdrletrecadd_max_bindingkx=function|Empty->singletonkx|Node{l;v;d;r}->ballvd(add_max_bindingkxr)(* Same as create and bal, but no assumptions are made on the
relative heights of l and r. *)letrecjoinlvdr=match(l,r)with(Empty,_)->add_min_bindingvdr|(_,Empty)->add_max_bindingvdl|(Node{l=ll;v=lv;d=ld;r=lr;h=lh},Node{l=rl;v=rv;d=rd;r=rr;h=rh})->iflh>rh+2thenballllvld(joinlrvdr)elseifrh>lh+2thenbal(joinlvdrl)rvrdrrelsecreatelvdr(* 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|(_,_)->let(x,d)=min_bindingt2injoint1xd(remove_min_bindingt2)letconcat_or_joint1vdt2=matchdwith|Somed->joint1vdt2|None->concatt1t2letrecsplitx=functionEmpty->(Empty,None,Empty)|Node{l;v;d;r}->letc=Ord.comparexvinifc=0then(l,Somed,r)elseifc<0thenlet(ll,pres,rl)=splitxlin(ll,pres,joinrlvdr)elselet(lr,pres,rr)=splitxrin(joinlvdlr,pres,rr)letrecmergefs1s2=match(s1,s2)with(Empty,Empty)->Empty|(Node{l=l1;v=v1;d=d1;r=r1;h=h1},_)whenh1>=heights2->let(l2,d2,r2)=splitv1s2inconcat_or_join(mergefl1l2)v1(fv1(Somed1)d2)(mergefr1r2)|(_,Node{l=l2;v=v2;d=d2;r=r2})->let(l1,d1,r1)=splitv2s1inconcat_or_join(mergefl1l2)v2(fv2d1(Somed2))(mergefr1r2)|_->assertfalseletrecunionfs1s2=match(s1,s2)with|(Empty,s)|(s,Empty)->s|(Node{l=l1;v=v1;d=d1;r=r1;h=h1},Node{l=l2;v=v2;d=d2;r=r2;h=h2})->ifh1>=h2thenlet(l2,d2,r2)=splitv1s2inletl=unionfl1l2andr=unionfr1r2inmatchd2with|None->joinlv1d1r|Somed2->concat_or_joinlv1(fv1d1d2)relselet(l1,d1,r1)=splitv2s1inletl=unionfl1l2andr=unionfr1r2inmatchd1with|None->joinlv2d2r|Somed1->concat_or_joinlv2(fv2d1d2)rletrecfilterp=functionEmpty->Empty|Node{l;v;d;r}asm->(* call [p] in the expected left-to-right order *)letl'=filterplinletpvd=pvdinletr'=filterprinifpvdthenifl==l'&&r==r'thenmelsejoinl'vdr'elseconcatl'r'letrecfilter_mapf=functionEmpty->Empty|Node{l;v;d;r}->(* call [f] in the expected left-to-right order *)letl'=filter_mapflinletfvd=fvdinletr'=filter_mapfrinbeginmatchfvdwith|Somed'->joinl'vd'r'|None->concatl'r'endletrecpartitionp=functionEmpty->(Empty,Empty)|Node{l;v;d;r}->(* call [p] in the expected left-to-right order *)let(lt,lf)=partitionplinletpvd=pvdinlet(rt,rf)=partitionprinifpvdthen(joinltvdrt,concatlfrf)else(concatltrt,joinlfvdrf)type'aenumeration=End|Moreofkey*'a*'at*'aenumerationletreccons_enumme=matchmwithEmpty->e|Node{l;v;d;r}->cons_enuml(More(v,d,r,e))letcomparecmpm1m2=letreccompare_auxe1e2=match(e1,e2)with(End,End)->0|(End,_)->-1|(_,End)->1|(More(v1,d1,r1,e1),More(v2,d2,r2,e2))->letc=Ord.comparev1v2inifc<>0thencelseletc=cmpd1d2inifc<>0thencelsecompare_aux(cons_enumr1e1)(cons_enumr2e2)incompare_aux(cons_enumm1End)(cons_enumm2End)letequalcmpm1m2=letrecequal_auxe1e2=match(e1,e2)with(End,End)->true|(End,_)->false|(_,End)->false|(More(v1,d1,r1,e1),More(v2,d2,r2,e2))->Ord.comparev1v2=0&&cmpd1d2&&equal_aux(cons_enumr1e1)(cons_enumr2e2)inequal_aux(cons_enumm1End)(cons_enumm2End)letreccardinal=functionEmpty->0|Node{l;r}->cardinall+1+cardinalrletrecbindings_auxaccu=functionEmpty->accu|Node{l;v;d;r}->bindings_aux((v,d)::bindings_auxaccur)lletbindingss=bindings_aux[]sletchoose=min_bindingletchoose_opt=min_binding_optletto_list=bindingsletof_listbs=List.fold_left(funm(k,v)->addkvm)emptybsletadd_seqim=Seq.fold_left(funm(k,v)->addkvm)miletof_seqi=add_seqiemptyletrecseq_of_enum_c()=matchcwith|End->Seq.Nil|More(k,v,t,rest)->Seq.Cons((k,v),seq_of_enum_(cons_enumtrest))letto_seqm=seq_of_enum_(cons_enummEnd)letrecsnoc_enumse=matchswithEmpty->e|Node{l;v;d;r}->snoc_enumr(More(v,d,l,e))letrecrev_seq_of_enum_c()=matchcwith|End->Seq.Nil|More(k,v,t,rest)->Seq.Cons((k,v),rev_seq_of_enum_(snoc_enumtrest))letto_rev_seqc=rev_seq_of_enum_(snoc_enumcEnd)letto_seq_fromlowm=letrecauxlowmc=matchmwith|Empty->c|Node{l;v;d;r;_}->beginmatchOrd.comparevlowwith|0->More(v,d,r,c)|nwhenn<0->auxlowrc|_->auxlowl(More(v,d,r,c))endinseq_of_enum_(auxlowmEnd)end