1(* ========================================================================= *)
2(* A MULTISET DATATYPE FOR ML                                                *)
3(* Copyright (c) 2002-2004 Joe Hurd.                                         *)
4(* ========================================================================= *)
5
6(*
7List.app load ["Binarymap", "mlibUseful"];
8*)
9
10(*
11*)
12structure mlibMultiset :> mlibMultiset =
13struct
14
15structure M = Binarymap; local open Binarymap in end;
16
17fun Mpurge m k = let val (m,_) = M.remove (m,k) in m end;
18
19fun Mall p =
20  let
21    exception Cut
22    fun f (x,y,()) = if p (x,y) then () else raise Cut
23  in
24    fn a => (M.foldl f () a; true) handle Cut => false
25  end;
26
27type 'a mset = ('a,int) M.dict;
28
29fun empty ord : 'a mset = M.mkDict ord;
30
31fun insert (_,0) a = a
32  | insert (x,n) a =
33  (case M.peek (a,x) of NONE => M.insert (a,x,n)
34   | SOME n' =>
35   let val n'' = n + n'
36   in if n'' = 0 then Mpurge a x else M.insert (a,x,n'')
37   end);
38
39fun count m x = case M.peek (m,x) of SOME n => n | NONE => 0;
40
41local fun un a b = M.foldl (fn (x : 'a,n : int,d) => insert (x,n) d) a b;
42in fun union a b = if M.numItems a < M.numItems b then un b a else un a b;
43end;
44
45fun compl a : 'a mset = M.transform ~ a;
46
47fun subtract a b = if M.numItems b = 0 then a else union a (compl b);
48
49fun sign a =
50  case (Mall (fn (_,n) => 0 <= n) a, Mall (fn (_,n) => n <= 0) a) of
51    (true,true) => SOME EQUAL
52  | (true,false) => SOME GREATER
53  | (false,true) => SOME LESS
54  | (false,false) => NONE;
55
56fun compare (a,b) = sign (subtract a b);
57
58fun subset a b =
59  (case compare (a,b) of SOME LESS => true
60   | SOME EQUAL => true
61   | _ => false);
62
63fun equal a b = (case compare (a,b) of SOME EQUAL => true | _ => false);
64
65fun app f (a : 'a mset) = M.app f a;
66
67fun foldl f x (a : 'a mset) = M.foldl f x a;
68
69fun foldr f x (a : 'a mset) = M.foldr f x a;
70
71(* "Unguarded type variables at the top level"
72   prevents this function being implemented :-(
73local
74  exception foundit of 'a;
75in
76  fun find p m =
77    (M.app (fn x => if p x then raise foundit x else ()) m; NONE)
78    handle foundit x => SOME x;
79end;
80*)
81
82local
83  exception existing;
84in
85  fun exists p m =
86    (M.app (fn x => if p x then raise existing else ()) m; false)
87    handle existing => true;
88end;
89
90fun all p m = not (exists (not o p) m);
91
92fun nonzero (a : 'a mset) = M.numItems a;
93
94fun to_list (a : 'a mset) = M.listItems a;
95
96local
97  open mlibUseful;
98in
99  fun pp_mset pp_a =
100    pp_map (map mlibUseful.|-> o to_list)
101    (pp_bracket "M[" "]" (pp_sequence "," (mlibUseful.pp_maplet pp_a pp_int)));
102end;
103
104val map = M.map;
105
106end
107