OCaml標準ライブラリの拡張

2011-12-09 プログラミング

OCamlで使える標準ライブラリは、最初に触れた時こそ「すげー、集合とか標準で使えるの！？」とか思ってたものの、実際触っていると「あれ？　Setってof_listないの？」とか「え？　リストのconsって関数として用意されてないの？」とか「うわっ……私の年収、低すぎ……？」など、いろいろな不満が出てきます。最後のは関係ありませんが。

調べてみたところ、あれは標準ライブラリではなくすとっどりぶなのですね……
それならしょうがない。
普通ならCoreとかBatteriesとか入れるんでしょうが、変な依存性入れたくないですし、これまで組んだプログラムを修正するのも面倒なので、勉強も兼ねて自分で互換性持たせたまま拡張してみることにしました。
先日、OCamlでモナドっぽいものを作ったという記事を書きましたが、それも拡張の一貫ですね。
というわけで、覚え書きも兼ねて、詰まった部分などをまとめておきます。

さて、拡張にあたり、オブジェクト指向の継承やHaskellの型クラスを参考にしました。
仕組みとしてはコアとなるシグネチャを規定しておいて、そのシグネチャに適合するストラクチャを元に派生関数を一気に定義してしまうファンクタを作っておきます。
例えば、順序を持つ型tに関するモジュールOrderedは以下のように定義しています。

(* Ordered: Ordered Type *)
module Ordered =
struct
  (* Request Type *)
  module type Type =
  sig
    type t
    val compare : t -> t -> int
  end
 
  (* Return Signature *)
  module type S =
  sig
    type t
    val eq : t -> t -> bool
    val ne : t -> t -> bool
    val gt : t -> t -> bool
    val lt : t -> t -> bool
    val ge : t -> t -> bool
    val le : t -> t -> bool
    val equal : t -> t -> bool
    val nequal : t -> t -> bool
    val fix : (t -> t) -> t -> t
  end
 
  (* Make Upgraded Structure *)
  module Make(T:Type) :
    S with type t := T.t
    =
  struct
    open T
    let eq x y = compare x y = 
    let ne x y = compare x y <> 
    let gt x y = compare x y > 
    let lt x y = compare x y < 
    let ge x y = compare x y >= 
    let le x y = compare x y <= 
    let equal = eq
    let nequal = ne
    let fix = fix equal
  end
end

Makeが要求する型Typeでは、型tとtに関する比較関数compareが定義されていることを要求しています。
普段のSetに渡す型Orderedと同じ定義ですね。
MakeではこのTypeを元に、eqやne、fixといった関数を作ります。
比較関数compareさえわかればこのあたりの関数はcompareを使って定義できるので、ファンクタを使って定義しちゃえばいいわけです。
ちなみに戻り値の型が必要になる場合に備えて、ファンクタの戻り型Sも定義しておきます。

ここで重要なのは、Sにはtype tはあるけどval compareはないというところと、Makeの戻り型としてSを指定するときに、type tをT.tで上書きしてやることです。
そもそもファンクタの返すストラクチャは、受け取ったストラクチャと併用する前提です。なので、type tだのval compareだのを返してしまうと名前被りが起こってしまうわけです。
val compareは定義しなければ済むのですが、問題はtype tです。
tがないとeqなどの関数の型が書けません。
かといって’aにしてしまうわけにもいきません。シグネチャの方が戻り値のストラクチャより広くなってしまうのでエラーになります。

というわけで、Sにはtype tを定義しておいて、戻り型として指定するときにはwith type t := T.tで上書きしてしまうわけです。
このwith type _ := _ という構文はOCaml3.12から導入されたもので、with type _ = _ が「型が一緒だよ」というのをコンピュータに教えるだけなのに対し、「型を上書きするよ」という具体的な動作を伴います。
要は、型としてtがあったところをT.tで置き換えた上で、type tという定義そのものをなかった事にしてしまうわけですね。
これなら名前被りの心配はありません。

ちなみに、この辺は型を書かなければコンパイラがよろしくやってくれます。
とはいえ、.mliを書くとなると避けては通れない道ですし、そうでなくてもSet.Sなどを拡張したSetでも持たせようと思うと基板となるファンクタの戻り型は必要になってしまいます。
まぁ自分もこのライブラリ自体の.mliは書いていないですし、最後の方は型を書くのに疲れて書いてないモジュールもありますが……

このOrderedみたいな感じで、文字列化出来る型Stringable、モナド型Monad、コレクション型Collection、射影型Projection、及びそれらの多相バージョンを定義しています。
特に注意が必要なのがCollection型で、iterやmin_elt辺りを定義したくなりますが、Set.Sなどの関数と名前被りしてしまいます。
もしかしたらコンパイル通す方法があるかもしれませんが、自分はわからなかったので諦めました。
本当はListにもmin_eltとかを持たせたいところなんですけどねぇ。
あと、最初はCollectionの中にサブモジュールとしてOrdered.TypeのEltというモジュールを持たせていたのですが、よく考えるとElt.tはeltなので、必要なのがElt.compareだけなんですよね。
サブモジュールは型を書くのがとてもとても面倒なので、elt_compareという関数を作ることにしました。

