TFL/utils.sml
changeset 3245 241838c01caf
parent 3191 14bd6e5985f1
child 3302 404fe31fd8d2
equal deleted inserted replaced
3244:71b760618f30 3245:241838c01caf
     1 (*---------------------------------------------------------------------------
     1 (*---------------------------------------------------------------------------
     2  * Some common utilities. This strucuture is parameterized over
     2  * Some common utilities.
     3  * "int_to_string" because there is a difference between the string 
       
     4  * operations of SML/NJ versions 93 and 109.
       
     5  *---------------------------------------------------------------------------*)
     3  *---------------------------------------------------------------------------*)
     6 
     4 
     7 functor UTILS (val int_to_string : int -> string) :Utils_sig = 
     5 
       
     6 structure Utils = 
     8 struct
     7 struct
     9 
     8 
    10 (* Standard exception for TFL. *)
     9 (* Standard exception for TFL. *)
    11 exception ERR of {module:string,func:string, mesg:string};
    10 exception ERR of {module:string,func:string, mesg:string};
    12 fun UTILS_ERR{func,mesg} = ERR{module = "Utils",func=func,mesg=mesg};
    11 fun UTILS_ERR{func,mesg} = ERR{module = "Utils",func=func,mesg=mesg};
    17 in
    16 in
    18 val ERR_string = info_string "Exception raised"
    17 val ERR_string = info_string "Exception raised"
    19 val MESG_string = info_string "Message"
    18 val MESG_string = info_string "Message"
    20 end;
    19 end;
    21 
    20 
    22 fun Raise (e as ERR sss) = (output(std_out, ERR_string sss);  raise e)
    21 fun Raise (e as ERR sss) = (TextIO.output(TextIO.stdOut, ERR_string sss);  
       
    22                             raise e)
    23   | Raise e = raise e;
    23   | Raise e = raise e;
    24 
       
    25 
       
    26 (* option type *)
       
    27 datatype 'a option = SOME of 'a | NONE
       
    28 
    24 
    29 
    25 
    30 (* Simple combinators *)
    26 (* Simple combinators *)
    31 
    27 
    32 infix 3 ##
       
    33 fun f ## g = (fn (x,y) => (f x, g y))
       
    34 
       
    35 fun W f x = f x x
       
    36 fun C f x y = f y x
    28 fun C f x y = f y x
    37 fun I x = x
       
    38 
       
    39 fun curry f x y = f(x,y)
       
    40 fun uncurry f (x,y) = f x y
       
    41 
       
    42 fun fst(x,y) = x
       
    43 fun snd(x,y) = y;
       
    44 
    29 
    45 val concat = curry (op ^)
    30 val concat = curry (op ^)
    46 fun quote s = "\""^s^"\"";
    31 fun quote s = "\""^s^"\"";
    47 
       
    48 fun map2 f L1 L2 =
       
    49  let fun mp2 [] [] L = rev L
       
    50        | mp2 (a1::rst1) (a2::rst2) L = mp2 rst1 rst2 (f a1 a2::L)
       
    51        | mp2 _ _ _ = raise UTILS_ERR{func="map2",mesg="different length lists"}
       
    52    in mp2 L1 L2 []
       
    53    end;
       
    54 
       
    55 
    32 
    56 fun itlist f L base_value =
    33 fun itlist f L base_value =
    57    let fun it [] = base_value
    34    let fun it [] = base_value
    58          | it (a::rst) = f a (it rst)
    35          | it (a::rst) = f a (it rst)
    59    in it L 
    36    in it L 
    79        | it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2))
    56        | it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2))
    80        | it _ = raise UTILS_ERR{func="itlist2",mesg="different length lists"}
    57        | it _ = raise UTILS_ERR{func="itlist2",mesg="different length lists"}
    81  in  it (L1,L2)
    58  in  it (L1,L2)
    82  end;
    59  end;
    83 
    60 
    84 fun filter p L = itlist (fn x => fn y => if (p x) then x::y else y) L []
       
    85 
       
    86 fun mapfilter f alist = itlist (fn i=>fn L=> (f i::L) handle _ => L) alist [];
    61 fun mapfilter f alist = itlist (fn i=>fn L=> (f i::L) handle _ => L) alist [];
    87 
    62 
    88 fun pluck p  =
    63 fun pluck p  =
    89   let fun remv ([],_) = raise UTILS_ERR{func="pluck",mesg = "item not found"}
    64   let fun remv ([],_) = raise UTILS_ERR{func="pluck",mesg = "item not found"}
    90         | remv (h::t, A) = if p h then (h, rev A @ t) else remv (t,h::A)
    65         | remv (h::t, A) = if p h then (h, rev A @ t) else remv (t,h::A)
   102   let fun grab(0,L) = []
    77   let fun grab(0,L) = []
   103         | grab(n, x::rst) = f x::grab(n-1,rst)
    78         | grab(n, x::rst) = f x::grab(n-1,rst)
   104   in grab
    79   in grab
   105   end;
    80   end;
   106 
    81 
   107 fun all p =
       
   108    let fun every [] = true
       
   109          | every (a::rst) = (p a) andalso every rst       
       
   110    in every 
       
   111    end;
       
   112 
       
   113 fun exists p =
       
   114    let fun ex [] = false
       
   115          | ex (a::rst) = (p a) orelse ex rst       
       
   116    in ex 
       
   117    end;
       
   118 
       
   119 fun zip [] [] = []
       
   120   | zip (a::b) (c::d) = (a,c)::(zip b d)
       
   121   | zip _ _ = raise UTILS_ERR{func = "zip",mesg = "different length lists"};
       
   122 
       
   123 fun unzip L = itlist (fn (x,y) => fn (l1,l2) =>((x::l1),(y::l2))) L ([],[]);
       
   124 
       
   125 fun zip3 [][][] = []
    82 fun zip3 [][][] = []
   126   | zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3
    83   | zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3
   127   | zip3 _ _ _ = raise UTILS_ERR{func="zip3",mesg="different lengths"};
    84   | zip3 _ _ _ = raise UTILS_ERR{func="zip3",mesg="different lengths"};
   128 
    85 
   129 
    86 
   130 fun can f x = (f x ; true) handle _ => false;
    87 fun can f x = (f x ; true) handle _ => false;
   131 fun holds P x = P x handle _ => false;
    88 fun holds P x = P x handle _ => false;
   132 
    89 
   133 
    90 
   134 fun assert p x = 
       
   135  if (p x) then x else raise UTILS_ERR{func="assert", mesg="predicate not true"}
       
   136 
       
   137 fun assoc1 eq item =
       
   138    let fun assc ((entry as (key,_))::rst) = 
       
   139              if eq(item,key) then SOME entry else assc rst
       
   140          | assc [] = NONE
       
   141     in assc
       
   142     end;
       
   143 
       
   144 (* Set ops *)
    91 (* Set ops *)
   145 nonfix mem union;  (* Gag Barf Choke *)
    92 nonfix mem;  (* Gag Barf Choke *)
   146 fun mem eq_func i =
    93 fun mem eq_func i =
   147    let val eqi = eq_func i
    94    let val eqi = eq_func i
   148        fun mm [] = false
    95        fun mm [] = false
   149          | mm (a::rst) = eqi a orelse mm rst
    96          | mm (a::rst) = eqi a orelse mm rst
   150    in mm
    97    in mm
   151    end;
       
   152 
       
   153 fun union eq_func =
       
   154    let val mem = mem eq_func
       
   155        fun un S1 []  = S1
       
   156          | un [] S1  = S1
       
   157          | un (a::rst) S2 = if (mem a S2) then (un rst S2) else (a::un rst S2)
       
   158    in un
       
   159    end;
    98    end;
   160 
    99 
   161 fun mk_set eq_func =
   100 fun mk_set eq_func =
   162    let val mem = mem eq_func
   101    let val mem = mem eq_func
   163        fun mk [] = []
   102        fun mk [] = []
   164          | mk (a::rst) = if (mem a rst) then mk rst else a::(mk rst)
   103          | mk (a::rst) = if (mem a rst) then mk rst else a::(mk rst)
   165    in mk
   104    in mk
   166    end;
   105    end;
   167 
   106 
   168 (* Union of a family of sets *)
       
   169 fun Union eq_func set_o_sets = itlist (union eq_func) set_o_sets [];
       
   170 
       
   171 fun intersect eq_func S1 S2 = mk_set eq_func (filter (C (mem eq_func) S2) S1);
       
   172 
       
   173 (* All the elements in the first set that are not also in the second set. *)
   107 (* All the elements in the first set that are not also in the second set. *)
   174 fun set_diff eq_func S1 S2 = filter (fn x => not (mem eq_func x S2)) S1
   108 fun set_diff eq_func S1 S2 = filter (fn x => not (mem eq_func x S2)) S1
   175 
       
   176 fun set_eq eq_func S1 S2 = 
       
   177    null(set_diff eq_func S1 S2) andalso null(set_diff eq_func S2 S1);
       
   178 
   109 
   179 
   110 
   180 fun sort R = 
   111 fun sort R = 
   181 let fun part (m, []) = ([],[])
   112 let fun part (m, []) = ([],[])
   182       | part (m, h::rst) =
   113       | part (m, h::rst) =
   190         end
   121         end
   191 in qsort
   122 in qsort
   192 end;
   123 end;
   193 
   124 
   194 
   125 
   195 val int_to_string = int_to_string;
       
   196 
   126 
   197 end; (* Utils *)
   127 end; (* Utils *)