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