あ、そういえばモジュールを持たせた場合、with typeの順番によってコンパイルが通ったり通らなかったりするみたいです。
with module Elt = T and type elt = T.tだと通るけど逆だと通らない、みたいな。
てっきり相互再帰のandみたいに定義順は関係ないのかと思いましたが、この場合は関係あるんですかね……

さて、フレームワークだけ定義してもしょうがないので、実際に使用するモジュールも定義していきます。
とりあえず2要素のタプルTuple2を以下のように定義しました。

(* Tuple: Module of Tuples *)
module Tuple2 =
struct
  let compare cmp1 cmp2 (x1,y1) (x2,y2) =
    if cmp1 x1 x2 <>  then
      cmp1 x1 x2
    else
      cmp2 y1 y2
  let to_string_sep lparen rparen sep f1 f2 (x,y)=
    lparen ^ (f1 x) ^ sep ^ (f2 y) ^ rparen
  let to_string f1 f2 =
    to_string_sep "(" ")" "," f1 f2
  let print f1 f2 fmt t =
    Format.fprintf fmt "%s" (to_string f1 f2 t)
  module Core =
  struct
    let fst = fst
    let snd = snd
    let apply f1 f2 (x1,x2) = (f1 x1, f2 x2)
    let apply_fst f (x,y) = (f x,y)
    let apply_snd f (x,y) = (x,f y)
    let apply_curry f (x,y) = f x y
    let build x y = (x,y)
    let rev_build y x = (x,y)
  end
 
  module Make(S1:OrderedStringable.Type)(S2:OrderedStringable.Type) =
  struct
    module Core =
    struct
      type t = S1.t * S2.t
      include Core
      let compare t1 t2 =
    compare S1.compare S2.compare t1 t2
      let to_string_sep lparen rparen sep (x,y)=
    lparen ^ (S1.to_string x) ^ sep ^ (S2.to_string y) ^ rparen
      let to_string =
    to_string_sep "(" ")" ","
    end
    include Core
    include OrderedStringable.Make(Core)
  end
 
  include Core
end

こんな感じで、トップレベルにユーティリティ関数を定義し、それとは別にMakeファンクタで具体的な型を与えた時の関数を定義しておきます。
Makeの中ではCoreモジュールで核となるストラクチャを定義し、これをOrderedStringable.Makeに渡してincludeすることで、OrderdとStringableに関する派生モジュールを一気に作っています。
ちなみにトップレベルではto_stringに各型のto_stringを渡さないと変換できませんが、Makeで作ったモジュールでは(Makeで受け取ってるので当然ですが)タプルを渡すだけで文字列に変換することが可能です。
これによって、Tuple2.Makeで得たモジュールを更に他のMakeに渡して……とする事ができ、作成したモジュールの型は特に指定しなくてもto_stringすることができるようになります。
その代償としてこれまでに書いたSet.MakeやMap.Makeに関して、渡すモジュールにto_stringを付け加える必要がありますが……まぁそれだけの修正で済むなら安いものです。

作り方の大枠としては上記のような感じで、型を強めるためのインターフェースとなるシグネチャと、実際に強めるためのファンクタを書く→Coreにインターフェースに適合するストラクチャを定義する→ひたすらMakeしてincludeする、という流れをやっています。
それ以外にもユーティリティ関数を幾つか用意していて、モナドにguardを作ったり、1–10といった記法で1から10までのリストを作ったり、Setに閉包や反射閉包を作るための関数を作ったり……といった感じになっています。

作っていて思ったこととして、やはりOCamlは型周りが難しい……
with typeの書き方やモジュールの定義の仕方によってコンパイルできなかったりするので、このへんの感覚をつかむのが難しいです。
今回は全体の.mliを書いてないですが、これを書くのは面倒そうですね。
あと、既存のSetやMapをincludeしてますが、このへんは中途半端に関数が定義されていて強化したモジュールと衝突しやすいので、必要なところだけコピーして持ってくるか、いっそ新しく作ってしまったほうが変な悩みがないかもしれません。

一応、実行例などを。
1つ目の例では、1から100までのリストを作り、各要素を二乗してから100未満でguardしています。
要するに100未満の平方数のリストですね。
2つ目の例では、まず頂点対のリストから有向グラフを表すMapを作り、各頂点から到達可能な頂点の集合を求めています。
これはclosureの例を示したかったからで、こういったグラフ操作では反射閉包を取る操作は便利に使うことができます。

module IntSet = Set.Make(Int)
module ISSet = Set.Make(IntSet)
module IntISMap = TypedMap.Make(Int)(IntSet)
 
