From mboxrd@z Thu Jan  1 00:00:00 1970
Return-Path: weis
Received: (from weis@localhost) by pauillac.inria.fr (8.7.6/8.7.3) id OAA05487 for caml-redistribution; Wed, 27 Aug 1997 14:50:50 +0200 (MET DST)
Received: from concorde.inria.fr (concorde.inria.fr [192.93.2.39]) by pauillac.inria.fr (8.7.6/8.7.3) with ESMTP id LAA02621 for <caml-list@pauillac.inria.fr>; Wed, 27 Aug 1997 11:52:11 +0200 (MET DST)
Received: from margaux.inria.fr (margaux.inria.fr [128.93.8.2])
	by concorde.inria.fr (8.8.7/8.8.5) with ESMTP id LAA04105
	for <caml-list@pauillac.inria.fr>; Wed, 27 Aug 1997 11:52:11 +0200 (MET DST)
Received: from concorde.inria.fr (concorde.inria.fr [192.93.2.39]) by margaux.inria.fr (8.7.6/8.7.3) with ESMTP id LAA02429 for <caml-list@margaux.inria.fr>; Wed, 27 Aug 1997 11:52:10 +0200 (MET DST)
Received: from shiva.jussieu.fr (shiva.jussieu.fr [134.157.0.129])
	by concorde.inria.fr (8.8.7/8.8.5) with ESMTP id LAA04101
	for <caml-list@margaux.inria.fr>; Wed, 27 Aug 1997 11:52:09 +0200 (MET DST)
Received: from boole.logique.jussieu.fr (boole.logique.jussieu.fr [134.157.19.17])
          by shiva.jussieu.fr (8.8.6/jtpda-5.2) with ESMTP id LAA00637
          for <caml-list@margaux.inria.fr>; Wed, 27 Aug 1997 11:52:06 +0200 (METDST)
Received: by boole.logique.jussieu.fr
   (8.8.5/jtpda-4.0); Wed, 27 Aug 1997 11:55:22 +0200 (MET DST)
Date: Wed, 27 Aug 1997 11:55:22 +0200 (MET DST)
Message-Id: <199708270955.LAA05515@boole.logique.jussieu.fr>
From: Christophe Raffalli <raffalli@logique.jussieu.fr>
To: caml-list@margaux.inria.fr
Subject: More complete Map library for OCaml
Sender: weis



Version Anglaise:

I needed an implementation of multisets, and I found that they were
missing functions in the Map module to implement multisets of elements of
X as a map from X to integers. The needed functions can be programmed
using Map.fold but you loose the performance of the well balanced tree
representation ! The modified map.ml and map.mli follows and the
multiset example too.

The extra functions are Map.union, Map.inter, Map.diff, Map.compare
and Map.equal.  But to give a meaning to these functions, you
need an extra argument to decide what to do when a binding is present
in both maps. You can look at the file map.mli for more details.
 
I also added the useful Map.map function. 

- ---

French version:

J'ai eu besoin d'une implantation des multi-ensembles et je me suis
apercu que certaines fonctions manquaient dans la librairie Map pour
implanter un multi-ensemble d'elements de X comme une "map" de X dans
les entiers. Les fonctions necessaires peuvent etre ecrites a l'aide de
Map.fold mais on perd la performance de la represeantion en arbre bien
balancee. Les fichiers modifies map.ml et map.mli suivent ainsi que
l'exemple des multi-ensembles.
 
Les fonctions suplementaires sont Map.union, Map.inter, Map.diff, Map.compare
et Map.equal.  Mais pour donner un sens a ces fonctions, il faut ajouter un
argument suplementaire pour decider quoi faire lorsque la meme liaison est
presente dans les deux Maps. Pour plus de details, voir le fichier map.mli.

J'ai aussi ajouter une fonction Map.map.

- ----
Christophe Raffalli
Universite Paris XII

URL: http://www.logique.jussieu.fr/www.raffalli


Here are the files:
Voici les fichiers:

- ----8<---- map.mli ----8<----
(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* $Id: map.mli,v 1.7 1996/04/30 14:50:17 xleroy Exp $ *)

