Re: [Caml-list] Recursive types and functors.

[Jean-Christophe Filliatre <Jean-Christophe.Filliatre@lri.fr>]

[-- Attachment #1: message body and .signature --]
[-- Type: text/plain, Size: 3096 bytes --]


David Brown writes:
 > I have a recursive type where I'd like one of the constructors of the
 > type to contain a set of the type (or something like set).  However, I
 > can't figure out how to represent this.
 > 
 > For example:
 > 
 > type foo =
 >   | Integer of int
 >   | String of string
 >   | Set of FooSet
 > 
 > module FooSet = Set.Make (struct type t = foo let compare = compare end)
 > 
 > but this obviously doesn't work.

I'm pretty  sure this has already  been discussed on this  list, but I
couldn't find the related thread in the archives...

A (too) naive solution could be  to make a polymorphic instance of the
Set module (either  by adding an argument 'a  everywhere in signatures
OrderedType  and S,  or  by  copying the  functor  body and  replacing
Ord.compare by compare); then you have polymorphic sets, say 'a Set.t,
balanced using compare, and you can define

	type foo = Integer of int | ... | Set of foo Set.t

Unfortunately this  doesn't work because sets  themselves shouldn't be
compared with  compare, but with  Set.compare (see set.mli).  And then
you  point out  the  main  difficulty: comparing  values  in type  foo
requires  to  be able  to  compare sets  of  foo,  and comparing  sets
requires to *implement* sets and thus to compare values in foo.

Fortunately, there  is another solution  (though a bit  more complex).
First  we  define  a  more  generic  type 'a  foo  where  'a  will  be
substituted later by sets of foo:

	type 'a foo = Integer of int | ... | Set of 'a

Then we implement a variant  of module Set which implements sets given
the following signature:

	module type OrderedType =
	sig
	  type 'a t
	  val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
	end

that is where elements are in  the polymorphic type 'a t and where the
comparison function depends on  a comparison function for arguments in
'a (which will represent the  sets, in fine). The functor implements a
type t for  sets using balanced trees, as usual,  and defines the type
of elements elt to be t Ord.t:

	module Make(Ord: OrderedType) =
	  struct
	    type elt = t Ord.t
	    and t = Empty | Node of t * elt * t * int

Right  after, it  implements comparison  over elements  and sets  in a
mutually recursive way:

	let rec compare_elt x y = 
	  Ord.compare compare x y

	and compare = ... (usual comparison of sets, using compare_elt)

The remaining  of the  functor is  exactly the same  as for  Set, with
compare_elt used  instead of Ord.compare. I  attach the implementation
of this module.

There  is (at  least) another  solution: to  use a  set implementation
where comparison  does not require  a comparison of elements.  This is
possible if, for instance, you are performing hash-consing on type foo
(which result  in tagging foo values  with integers, then  used in the
comparison). This  solution is used in Claude  Marché's regexp library
(http://www.lri.fr/~marche/regexp/) and  uses a hash-consing technique
available here: http://www.lri.fr/~filliatr/software.en.html

Hope this helps,
-- 
Jean-Christophe Filliâtre (http://www.lri.fr/~filliatr)


[-- Attachment #2: mset.mli --]
[-- Type: application/octet-stream, Size: 5082 bytes --]

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            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 Library General Public License.         *)
(*                                                                     *)
(***********************************************************************)

(* $Id: pset.mli,v 1.2 2002/02/22 15:54:43 filliatr Exp $ *)

(* Module [Mset]: variant of module [Set] to build a type and sets of
   elements in this type in a mutually recursive way. *)

module type OrderedType =
  sig
    type 'a t
    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
  end
          (* The input signature of the functor [Mset.Make].
             ['a t] is the type of the set elements where ['a] will be 
	     substituted by the type for sets of such elements.
             [compare] is a total ordering function over the set elements,
	     given a total ordering function over sets. *)


module Make(Ord: OrderedType):
        (* Functor building an implementation of the set structure *)
  sig
    type t
          (* The type of sets. *)
    type elt = t Ord.t
          (* The type of the set elements. *)
    val empty: t
          (* The empty set. *)
    val is_empty: t -> bool
        (* Test whether a set is empty or not. *)
    val mem: elt -> t -> bool
        (* [mem x s] tests whether [x] belongs to the set [s]. *)
    val add: elt -> t -> t
        (* [add x s] returns a set containing all elements of [s],
           plus [x]. If [x] was already in [s], [s] is returned unchanged. *)
    val singleton: elt -> t
        (* [singleton x] returns the one-element set containing only [x]. *)
    val remove: elt -> t -> t
        (* [remove x s] returns a set containing all elements of [s],
           except [x]. If [x] was not in [s], [s] is returned unchanged. *)
    val union: t -> t -> t
    val inter: t -> t -> t
    val diff: t -> t -> t
        (* Union, intersection and set difference. *)
    val compare_elt: elt -> elt -> int
	(* Total ordering between elements. *)
    val compare: t -> t -> int
        (* Total ordering between sets. Can be used as the ordering function
           for doing sets of sets. *)
    val equal: t -> t -> bool
        (* [equal s1 s2] tests whether the sets [s1] and [s2] are
           equal, that is, contain equal elements. *)
    val subset: t -> t -> bool
        (* [subset s1 s2] tests whether the set [s1] is a subset of
           the set [s2]. *)
    val iter: (elt -> unit) -> t -> unit
        (* [iter f s] applies [f] in turn to all elements of [s].
           The order in which the elements of [s] are presented to [f]
           is unspecified. *)
    val fold: (elt -> 'b -> 'b) -> t -> 'b -> 'b
        (* [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)],
           where [x1 ... xN] are the elements of [s].
           The order in which elements of [s] are presented to [f] is
           unspecified. *)
    val for_all: (elt -> bool) -> t -> bool
        (* [for_all p s] checks if all elements of the set
           satisfy the predicate [p]. *)
    val exists: (elt -> bool) -> t -> bool
        (* [exists p s] checks if at least one element of
           the set satisfies the predicate [p]. *)
    val filter: (elt -> bool) -> t -> t
        (* [filter p s] returns the set of all elements in [s]
           that satisfy predicate [p]. *)
    val partition: (elt -> bool) -> t -> t * t
        (* [partition p s] returns a pair of sets [(s1, s2)], where
           [s1] is the set of all the elements of [s] that satisfy the
           predicate [p], and [s2] is the set of all the elements of
           [s] that do not satisfy [p]. *)
    val cardinal: t -> int
        (* Return the number of elements of a set. *)
    val elements: t -> elt list
        (* Return the list of all elements of the given set.
           The returned list is sorted in increasing order with respect
           to the ordering [Ord.compare], where [Ord] is the argument
           given to [Set.Make]. *)
    val min_elt: t -> elt
        (* Return the smallest element of the given set
           (with respect to the [Ord.compare] ordering), or raise
           [Not_found] if the set is empty. *)
    val max_elt: t -> elt
        (* Same as [min_elt], but returns the largest element of the
           given set. *)
    val choose: t -> elt
        (* Return one element of the given set, or raise [Not_found] if
           the set is empty. Which element is chosen is unspecified,
           but equal elements will be chosen for equal sets. *)
  end


[-- Attachment #3: mset.ml --]
[-- Type: application/octet-stream, Size: 9891 bytes --]

(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            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 Library General Public License.         *)
(*                                                                     *)
(***********************************************************************)

(* $Id: pset.ml,v 1.1 2000/07/07 16:13:17 filliatr Exp $ *)

(* Sets over ordered types *)

module type OrderedType =
  sig
    type 'a t
    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
  end

module type S =
  sig
    type elt
    type t
    val empty: t
    val is_empty: t -> bool
    val mem: elt -> t -> bool
    val add: elt -> t -> t
    val singleton: elt -> t
    val remove: elt -> t -> t
    val union: t -> t -> t
    val inter: t -> t -> t
    val diff: t -> t -> t
    val compare_elt : elt -> elt -> int
    val compare: t -> t -> int
    val equal: t -> t -> bool
    val subset: t -> t -> bool
    val iter: (elt -> unit) -> t -> unit
    val fold: (elt -> 'b -> 'b) -> t -> 'b -> 'b
    val for_all: (elt -> bool) -> t -> bool
    val exists: (elt -> bool) -> t -> bool
    val filter: (elt -> bool) -> t -> t
    val partition: (elt -> bool) -> t -> t * t
    val cardinal: t -> int
    val elements: t -> elt list
    val min_elt: t -> elt
    val max_elt: t -> elt
    val choose: t -> elt
  end

module Make(Ord: OrderedType) =
  struct
    type elt = t Ord.t
    and t = Empty | Node of t * elt * t * int

    let rec compare_elt x y = 
      Ord.compare compare x y

    and compare_aux l1 l2 =
        match (l1, l2) with
        ([], []) -> 0
      | ([], _)  -> -1
      | (_, []) -> 1
      | (Empty :: t1, Empty :: t2) ->
          compare_aux t1 t2
      | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) ->
          let c = compare_elt v1 v2 in
          if c <> 0 then c else compare_aux (r1::t1) (r2::t2)
      | (Node(l1, v1, r1, _) :: t1, t2) ->
          compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2
      | (t1, Node(l2, v2, r2, _) :: t2) ->
          compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2)

    and compare s1 s2 =
      compare_aux [s1] [s2]

    (* Sets are represented by balanced binary trees (the heights of the
       children differ by at most 2 *)

    let height = function
        Empty -> 0
      | Node(_, _, _, h) -> h

    (* Creates a new node with left son l, value x and right son r.
       l and r must be balanced and | height l - height r | <= 2.
       Inline expansion of height for better speed. *)

    let create l x r =
      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
      Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))

    (* Same as create, but performs one step of rebalancing if necessary.
       Assumes l and r balanced.
       Inline expansion of create for better speed in the most frequent case
       where no rebalancing is required. *)

    let bal l x r =
      let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in
      let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in
      if hl > hr + 2 then begin
        match l with
          Empty -> invalid_arg "Set.bal"
        | Node(ll, lv, lr, _) ->
            if height ll >= height lr then
              create ll lv (create lr x r)
            else begin
              match lr with
                Empty -> invalid_arg "Set.bal"
              | Node(lrl, lrv, lrr, _)->
                  create (create ll lv lrl) lrv (create lrr x r)
            end
      end else if hr > hl + 2 then begin
        match r with
          Empty -> invalid_arg "Set.bal"
        | Node(rl, rv, rr, _) ->
            if height rr >= height rl then
              create (create l x rl) rv rr
            else begin
              match rl with
                Empty -> invalid_arg "Set.bal"
              | Node(rll, rlv, rlr, _) ->
                  create (create l x rll) rlv (create rlr rv rr)
            end
      end else
        Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1))

    (* Same as bal, but repeat rebalancing until the final result
       is balanced. *)

    let rec join l x r =
      match bal l x r with
        Empty -> invalid_arg "Set.join"
      | Node(l', x', r', _) as t' ->
          let d = height l' - height r' in
          if d < -2 or d > 2 then join l' x' r' else t'

    (* Merge two trees l and r into one.
       All elements of l must precede the elements of r.
       Assumes | height l - height r | <= 2. *)

    let rec merge t1 t2 =
      match (t1, t2) with
        (Empty, t) -> t
      | (t, Empty) -> t
      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
          bal l1 v1 (bal (merge r1 l2) v2 r2)

    (* Same as merge, but does not assume anything about l and r. *)

    let rec concat t1 t2 =
      match (t1, t2) with
        (Empty, t) -> t
      | (t, Empty) -> t
      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
          join l1 v1 (join (concat r1 l2) v2 r2)

    (* Splitting *)

    let rec split x = function
        Empty ->
          (Empty, None, Empty)
      | Node(l, v, r, _) ->
          let c = compare_elt x v in
          if c = 0 then (l, Some v, r)
          else if c < 0 then
            let (ll, vl, rl) = split x l in (ll, vl, join rl v r)
          else
            let (lr, vr, rr) = split x r in (join l v lr, vr, rr)

    (* Implementation of the set operations *)

    let empty = Empty

    let is_empty = function Empty -> true | _ -> false

    let rec mem x = function
        Empty -> false
      | Node(l, v, r, _) ->
          let c = compare_elt x v in
          c = 0 || mem x (if c < 0 then l else r)

    let rec add x = function
        Empty -> Node(Empty, x, Empty, 1)
      | Node(l, v, r, _) as t ->
          let c = compare_elt x v in
          if c = 0 then t else
          if c < 0 then bal (add x l) v r else bal l v (add x r)

    let singleton x = Node(Empty, x, Empty, 1)

    let rec remove x = function
        Empty -> Empty
      | Node(l, v, r, _) ->
          let c = compare_elt x v in
          if c = 0 then merge l r else
          if c < 0 then bal (remove x l) v r else bal l v (remove x r)

    let rec union s1 s2 =
      match (s1, s2) with
        (Empty, t2) -> t2
      | (t1, Empty) -> t1
      | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) ->
          if h1 >= h2 then
            if h2 = 1 then add v2 s1 else begin
              let (l2, _, r2) = split v1 s2 in
              join (union l1 l2) v1 (union r1 r2)
            end
          else
            if h1 = 1 then add v1 s2 else begin
              let (l1, _, r1) = split v2 s1 in
              join (union l1 l2) v2 (union r1 r2)
            end

    let rec inter s1 s2 =
      match (s1, s2) with
        (Empty, t2) -> Empty
      | (t1, Empty) -> Empty
      | (Node(l1, v1, r1, _), t2) ->
          match split v1 t2 with
            (l2, None, r2) ->
              concat (inter l1 l2) (inter r1 r2)
          | (l2, Some _, r2) ->
              join (inter l1 l2) v1 (inter r1 r2)

    let rec diff s1 s2 =
      match (s1, s2) with
        (Empty, t2) -> Empty
      | (t1, Empty) -> t1
      | (Node(l1, v1, r1, _), t2) ->
          match split v1 t2 with
            (l2, None, r2) ->
              join (diff l1 l2) v1 (diff r1 r2)
          | (l2, Some _, r2) ->
              concat (diff l1 l2) (diff r1 r2)

    let equal s1 s2 =
      compare s1 s2 = 0

    let rec subset s1 s2 =
      match (s1, s2) with
        Empty, _ ->
          true
      | _, Empty ->
          false
      | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) ->
          let c = compare_elt v1 v2 in
          if c = 0 then
            subset l1 l2 && subset r1 r2
          else if c < 0 then
            subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2
          else
            subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2

    let rec iter f = function
        Empty -> ()
      | Node(l, v, r, _) -> iter f l; f v; iter f r

    let rec fold f s accu =
      match s with
        Empty -> accu
      | Node(l, v, r, _) -> fold f l (f v (fold f r accu))

    let rec for_all p = function
        Empty -> true
      | Node(l, v, r, _) -> p v && for_all p l && for_all p r

    let rec exists p = function
        Empty -> false
      | Node(l, v, r, _) -> p v || exists p l || exists p r

    let filter p s =
      let rec filt accu = function
        | Empty -> accu
        | Node(l, v, r, _) ->
            filt (filt (if p v then add v accu else accu) l) r in
      filt Empty s

    let partition p s =
      let rec part (t, f as accu) = function
        | Empty -> accu
        | Node(l, v, r, _) ->
            part (part (if p v then (add v t, f) else (t, add v f)) l) r in
      part (Empty, Empty) s

    let rec cardinal = function
        Empty -> 0
      | Node(l, v, r, _) -> cardinal l + 1 + cardinal r

    let rec elements_aux accu = function
        Empty -> accu
      | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l

    let elements s =
      elements_aux [] s

    let rec min_elt = function
        Empty -> raise Not_found
      | Node(Empty, v, r, _) -> v
      | Node(l, v, r, _) -> min_elt l

    let rec max_elt = function
        Empty -> raise Not_found
      | Node(l, v, Empty, _) -> v
      | Node(l, v, r, _) -> max_elt r

    let choose = min_elt

  end