(* example1 *)
let l =
  List.(
    map Int.sqr (1--100)
    >>= guard (Int.gt 100))
 
(* example2 *)
let m =
  [(1,2);(1,3);(2,4);(2,5);(4,2)]
  |> List.map (Tuple2.apply id IntSet.singleton)
  |> IntISMap.of_dup_list (IntSet.union << Option.safe_get IntSet.empty)
let is1 =
  List.(1--5 >>= 
      (IntSet.singleton >> singleton) |> ISSet.of_list)
let is2 =
  let closure =
    IntSet.closure_reflect 
      (fun x -> IntISMap.safe_find x m 
       |> Option.safe_get IntSet.empty)
  in
  let module ISMapper = Mapper(ISSet)(ISSet) in
    ISMapper.map closure is1
 
let () = Format.printf "Ex1.@.List:%a@." (List.print Int.to_string) l
let () = Format.printf "@.Ex2.@.Path:%a@." IntISMap.print m
let () = Format.printf "before:%a@." ISSet.print is1
let () = Format.printf "after:%a@." ISSet.print is2

出力は以下のようになります。
2番目の例では、5つの頂点から出発したのに対し、到達可能な頂点集合は4つになっています。
この結果を利用して、有向グラフから最小化した有向グラフを作る、なんてこともできそうです。

Ex1.
List:[1,4,9,16,25,36,49,64,81]
 
Ex2.
Path:{1->{2,3},2->{4,5},4->{2}}
before:{{1},{2},{3},{4},{5}}
after:{{1,2,3,4,5},{2,4,5},{3},{5}}

最後に、どう考えても素直にCoreやBatteriesを使ったほうがいいと思いますが、何らかの資料程度にはなるかもしれないので、展開したところに標準ライブラリ拡張のソースを置いておきます。
自分はstdlib.mlという名前で一番最初にmakeして、以降のファイルでは先頭でopen Stdlibしています。
最初はList.mlとかに小分けしていたんですが、標準ライブラリと名前が被るとリンクで失敗するんですね……知りませんでした(参考)

もし興味のある方がいれば、このまま使うなり書き換えるなり好きにお使い頂いて結構です。
WP Codeboxがうまく動いていないらしくダウンロードのためのメニューバーがないですが、原始的なコピペでひとつ……ｗ
しっかりデバッグしていないのでバグがある可能性が高いです。バグを見つけたらご一報いただけると助かります。

(*******************************
 * Standard Library Expansion  *
 *                             *
 * 2011/12/09 @Kokuyouwind     *
 * http://blog.kokuyouwind.com *
 *******************************)
 
(* Util: Change Apply Order *)
let (|>) x f = f x
let (<|) f x = f x
let (>>) f g x = g (f x)
let (<<) f g x = f (g x)
let id x = x
let apply f x = f x
let switch f x y = f y x
 
(* Util: Compare and fix *)
let eq x y = compare x y = 
let ne x y = compare x y <> 
let gt x y = compare x y > 
let lt x y = compare x y < 
let ge x y = compare x y >= 
let le x y = compare x y <= 
let equal = eq
let nequal = ne
let on cmp f x y = cmp (f x) (f y)
let rec fix equal f x =
  let x' = f x in
    if equal x x' then x
    else fix equal f x'
 
(* Util: List Utilitys *)
let cons x l = x::l
let rec (--) x y =
  if x > y then [] 
  else x::((--) (x+1) y)
 
(* Extend Standard Modules *)
(* Ordered: Ordered Type *)
module Ordered =
struct
  (* Request Type *)
  module type Type =
  sig
    type t
    val compare : t -> t -> int
  end
 
  (* Return Signature *)
  module type S =
  sig
    type t
    val eq : t -> t -> bool
    val ne : t -> t -> bool
    val gt : t -> t -> bool
    val lt : t -> t -> bool
    val ge : t -> t -> bool
    val le : t -> t -> bool
    val equal : t -> t -> bool
    val nequal : t -> t -> bool
    val fix : (t -> t) -> t -> t
  end
 
  (* Make Upgraded Structure *)
  module Make(T:Type) :
    S with type t := T.t
    =
  struct
    open T
    let eq x y = compare x y = 
    let ne x y = compare x y <> 
    let gt x y = compare x y > 
    let lt x y = compare x y < 
    let ge x y = compare x y >= 
    let le x y = compare x y <= 
    let equal = eq
    let nequal = ne
    let fix = fix equal
  end