(* Module [Map]: association tables over ordered types *)

(* extended by C. Raffalli *)

(* This module implements applicative association tables, also known as
   finite maps or dictionaries, given a total ordering function
   over the keys.
   All operations over maps are purely applicative (no side-effects).
   The implementation uses balanced binary trees, and therefore searching
   and insertion take time logarithmic in the size of the map. *)

module type OrderedType =
  sig
    type t
    val compare: t -> t -> int
  end
          (* The input signature of the functor [Map.Make].
             [t] is the type of the map keys.
             [compare] is a total ordering function over the keys.
             This is a two-argument function [f] such that
             [f e1 e2] is zero if the keys [e1] and [e2] are equal,
             [f e1 e2] is strictly negative if [e1] is smaller than [e2],
             and [f e1 e2] is strictly positive if [e1] is greater than [e2].
             Examples: a suitable ordering function for type [int]
             is [(-)]. You can also use the generic structural comparison
             function [compare]. *)

module type S =
  sig
    type key
          (* The type of the map keys. *)
    type 'a t
          (* The type of maps from type [key] to type ['a]. *)
    val empty: 'a t
          (* The empty map. *)
    val is_empty: 'a t -> bool
        (* Test whether a map is empty or not. *)
    val add: key -> 'a -> 'a t -> 'a t
        (* [add x y m] returns a map containing the same bindings as
           [m], plus a binding of [x] to [y]. If [x] was already bound
           in [m], its previous binding disappears. *)
    val find: key -> 'a t -> 'a
        (* [find x m] returns the current binding of [x] in [m],
           or raises [Not_found] if no such binding exists. *)
    val remove: key -> 'a t -> 'a t
        (* [remove x m] returns a map containing the same bindings as
           [m], except for [x] which is unbound in the returned map. *)
    val update: key -> ('a -> 'a) -> (unit -> 'a) -> 'a t -> 'a t
        (* [update x fn gn m] returns a map containing the same bindings as
           [m], except for [x]. If [x] was bound to [d] then it is bound to
           [fn d] in the returned map. If [x] was unbound, it is bound to
           [gn ()] in the returned map. *)   
    val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
        (* [union m m']. If [x] is bound to [d] in [m] and [d'] in [m'] then
           it is bound to [fn d d'] in the returned map. Otherwise, if [x] 
           is bound to [d] in [m] or [m'] then it is bound to [d] in 
           the returned map. No other bindings are created *)   
    val inter: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
        (* [inter m m']. If [x] is bound to [d] in [m] and [d'] in [m'] then
           it is bound to [fn d d'] in the returned map. No other bindings 
           are created *)   
    val diff:  ('a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
        (* [inter m m']. If [x] is bound to [d] in [m] and [d'] in [m'] then
           if [fn d d' = Some d''] then [x] is bound to [d''] in the returned
           map. Otherwise, if [x] is bound to [d] in [m] and unbound in [m']
           then [x] is bound to [d] in the returned map.  No other bindings 
           are created *)   
    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
        (* Total ordering between sets. Can be used as the ordering function
           for doing sets of sets. The first argument must be a total ordering 
           on 'a *)
    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
        (* [equal fn m1 m2] tests whether the maps [m1] and [m2] are
           equal, that is, contain the same bindings. [fn] is used to
           compare the value in the maps. *)
    val map: (key -> 'a -> 'b) -> 'a t -> 'b t
        (* [map f m] applies [f] to all bindings in map [m],
	   and return the corresponding map: if [x] is bound to [d] in [m] 
           then [x] is bound to [f x d] in the resulting map. *)
    val iter: (key -> 'a -> 'b) -> 'a t -> unit
        (* [iter f m] applies [f] to all bindings in map [m],
	   discarding the results.
           [f] receives the key as first argument, and the associated value
           as second argument. The order in which the bindings are passed to
           [f] is unspecified. Only current bindings are presented to [f]:
           bindings hidden by more recent bindings are not passed to [f]. *)
    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
        (* [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)],
           where [k1 ... kN] are the keys of all bindings in [m],
           and [d1 ... dN] are the associated data.
           The order in which the bindings are presented to [f] is
           not specified. *)
  end

module Make(Ord: OrderedType): (S with type key = Ord.t)
        (* Functor building an implementation of the map structure
           given a totally ordered type. *)
- ----8<-----------------8<----



- ----8<---- map.ml  ----8<----
(***********************************************************************)
(*                                                                     *)
(*                           Objective Caml                            *)
(*                                                                     *)
(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
(*                                                                     *)
(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
(*  Automatique.  Distributed only by permission.                      *)
(*                                                                     *)
(***********************************************************************)

(* extended by C. Raffalli *)

(* $Id: map.ml,v 1.5 1996/04/30 14:50:17 xleroy Exp $ *)

module type OrderedType =
  sig
    type t
    val compare: t -> t -> int
  end

module type S =
  sig
    type key
    type 'a t
    val empty: 'a t
    val is_empty: 'a t -> bool
    val add: key -> 'a -> 'a t -> 'a t
    val find: key -> 'a t -> 'a
    val remove: key -> 'a t -> 'a t
    val update: key -> ('a -> 'a) -> (unit -> 'a) -> 'a t -> 'a t
    val union: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
    val inter: ('a -> 'a -> 'a) -> 'a t -> 'a t -> 'a t
    val diff:  ('a -> 'a -> 'a option) -> 'a t -> 'a t -> 'a t
    val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int
    val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
    val map: (key -> 'a -> 'b) -> 'a t -> 'b t
    val iter: (key -> 'a -> 'b) -> 'a t -> unit
    val fold: (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
  end

module Make(Ord: OrderedType) = struct

    type key = Ord.t

    type 'a t =
        Empty
      | Node of 'a t * key * 'a * 'a t * int

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

    let create l x d r =
      let hl = height l and hr = height r in
      Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1))

    let bal l x d 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, ld, lr, _) ->
            if height ll >= height lr then
              create ll lv ld (create lr x d r)
            else begin
              match lr with
                Empty -> invalid_arg "Set.bal"
              | Node(lrl, lrv, lrd, lrr, _)->
                  create (create ll lv ld lrl) lrv lrd (create lrr x d r)
            end
      end else if hr > hl + 2 then begin
        match r with
          Empty -> invalid_arg "Set.bal"
        | Node(rl, rv, rd, rr, _) ->
            if height rr >= height rl then
              create (create l x d rl) rv rd rr
            else begin
              match rl with
                Empty -> invalid_arg "Set.bal"
              | Node(rll, rlv, rld, rlr, _) ->
                  create (create l x d rll) rlv rld (create rlr rv rd rr)
            end
      end else
        Node(l, x, d, 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 d r =
      match bal l x d r with
        Empty -> invalid_arg "Set.join"
      | Node(l', x', d', r', _) as t' ->
          let diff = height l' - height r' in
          if diff < -2 or diff > 2 then join l' x' d' 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, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
          bal l1 v1 d1 (bal (merge r1 l2) v2 d2 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, d1, r1, h1), Node(l2, v2, d2, r2, h2)) ->
          join l1 v1 d1 (join (concat r1 l2) v2 d2 r2)

    (* Splitting *)

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

    (* Implementation of the set operations *)

    let empty = Empty

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

    let rec add x data = function
        Empty ->
          Node(Empty, x, data, Empty, 1)
      | Node(l, v, d, r, h) as t ->
          let c = Ord.compare x v in
          if c = 0 then
            Node(l, x, data, r, h)
          else if c < 0 then
            bal (add x data l) v d r
          else
            bal l v d (add x data r)

    let rec find x = function
        Empty ->
          raise Not_found
      | Node(l, v, d, r, _) ->
          let c = Ord.compare x v in
          if c = 0 then d
          else find x (if c < 0 then l else r)

    let rec remove x = function
        Empty ->
          Empty
      | Node(l, v, d, r, h) as t ->
          let c = Ord.compare x v in
          if c = 0 then
            merge l r
          else if c < 0 then
            bal (remove x l) v d r
          else
            bal l v d (remove x r)

    let rec update x fn gn = function
        Empty ->
          Node(Empty, x, gn (), Empty, 1)
      | Node(l, v, d, r, h) as t ->
          let c = Ord.compare x v in
          if c = 0 then
            Node(l, x, fn d, r, h)
          else if c < 0 then
            bal (update x fn gn l) v d r
          else
            bal l v d (update x fn gn r)

    let rec union fn s1 s2 =
      match (s1, s2) with
        (Empty, t2) -> t2
      | (t1, Empty) -> t1
      | (Node(l1, v1, d1, r1, _), t2) ->
          let (l2, q, r2) = split v1 t2 in
          let d1'' = match q with
            None -> d1
          | Some(_,d1') -> fn d1 d1' in
          join (union fn l1 l2) v1 d1'' (union fn r1 r2)

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

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

    let rec compare_aux fn l1 l2 =
        match (l1, l2) with
        ([], []) -> 0
      | ([], _)  -> -1
      | (_, []) -> 1
      | (Empty :: t1, Empty :: t2) ->
          compare_aux fn t1 t2
      | (Node(Empty, v1, d1, r1, _) :: t1, Node(Empty, v2, d2, r2, _) :: t2) ->
          let c = Ord.compare v1 v2 in
          if c <> 0 then c else 
          let c = fn d1 d2 in
          if c <> 0 then c else compare_aux fn (r1::t1) (r2::t2)
      | (Node(l1, v1, d1, r1, _) :: t1, t2) ->
          compare_aux fn (l1 :: Node(Empty, v1, d1, r1, 0) :: t1) t2
      | (t1, Node(l2, v2, d2, r2, _) :: t2) ->
          compare_aux fn t1 (l2 :: Node(Empty, v2, d2, r2, 0) :: t2)

    let compare fn s1 s2 =
      compare_aux fn [s1] [s2]

    let equal fn s1 s2 =
      let fn' x y = if fn x y then 0 else 1 in 
      compare fn' s1 s2 = 0

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

    let rec map f = function
        Empty -> Empty
      | Node(l, v, d, r, h) ->
          Node (map f l, v, f v d, map f r, h)

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

end
- ----8<-----------------8<----



- ----8<---- multiset.ml ----8<----
(* Multisets over ordered types *)

module type OrderedType =
  sig
    type t
    val compare: t -> 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 count: elt -> t -> int
    val add: elt -> t -> t
    val multiple_add: elt -> int -> t -> t
    val remove: elt -> t -> t
    val union: t -> t -> t
    val inter: t -> t -> t
    val diff: t -> t -> t
    val compare: t -> t -> int
    val equal: t -> t -> bool
    val iter: (elt -> int -> 'a) -> t -> unit
    val fold: (elt -> int -> 'a -> 'a) -> t -> 'a -> 'a
    val cardinal: t -> int
  end

module Make(Ord: OrderedType) =
  struct
    type elt = Ord.t

    module M = Map.Make (Ord)

    type t = int M.t

    let empty = M.empty

    let is_empty = M.is_empty

    let count x s = try M.find x s with Not_found -> 0

    let mem x s = count x s > 0

    let add x s = M.update x (fun n -> n+1) (fun () -> 1) s

    let multiple_add x n s = M.update x (fun n' -> n+n') (fun () -> n) s

    let remove x s = 
      try 
        M.update x (fun n -> if n = 1 then raise Exit else n-1) 
                   (fun () -> raise Not_found) s
      with 
        Exit -> M.remove x s

    let union = M.union (+)

    let inter = M.inter (min : int -> int -> int)

    let diff = M.diff (fun n n' -> let r = n - n' in
                        if r <= 0 then None else Some r)

    let compare = M.compare (-)

    let equal = M.equal ((=) : int -> int -> bool)

    let iter = M.iter

    let fold = M.fold

    let cardinal s = fold (fun _ n n' -> n + n') s 0

  end
- ----8<-----------------8<----

- --PAA11081.872600455/concorde.inria.fr--
------- End of forwarded message -------


- ----
Christophe Raffalli
Universite Paris XII

URL: http://www.logique.jussieu.fr/www.raffalli