123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702(**************************************************************************)(* *)(* OCaml *)(* *)(* Simon Cruanes *)(* *)(* Copyright 2017 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. *)(* *)(**************************************************************************)(* Module [Seq]: functional iterators *)type+'anode=|Nil|Consof'a*'atand'at=unit->'anodeletempty()=Nilletreturnx()=Cons(x,empty)letconsxnext()=Cons(x,next)letrecappendseq1seq2()=matchseq1()with|Nil->seq2()|Cons(x,next)->Cons(x,appendnextseq2)letrecmapfseq()=matchseq()with|Nil->Nil|Cons(x,next)->Cons(fx,mapfnext)letrecfilter_mapfseq()=matchseq()with|Nil->Nil|Cons(x,next)->matchfxwith|None->filter_mapfnext()|Somey->Cons(y,filter_mapfnext)letrecfilterfseq()=matchseq()with|Nil->Nil|Cons(x,next)->iffxthenCons(x,filterfnext)elsefilterfnext()letrecconcatseq()=matchseq()with|Nil->Nil|Cons(x,next)->appendx(concatnext)()letrecflat_mapfseq()=matchseq()with|Nil->Nil|Cons(x,next)->append(fx)(flat_mapfnext)()letconcat_map=flat_mapletrecfold_leftfaccseq=matchseq()with|Nil->acc|Cons(x,next)->letacc=faccxinfold_leftfaccnextletreciterfseq=matchseq()with|Nil->()|Cons(x,next)->fx;iterfnextletrecunfoldfu()=matchfuwith|None->Nil|Some(x,u')->Cons(x,unfoldfu')letis_emptyxs=matchxs()with|Nil->true|Cons(_,_)->falseletunconsxs=matchxs()with|Cons(x,xs)->Some(x,xs)|Nil->Noneletreclength_auxaccuxs=matchxs()with|Nil->accu|Cons(_,xs)->length_aux(accu+1)xslet[@inline]lengthxs=length_aux0xsletreciteri_auxfixs=matchxs()with|Nil->()|Cons(x,xs)->fix;iteri_auxf(i+1)xslet[@inline]iterifxs=iteri_auxf0xsletrecfold_lefti_auxfaccuixs=matchxs()with|Nil->accu|Cons(x,xs)->letaccu=faccuixinfold_lefti_auxfaccu(i+1)xslet[@inline]fold_leftifaccuxs=fold_lefti_auxfaccu0xsletrecfor_allpxs=matchxs()with|Nil->true|Cons(x,xs)->px&&for_allpxsletrecexistspxs=matchxs()with|Nil->false|Cons(x,xs)->px||existspxsletrecfindpxs=matchxs()with|Nil->None|Cons(x,xs)->ifpxthenSomexelsefindpxsletfind_indexpxs=letrecauxixs=matchxs()with|Nil->None|Cons(x,xs)->ifpxthenSomeielseaux(i+1)xsinaux0xsletrecfind_mapfxs=matchxs()with|Nil->None|Cons(x,xs)->matchfxwith|None->find_mapfxs|Some_asresult->resultletfind_mapifxs=letrecauxixs=matchxs()with|Nil->None|Cons(x,xs)->matchfixwith|None->aux(i+1)xs|Some_asresult->resultinaux0xs(* [iter2], [fold_left2], [for_all2], [exists2], [map2], [zip] work also in
the case where the two sequences have different lengths. They stop as soon
as one sequence is exhausted. Their behavior is slightly asymmetric: when
[xs] is empty, they do not force [ys]; however, when [ys] is empty, [xs] is
forced, even though the result of the function application [xs()] turns out
to be useless. *)letreciter2fxsys=matchxs()with|Nil->()|Cons(x,xs)->matchys()with|Nil->()|Cons(y,ys)->fxy;iter2fxsysletrecfold_left2faccuxsys=matchxs()with|Nil->accu|Cons(x,xs)->matchys()with|Nil->accu|Cons(y,ys)->letaccu=faccuxyinfold_left2faccuxsysletrecfor_all2fxsys=matchxs()with|Nil->true|Cons(x,xs)->matchys()with|Nil->true|Cons(y,ys)->fxy&&for_all2fxsysletrecexists2fxsys=matchxs()with|Nil->false|Cons(x,xs)->matchys()with|Nil->false|Cons(y,ys)->fxy||exists2fxsysletrecequaleqxsys=matchxs(),ys()with|Nil,Nil->true|Cons(x,xs),Cons(y,ys)->eqxy&&equaleqxsys|Nil,Cons(_,_)|Cons(_,_),Nil->falseletreccomparecmpxsys=matchxs(),ys()with|Nil,Nil->0|Cons(x,xs),Cons(y,ys)->letc=cmpxyinifc<>0thencelsecomparecmpxsys|Nil,Cons(_,_)->-1|Cons(_,_),Nil->+1(* [init_aux f i j] is the sequence [f i, ..., f (j-1)]. *)letrecinit_auxfij()=ifi<jthenbeginCons(fi,init_auxf(i+1)j)endelseNilletinitnf=ifn<0theninvalid_arg"Seq.init"elseinit_auxf0nletrecrepeatx()=Cons(x,repeatx)letrecforeverf()=Cons(f(),foreverf)(* This preliminary definition of [cycle] requires the sequence [xs]
to be nonempty. Applying it to an empty sequence would produce a
sequence that diverges when it is forced. *)letreccycle_nonemptyxs()=appendxs(cycle_nonemptyxs)()(* [cycle xs] checks whether [xs] is empty and, if so, returns an empty
sequence. Otherwise, [cycle xs] produces one copy of [xs] followed
with the infinite sequence [cycle_nonempty xs]. Thus, the nonemptiness
check is performed just once. *)letcyclexs()=matchxs()with|Nil->Nil|Cons(x,xs')->Cons(x,appendxs'(cycle_nonemptyxs))(* [iterate1 f x] is the sequence [f x, f (f x), ...].
It is equivalent to [tail (iterate f x)].
[iterate1] is used as a building block in the definition of [iterate]. *)letreciterate1fx()=lety=fxinCons(y,iterate1fy)(* [iterate f x] is the sequence [x, f x, ...]. *)(* The reason why we give this slightly indirect definition of [iterate],
as opposed to the more naive definition that may come to mind, is that
we are careful to avoid evaluating [f x] until this function call is
actually necessary. The naive definition (not shown here) computes the
second argument of the sequence, [f x], when the first argument is
requested by the user. *)letiteratefx=consx(iterate1fx)letrecmapi_auxfixs()=matchxs()with|Nil->Nil|Cons(x,xs)->Cons(fix,mapi_auxf(i+1)xs)let[@inline]mapifxs=mapi_auxf0xs(* [tail_scan f s xs] is equivalent to [tail (scan f s xs)].
[tail_scan] is used as a building block in the definition of [scan]. *)(* This slightly indirect definition of [scan] is meant to avoid computing
elements too early; see the above comment about [iterate1] and [iterate]. *)letrectail_scanfsxs()=matchxs()with|Nil->Nil|Cons(x,xs)->lets=fsxinCons(s,tail_scanfsxs)letscanfsxs=conss(tail_scanfsxs)(* [take] is defined in such a way that [take 0 xs] returns [empty]
immediately, without allocating any memory. *)letrectake_auxnxs=ifn=0thenemptyelsefun()->matchxs()with|Nil->Nil|Cons(x,xs)->Cons(x,take_aux(n-1)xs)lettakenxs=ifn<0theninvalid_arg"Seq.take";take_auxnxs(* [force_drop n xs] is equivalent to [drop n xs ()].
[force_drop n xs] requires [n > 0].
[force_drop] is used as a building block in the definition of [drop]. *)letrecforce_dropnxs=matchxs()with|Nil->Nil|Cons(_,xs)->letn=n-1inifn=0thenxs()elseforce_dropnxs(* [drop] is defined in such a way that [drop 0 xs] returns [xs] immediately,
without allocating any memory. *)letdropnxs=ifn<0theninvalid_arg"Seq.drop"elseifn=0thenxselsefun()->force_dropnxsletrectake_whilepxs()=matchxs()with|Nil->Nil|Cons(x,xs)->ifpxthenCons(x,take_whilepxs)elseNilletrecdrop_whilepxs()=matchxs()with|Nil->Nil|Cons(x,xs)asnode->ifpxthendrop_whilepxs()elsenodeletrecgroupeqxs()=matchxs()with|Nil->Nil|Cons(x,xs)->Cons(consx(take_while(eqx)xs),groupeq(drop_while(eqx)xs))exceptionForced_twicemoduleSuspension=structtype'asuspension=unit->'a(* Conversions. *)letto_lazy:'asuspension->'aLazy.t=Lazy.from_fun(* fun s -> lazy (s()) *)letfrom_lazy(s:'aLazy.t):'asuspension=fun()->Lazy.forces(* [memoize] turns an arbitrary suspension into a persistent suspension. *)letmemoize(s:'asuspension):'asuspension=from_lazy(to_lazys)(* [failure] is a suspension that fails when forced. *)letfailure:_suspension=fun()->(* A suspension created by [once] has been forced twice. *)raiseForced_twice(* If [f] is a suspension, then [once f] is a suspension that can be forced
at most once. If it is forced more than once, then [Forced_twice] is
raised. *)letonce(f:'asuspension):'asuspension=letaction=Atomic.makefinfun()->(* Get the function currently stored in [action], and write the
function [failure] in its place, so the next access will result
in a call to [failure()]. *)letf=Atomic.exchangeactionfailureinf()end(* Suspension *)letrecmemoizexs=Suspension.memoize(fun()->matchxs()with|Nil->Nil|Cons(x,xs)->Cons(x,memoizexs))letreconcexs=Suspension.once(fun()->matchxs()with|Nil->Nil|Cons(x,xs)->Cons(x,oncexs))letreczipxsys()=matchxs()with|Nil->Nil|Cons(x,xs)->matchys()with|Nil->Nil|Cons(y,ys)->Cons((x,y),zipxsys)letrecmap2fxsys()=matchxs()with|Nil->Nil|Cons(x,xs)->matchys()with|Nil->Nil|Cons(y,ys)->Cons(fxy,map2fxsys)letrecinterleavexsys()=matchxs()with|Nil->ys()|Cons(x,xs)->Cons(x,interleaveysxs)(* [sorted_merge1l cmp x xs ys] is equivalent to
[sorted_merge cmp (cons x xs) ys].
[sorted_merge1r cmp xs y ys] is equivalent to
[sorted_merge cmp xs (cons y ys)].
[sorted_merge1 cmp x xs y ys] is equivalent to
[sorted_merge cmp (cons x xs) (cons y ys)].
These three functions are used as building blocks in the definition
of [sorted_merge]. *)letrecsorted_merge1lcmpxxsys()=matchys()with|Nil->Cons(x,xs)|Cons(y,ys)->sorted_merge1cmpxxsyysandsorted_merge1rcmpxsyys()=matchxs()with|Nil->Cons(y,ys)|Cons(x,xs)->sorted_merge1cmpxxsyysandsorted_merge1cmpxxsyys=ifcmpxy<=0thenCons(x,sorted_merge1rcmpxsyys)elseCons(y,sorted_merge1lcmpxxsys)letsorted_mergecmpxsys()=matchxs(),ys()with|Nil,Nil->Nil|Nil,c|c,Nil->c|Cons(x,xs),Cons(y,ys)->sorted_merge1cmpxxsyysletrecmap_fstxys()=matchxys()with|Nil->Nil|Cons((x,_),xys)->Cons(x,map_fstxys)letrecmap_sndxys()=matchxys()with|Nil->Nil|Cons((_,y),xys)->Cons(y,map_sndxys)letunzipxys=map_fstxys,map_sndxysletsplit=unzip(* [filter_map_find_left_map f xs] is equivalent to
[filter_map Either.find_left (map f xs)]. *)letrecfilter_map_find_left_mapfxs()=matchxs()with|Nil->Nil|Cons(x,xs)->matchfxwith|Either.Lefty->Cons(y,filter_map_find_left_mapfxs)|Either.Right_->filter_map_find_left_mapfxs()letrecfilter_map_find_right_mapfxs()=matchxs()with|Nil->Nil|Cons(x,xs)->matchfxwith|Either.Left_->filter_map_find_right_mapfxs()|Either.Rightz->Cons(z,filter_map_find_right_mapfxs)letpartition_mapfxs=filter_map_find_left_mapfxs,filter_map_find_right_mapfxsletpartitionpxs=filterpxs,filter(funx->not(px))xs(* If [xss] is a matrix (a sequence of rows), then [peel xss] is a pair of
the first column (a sequence of elements) and of the remainder of the
matrix (a sequence of shorter rows). These two sequences have the same
length. The rows of the matrix [xss] are not required to have the same
length. An empty row is ignored. *)(* Because [peel] uses [unzip], its argument must be persistent. The same
remark applies to [transpose], [diagonals], [product], etc. *)letpeelxss=unzip(filter_mapunconsxss)letrectransposexss()=letheads,tails=peelxssinifis_emptyheadsthenbeginassert(is_emptytails);NilendelseCons(heads,transposetails)(* The internal function [diagonals] takes an extra argument, [remainders],
which contains the remainders of the rows that have already been
discovered. *)letrecdiagonalsremaindersxss()=matchxss()with|Cons(xs,xss)->beginmatchxs()with|Cons(x,xs)->(* We discover a new nonempty row [x :: xs]. Thus, the next diagonal
is [x :: heads]: this diagonal begins with [x] and continues with
the first element of every row in [remainders]. In the recursive
call, the argument [remainders] is instantiated with [xs ::
tails], which means that we have one more remaining row, [xs],
and that we keep the tails of the pre-existing remaining rows. *)letheads,tails=peelremaindersinCons(consxheads,diagonals(consxstails)xss)|Nil->(* We discover a new empty row. In this case, the new diagonal is
just [heads], and [remainders] is instantiated with just [tails],
as we do not have one more remaining row. *)letheads,tails=peelremaindersinCons(heads,diagonalstailsxss)end|Nil->(* There are no more rows to be discovered. There remains to exhaust
the remaining rows. *)transposeremainders()(* If [xss] is a matrix (a sequence of rows), then [diagonals xss] is
the sequence of its diagonals.
The first diagonal contains just the first element of the
first row. The second diagonal contains the first element of the
second row and the second element of the first row; and so on.
This kind of diagonal is in fact sometimes known as an antidiagonal.
- Every diagonal is a finite sequence.
- The rows of the matrix [xss] are not required to have the same length.
- The matrix [xss] is not required to be finite (in either direction).
- The matrix [xss] must be persistent. *)letdiagonalsxss=diagonalsemptyxssletmap_productfxsys=concat(diagonals(map(funx->map(funy->fxy)ys)xs))letproductxsys=map_product(funxy->(x,y))xsysletof_dispenserit=letrecc()=matchit()with|None->Nil|Somex->Cons(x,c)incletto_dispenserxs=lets=refxsinfun()->match(!s)()with|Nil->None|Cons(x,xs)->s:=xs;Somexletrecintsi()=Cons(i,ints(i+1))