end
 
 
(* TypeOrdered: Ordered Type with Type Variable *)
module TypedOrdered =
struct
  (* Request Type *)
  module type Type =
  sig
    type 'a t
    val compare : 'a t -> 'a t -> int
  end
 
  (* Return Signature *)
  module type S =
  sig
    type 'a t
    val eq : 'a t -> 'a t -> bool
    val ne : 'a t -> 'a t -> bool
    val gt : 'a t -> 'a t -> bool
    val lt : 'a t -> 'a t -> bool
    val ge : 'a t -> 'a t -> bool
    val le : 'a t -> 'a t -> bool
    val equal : 'a t -> 'a t -> bool
    val nequal : 'a t -> 'a t -> bool
    val fix : ('a t -> 'a t) -> 'a t -> 'a t
  end
 
  (* Make Upgraded Structure *)
  module Make(T:Type) 
    : S with type 'a t := 'a T.t
      =
  struct
    open T
    let eq x y = compare x y = 
    let ne x y = compare x y <> 
    let gt x y = compare x y > 
    let lt x y = compare x y < 
    let ge x y = compare x y >= 
    let le x y = compare x y <= 
    let equal = eq
    let nequal = ne
    let fix f = fix equal f
  end
end
 
 
(* Stringable: Type can cast to string *)
module Stringable =
struct
  module type Type =
  sig
    type t
    val to_string : t -> string
  end
 
  module type S =
  sig
    type t
    val print : Format.formatter -> t -> unit
    val to_chararray : t -> char array
    val to_charlist : t -> char list
  end
 
  module Make(T:Type)
    : S with type t := T.t
      =
  struct
    open T
    let print fmt t = Format.fprintf fmt "%s" (to_string t)
    let to_chararray t =
      let s = to_string t in
    Array.init (String.length s) (String.get s)
    let to_charlist t =
      Array.to_list (to_chararray t)
  end
end
 
module TypedStringable =
struct
  module type Type =
  sig
    type 'a t
    val to_string : 'a t -> string
  end
 
  module type S =
  sig
    type 'a t
    val print : Format.formatter -> 'a t -> unit
    val to_chararray : 'a t -> char array
    val to_charlist : 'a t -> char list
  end
 
  module Make(T:Type) 
    : S with type 'a t := 'a T.t
      =
  struct
    open T
    let print fmt t = Format.fprintf fmt "%s" (to_string t)
    let to_chararray t =
      let s = to_string t in
    Array.init (String.length s) (String.get s)
    let to_charlist t =
      Array.to_list (to_chararray t)
  end
end
 
(* OrderedStringable: Type Build by Ordered and Stringable  *)
module OrderedStringable =
struct
  module type Type =
  sig
    include Ordered.Type
    include Stringable.Type with type t := t
  end
 
  module type S =
  sig
    include Ordered.S
    include Stringable.S with type t := t
  end
 
  module Make(T:Type) 
    : S with type t := T.t
    =
  struct
    open T
    include Ordered.Make(T)
    include Stringable.Make(T)
  end
end
 
module TypedOrderedStringable =
struct
  module type Type =
  sig
    include TypedOrdered.Type
    include TypedStringable.Type with type 'a t := 'a t
  end
 
  module type S =
  sig
    include TypedOrdered.S
    include TypedStringable.S with type 'a t := 'a t
  end
 
  module Make(T:Type) 
    : S with type 'a t := 'a T.t
      =
  struct
    open T
    include TypedOrdered.Make(T)
    include TypedStringable.Make(T)
  end
end
 
 
(* Monad: Type of Monad *)
module Monad =
struct
  module type Type =
  sig
    type elt
    type t
    val empty : t
    val singleton : elt -> t
    val bind : t -> (elt -> t) -> t
  end
 
  module type S =
  sig
    type elt
    type t
    val (>>=) : t -> (elt -> t) -> t
    val (=<<) : (elt -> t) -> t -> t
    val fail : t
    val return : elt -> t
    val guard : (elt -> bool) -> elt -> t
    val sequence : t -> (elt -> t) list -> t
    val sequence_ : t -> (elt -> t) list -> unit
  end
 
  module Make(T:Type)
    : S with type elt := T.elt and type t := T.t
      =
  struct
    open T
    let (>>=) = bind
    let (=<<) f m = m >>= f
    let fail = empty
    let return = singleton
    let guard f x =
      if f x then singleton x else empty
    let rec sequence x = function
    [] -> x
      | f::t -> sequence (x >>= f) t
    let sequence_ m l = ignore (sequence m l)
  end
end
 
module TypedMonad =
struct
  module type Type =
  sig
    type 'a t
    val empty : 'a t
    val singleton : 'a -> 'a t
    val bind : 'a t -> ('a -> 'b t) -> 'b t
  end
 
  module type S =
  sig
    type 'a t
    val (>>=) : 'a t -> ('a  -> 'b t) -> 'b t
    val (=<<) : ('a -> 'b t) -> 'a t -> 'b t
    val fail : 'a t
    val return : 'a -> 'a t
    val guard : ('a -> bool) -> 'a -> 'a t
    val sequence : 'a t -> ('a -> 'a t) list -> 'a t
    val sequence_ : 'a t -> ('a -> 'a t) list -> unit
  end
 
  module Make(T:Type) 
    : S with type 'a t := 'a T.t
      =
  struct
    open T
    let (>>=) = bind
    let (=<<) f m = m >>= f
    let fail = empty
    let return = singleton
    let guard f x =
      if f x then singleton x else empty
    let rec sequence x = function
    [] -> x
      | f::t -> sequence (x >>= f) t
    let sequence_ m l = sequence m l |> ignore
  end
end
 
(* Collection: Type of Container *)
module Collection =
struct
  module type Type =
  sig
    type elt
    type t
    val elt_to_string : elt -> string
    val lparen : string
    val rparen : string
    val separator : string
    val empty : t
    val add : elt -> t -> t
    val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
  end
 
  module type S =
  sig
    type elt
    type t
    val foldi : (int -> elt -> 'a -> 'a) -> t -> 'a -> 'a
    val iteri : (int -> elt -> unit) -> t -> unit
    val of_option : elt option -> t
    val to_option : t -> elt option
    val add_option : elt option -> t -> t
    val of_list : elt list -> t
    val to_list : t -> elt list
    val add_list : elt list -> t -> t
    val to_string_sep : string -> string -> string -> t -> string
    val to_string : t -> string
    include Stringable.S with type t := t
  end
 
  module Make(T:Type) 
    : S with type elt := T.elt and type t := T.t
      =
  struct
    open T
    let foldi f =
      let i = ref (-1) in
    fold (fun e t -> i:=!i+1; f !i e t)
    let iteri f t =
      foldi (fun i e () -> f i e; ()) t ()
    let of_option = function
    None -> empty
      | Some x -> add x empty
    let to_option t =
      fold (fun x _ -> Some x) t None
    let add_option = function
    None -> id
      | Some x -> add x
    let of_list l =
      List.fold_right add l empty
    let to_list t =
      List.rev (fold (fun x l -> x::l) t [])
    let add_list l t =
      List.fold_left (switch add) t l
    let to_string_sep lparen rparen sep t =
      let adds i e s = s ^ (if i<> then sep else "")
    ^ (elt_to_string e)
      in 
      let s = foldi adds t "" in
      lparen ^ s ^ rparen
    let to_string = to_string_sep lparen rparen separator
    include Stringable.Make(
      (struct type t = T.t let to_string = to_string end
     : Stringable.Type with type t = T.t
      ))
  end
end
 
module TypedCollection =
struct
  module type Type =
  sig
    type 'a t
    val empty : 'a t
    val add : 'a -> 'a t -> 'a t
    val fold : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  end
 
  module type S =
  sig
    type 'a t
    val iter : ('a -> unit) -> 'a t -> unit
    val foldi : (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
    val iteri : (int -> 'a -> unit) -> 'a t -> unit
    val of_option : 'a option -> 'a t
    val to_option : 'a t -> 'a option
    val add_option : 'a option -> 'a t -> 'a t
    val of_list : 'a list -> 'a t
    val to_list : 'a t -> 'a list
    val add_list : 'a list -> 'a t -> 'a t
  end
 
  module Make(T:Type) 
    : S with type 'a t := 'a T.t
    =
  struct
    open T
    let iter f t =
      fold (fun e () -> f e; ()) t ()
    let foldi f =
      let i = ref (-1) in
    fold (i:=!i+1; f !i)
    let iteri f t =
      foldi (fun i e () -> f i e; ()) t ()
    let of_option = function
    None -> empty
      | Some x -> add x empty
    let to_option t =
      fold (fun x _ -> Some x) t None
    let add_option = function
    None -> id
      | Some x -> add x
    let of_list l =
      List.fold_left (switch add) empty l
    let to_list t =
      List.rev (fold (fun x l -> x::l) t [])
    let add_list l t =
      List.fold_left (switch add) t l
  end
end
 
(* TypedProjection: Projection of key -> 'a *)
module TypedProjection =
struct
  module type Type =
  sig
    type key
    type 'a t
    val key_to_string : key -> string
    val empty : 'a t
    val add : key -> 'a -> 'a t -> 'a t
    val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
    val find : key -> 'a t -> 'a
  end
 
  module type S =
  sig
    type key
    type 'a t
    val safe_find : key -> 'a t -> 'a option
    val safe_find_with : 'a -> key -> 'a t -> 'a
    val append : ('a option -> 'b -> 'a) -> key -> 'b -> 'a t -> 'a t
    val append_tuple : ('a option -> 'b -> 'a) -> (key * 'b) -> 'a t -> 'a t
    val of_list : (key * 'a) list -> 'a t
    val of_dup_list : ('a option -> 'b -> 'a) -> (key * 'b) list -> 'a t
    val to_list : 'a t -> (key * 'a) list
    val add_list : (key * 'a) list -> 'a t -> 'a t
    val append_list : ('a option -> 'b -> 'a) -> (key * 'b) list -> 'a t -> 'a t
    val key_to_list : 'a t -> key list
    val elt_to_list : 'a t -> 'a list
  end
 
  module Make(T:Type) 
    : S with type key := T.key and type 'a t := 'a T.t
    =
  struct
    open T
    let safe_find k m =
      try
    Some (find k m)
      with _ -> None
    let safe_find_with empty k m =
      try
    find k m
      with _ -> empty
    let append f k e m =
      add k (f (safe_find k m) e) m
    let append_tuple f (k,e) m =
      append f k e m
    let of_list l =
      List.fold_left (fun t (k,v) -> add k v t) empty l
    let of_dup_list f l =
      List.fold_left (fun t (k,e) -> append f k e t) empty l 
    let to_list t =
    List.rev (fold (fun k v l -> (k,v)::l) t [])
    let add_list l t =
      List.fold_left (fun t (k,v) -> add k v t) t l
    let append_list f l t =
      List.fold_left (fun t (k,e) -> append f k e t) t l
    let key_to_list m =
      List.rev (fold (fun k _ l -> k::l) m [])
    let elt_to_list m =
      List.rev (fold (fun _ v l -> v::l) m [])
  end
end
 
(* Option: Module of 'a option *)
module Option =
struct
  let to_string_sep rparen lparen f =
    function
    None -> rparen ^ lparen
      | Some x -> rparen ^ (f x) ^ lparen
  let to_string f =
    to_string_sep "{" "}" f
  let print f fmt x =
    Format.fprintf fmt "%s" (to_string f x)
  module Core =
  struct
    type 'a t = 'a option
    let compare = compare
    let empty = None
    let singleton x = Some x
    let add x _ = Some x
    let bind x f =
      match x with
      None -> None
    | Some x -> f x
    let fold f x e =
      match x with
      None -> e
    | Some x -> f x e
    let safe_get empty = function
    None -> empty
      | Some x -> x
  end
 
  module type S =
  sig
    type elt
    type t = elt option
    val elt_to_string : elt -> string
    val safe_get : elt -> t -> elt
    include Ordered.Type
      with type t := t
    include Monad.Type with type elt := elt 
               and type t := t
    include Collection.Type with type elt := elt
                and type t := t
    include Ordered.S
      with type t := t
    include Monad.S with type elt := elt
            and type t := t
    include Collection.S with type elt := elt 
             and type t := t
  end
 
  module Make(T:OrderedStringable.Type)
    : S with type elt = T.t
      =
  struct
    module Core =
    struct
      type elt = T.t
      type t = elt option
      let elt_to_string = T.to_string
      let lparen="{"
      let rparen="}"
      let separator=""
      let compare x y= 
    match (x,y) with
        (None,None) -> 
      | (Some _,None) -> 1
      | (None,Some _) -> -1
      | (Some x, Some y) ->
          compare x y
      let empty = None
      let singleton x = Some x
      let add x _ = Some x
      let bind x f =
    match x with
        None -> None
      | Some x -> f x
      let fold f x e =
    match x with
        None -> e
      | Some x -> f x e
      let safe_get empty = function
      None -> empty
    | Some x -> x
    end
    include Core
    include Ordered.Make(Core)
    include Monad.Make(Core)
    include Collection.Make(Core)
  end
  include Core
  include TypedOrdered.Make(Core)
  include TypedMonad.Make(Core)
  include TypedCollection.Make(Core)
end
 
 
(* Tuple: Module of Tuples *)
module Tuple2 =
struct
  let compare cmp1 cmp2 (x1,y1) (x2,y2) =
    if cmp1 x1 x2 <>  then
      cmp1 x1 x2
    else
      cmp2 y1 y2
  let to_string_sep lparen rparen sep f1 f2 (x,y)=
    lparen ^ (f1 x) ^ sep ^ (f2 y) ^ rparen
  let to_string f1 f2 =
    to_string_sep "(" ")" "," f1 f2
  let print f1 f2 fmt t =
    Format.fprintf fmt "%s" (to_string f1 f2 t)
  module Core =
  struct
    let fst = fst
    let snd = snd
    let apply f1 f2 (x1,x2) = (f1 x1, f2 x2)
    let apply_fst f (x,y) = (f x,y)
    let apply_snd f (x,y) = (x,f y)
    let apply_curry f (x,y) = f x y
    let build x y = (x,y)
    let rev_build y x = (x,y)
  end
 
  module Make(S1:OrderedStringable.Type)(S2:OrderedStringable.Type) =
  struct
    module Core =
    struct
      type t = S1.t * S2.t
      include Core
      let compare t1 t2 =
    compare S1.compare S2.compare t1 t2
      let to_string_sep lparen rparen sep (x,y)=
    lparen ^ (S1.to_string x) ^ sep ^ (S2.to_string y) ^ rparen
      let to_string =
    to_string_sep "(" ")" ","
    end
    include Core
    include OrderedStringable.Make(Core)
  end
 
  include Core
end
 
module Tuple3 =
struct
  let compare cmp1 cmp2 cmp3 (x1,y1,z1) (x2,y2,z2) =
    if cmp1 x1 x2 <>  then
      cmp1 x1 x2
    else if cmp2 y1 y2 <>  then
      cmp2 y1 y2
    else
      cmp3 z1 z2
  let to_string_sep lparen rparen sep f1 f2 f3 (x,y,z) =
    lparen ^ (f1 x)
    ^ sep ^ (f2 y) 
    ^ sep ^ (f3 z)
    ^ rparen
  let to_string f1 f2 f3 =
    to_string_sep "(" ")" "," f1 f2 f3
  let print f1 f2 f3 fmt t =
    Format.fprintf fmt "%s" (to_string f1 f2 f3 t)
  module Core =
  struct
    let fst (x,_,_) = x
    let snd (_,y,_) = y
    let thd (_,_,z) = z
    let apply f1 f2 f3 (x,y,z) = (f1 x, f2 y, f3 z)
    let apply_curry f (x,y,z) = f x y z
    let build x y z = (x,y,z)
    let rev_build z y x = (x,y,z)
  end
 
  module Make(S1:OrderedStringable.Type)
    (S2:OrderedStringable.Type) 
    (S3:OrderedStringable.Type)
    =
  struct
    module Core =
    struct
      type t = S1.t * S2.t * S3.t
      let compare t1 t2 =
    compare S1.compare S2.compare S3.compare t1 t2
      let fst (x,_,_) = x
      let snd (_,y,_) = y
      let thd (_,_,z) = z
      let apply f1 f2 f3 (x,y,z) = (f1 x, f2 y, f3 z)
      let to_string_sep lparen rparen sep (x,y,z) =
    lparen ^ (S1.to_string x)
    ^ sep ^ (S2.to_string y) 
    ^ sep ^ (S3.to_string z)
    ^ rparen
      let to_string =
    to_string_sep "(" ")" ","
    end
    include Core
    include OrderedStringable.Make(Core)
  end
end
 
(* Int: Module of int *)
module Int =
struct
  module Core =
  struct
    type t = int
    let compare (x:int) y = compare x y
    let abs = abs
    let sqr x = x * x
    let equal (x:int) y = (x = y)
    let add = ( + )
    let sub = ( - )
    let mul = ( * )
    let div = ( / )
    let rem = (mod) 
    let of_float = int_of_float
    let to_float = float_of_int
    let of_string = int_of_string
    let to_string = string_of_int
  end
  include Core
  include OrderedStringable.Make(Core)
end
 
(* Float: Module of float*)
module Float =
struct
  module Core =
  struct
    type t = float
    let compare (x:float) y = compare x y
    let abs x = if x < . then (-.x) else x
    let sqr x = x ** 2.
    let sqrt = sqrt
    let equal (x:float) y = (x = y)
    let aequal e x y = abs(x -. y) < e
    let add = ( +. )
    let sub = ( -. )
    let mul = ( *. )
    let div = ( /. )
    let of_int = float_of_int
    let to_int = int_of_float
    let of_string = float_of_string
    let to_string = string_of_float
  end
  include Core
  include OrderedStringable.Make(Core)
end
 
(* Char: Module of char*)
module Char =
struct
  module Core =
  struct
    include Char
    let of_int = chr
    let to_int = code
    let of_string s = String.get s 
    let to_string = escaped
  end
  include Core
  include OrderedStringable.Make(Core)
end
 
(* String: Module of string *)
module String =
struct
  module Core =
  struct
    include String
    let empty = ""
    let is_empty = (=) ""
    let singleton = Char.to_string
    let hd s = get s 
    let head = hd
    let tl s = sub s 1 (length s - 1)
    let tail = tl
    let nth = get
    let rec rev s =
      if s="" then ""
      else (rev (tl s))^(Char.escaped (hd s)) 
    let of_string (s:string) = s
    let to_string (s:string) = s
    let of_int = string_of_int
    let to_int = int_of_string
    let of_float = string_of_float
    let to_float = float_of_string
    let of_char = Char.to_string
    let to_char = Char.of_string
    let rec fold f s c =
      if s="" then c
      else
    fold f (tl s) (f (hd s) c)
  end
  include Core
  include OrderedStringable.Make(Core)
end
 
(* List: Module of 'a list and elt list *)
module List =
struct
  module Core =
  struct
    include List
    type 'a t = 'a list
    let compare = compare
    let empty = []
    let singleton x = [x]
    let cons = cons
    let add = cons
    let bind l f = flatten (map f l)
    let fold f l e =
      fold_left (switch f) e l
    let to_string_sep rparen lparen sep f =
      function
      [] -> rparen ^ lparen
    | h::t ->
        rparen ^ (f h) 
        ^ (List.fold_left (fun s x -> s ^ sep ^ (f x)) "" t)
        ^ lparen
    let to_string f = to_string_sep "[" "]" "," f
    let print pr fmt l =
      Format.fprintf fmt "%s" (to_string pr l)
  end
 
  module type S =
  sig
    include module type of List
    type elt
    type t = elt list
    val elt_to_string : elt -> string
    val cons : elt -> t -> t
    include Ordered.Type with type t := t
    include Monad.Type with type elt := elt 
               and type t := t
    include Collection.Type with type elt := elt
                and type t := t
    include Ordered.S with type t := t
    include Monad.S with type elt := elt
            and type t := t
    include Collection.S with type elt := elt 
             and type t := t
  end
 
  module Make(T:OrderedStringable.Type)
    : S with type elt = T.t
      =
  struct
    module Core =
    struct
      include List
      type elt = T.t
      type t = elt list
      let elt_to_string = T.to_string
      let lparen = "["
      let rparen = "]"
      let separator = ","
      let rec compare l1 l2 =
    match (l1,l2) with
        ([],[]) -> 
      | (_,[]) -> 1
      | ([],_) -> -1
      | (h1::_,h2::_) when T.compare h1 h2 <>  ->
          T.compare h1 h2
      | (_::t1,_::t2) ->
          compare t1 t2
      let empty = []
      let singleton x = [x]
      let cons x l = x::l
      let add = cons
      let bind l f = flatten (map f l)
    let fold f l e =
      fold_left (switch f) e l
    end
    include Core
    include Ordered.Make(Core)
    include Monad.Make(Core)
    include Collection.Make(Core)
  end
  include Core
  include TypedOrdered.Make(Core)
  include TypedMonad.Make(Core)
  include TypedCollection.Make(Core)
end
 
(* Set: Module of set *)
module Set =
struct
  module type S =
  sig
    include Set.S
    val elt_to_string : elt -> string
    val lparen : string
    val rparen : string
    val separator : string
    val bind : t -> (elt -> t) -> t
    val bind_reflect : t -> (elt -> t) -> t
    val closure : (elt -> t) -> t -> t
    val closure_reflect : (elt -> t) -> t -> t
    include Ordered.S with type t := t
    include Monad.S with type elt := elt
            and type t := t
    include Collection.S with type elt := elt 
             and type t := t
  end
 
  module Make(T:OrderedStringable.Type)
    : S with type elt = T.t
    =
  struct
    module Core =
    struct
      include Set.Make(T)
      let elt_to_string = T.to_string
      let lparen="{"
      let rparen="}"
      let separator=","
      let bind s f = fold (f >> union) s empty
      let bind_reflect s f = fold (f >> union) s s
      let closure f s =
    fix equal (fun x -> bind x f) s
      let closure_reflect f s =
    fix equal (fun x -> bind_reflect x f) s
    end
    include Core
    include Ordered.Make(Core)
    include Monad.Make(Core)
    include Collection.Make(Core)
  end
end
 
(* Map: Module of Map *)
module Map =
struct
  module type S =
  sig
    include Map.S
    val key_to_string : key -> string
    include TypedProjection.S with type key := key
                  and type 'a t := 'a t
  end
 
  module Make(T:OrderedStringable.Type)
    : S with type key = T.t
    =
  struct
    module Core =
    struct
      include Map.Make(T)
      let key_to_string = T.to_string
    end
    include Core
    include TypedProjection.Make(Core)
  end
end
 
module TypedMap =
struct
  module type S =
  sig
    type elt
    include Map.S
    val to_string_sep : string -> string -> string -> string -> elt t -> unit
    val to_string : elt t -> unit
  end
 
  module Make(K:OrderedStringable.Type)(E:OrderedStringable.Type)
    =
  struct
    type elt = E.t
    include Map.Make(K)
    let to_string_sep lparen rparen arrow sep m =
      if is_empty m then lparen ^ rparen
      else
    let (k,v) = min_binding m in
    let m = remove k m in
    let h = (K.to_string k) ^ arrow ^ (E.to_string v) in
    let s = fold (fun k v s -> s ^ sep ^ (K.to_string k)
            ^ arrow ^ (E.to_string v)) m h
    in
      lparen ^ s ^ rparen
    let to_string m =
      to_string_sep "{" "}" "->" "," m
    let print fmt m =
      Format.fprintf fmt "%s" (to_string m)
  end
end
 
(* Mapper: Fanctor of map from A.t to B.t  *)
module Mapper(S1:Collection.Type)(S2:Collection.Type) =
struct
  let map f s =
    S1.fold (f >> S2.add) s S2.empty
  let remap f s =
    S2.fold (f >> S1.add) s S1.empty
end
 
module Mapper2(S1:TypedProjection.Type)(S2:TypedProjection.Type) =
struct
  let elt_map f m =
    S1.fold (fun k -> f >> S1.add k) m S1.empty
  let elt_remap f m =
    S2.fold (fun k -> f >> S2.add k) m S2.empty
  let key_map f m =
    S1.fold (f >> S2.add) m S2.empty
  let key_remap f m =
    S2.fold (f >> S1.add) m S1.empty
  let map = key_map
  let remap = key_remap
end