2112

1 
(*


2 
* Some common utilities. This strucuture is parameterized over


3 
* "int_to_string" because there is a difference between the string


4 
* operations of SML/NJ versions 93 and 109.


5 
**)


6 


7 
functor UTILS (val int_to_string : int > string) :Utils_sig =


8 
struct


9 


10 
(* Standard exception for TFL. *)


11 
exception ERR of {module:string,func:string, mesg:string};


12 
fun UTILS_ERR{func,mesg} = ERR{module = "Utils",func=func,mesg=mesg};


13 


14 
local


15 
fun info_string s {module,func,mesg} =


16 
(s^" at "^module^"."^func^":\n"^mesg^"\n")


17 
in


18 
val ERR_string = info_string "Exception raised"


19 
val MESG_string = info_string "Message"


20 
end;


21 


22 
fun Raise (e as ERR sss) = (output(std_out, ERR_string sss); raise e)


23 
 Raise e = raise e;


24 


25 


26 
(* option type *)


27 
datatype 'a option = SOME of 'a  NONE


28 


29 


30 
(* Simple combinators *)


31 


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


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 


45 
val concat = curry (op ^)


46 
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 


56 
fun itlist f L base_value =


57 
let fun it [] = base_value


58 
 it (a::rst) = f a (it rst)


59 
in it L


60 
end;


61 


62 
fun rev_itlist f =


63 
let fun rev_it [] base = base


64 
 rev_it (a::rst) base = rev_it rst (f a base)


65 
in rev_it


66 
end;


67 


68 
fun end_itlist f =


69 
let fun endit [] = raise UTILS_ERR{func="end_itlist", mesg="list too short"}


70 
 endit alist =


71 
let val (base::ralist) = rev alist


72 
in itlist f (rev ralist) base


73 
end


74 
in endit


75 
end;


76 


77 
fun itlist2 f L1 L2 base_value =


78 
let fun it ([],[]) = base_value


79 
 it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2))


80 
 it _ = raise UTILS_ERR{func="itlist2",mesg="different length lists"}


81 
in it (L1,L2)


82 
end;


83 


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 [];


87 


88 
fun pluck p =


89 
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)


91 
in fn L => remv(L,[])


92 
end;


93 


94 
fun front_back [] = raise UTILS_ERR{func="front_back",mesg="empty list"}


95 
 front_back [x] = ([],x)


96 
 front_back (h::t) =


97 
let val (L,b) = front_back t


98 
in (h::L,b)


99 
end;


100 


101 
fun take f =


102 
let fun grab(0,L) = []


103 
 grab(n, x::rst) = f x::grab(n1,rst)


104 
in grab


105 
end;


106 


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 [][][] = []


126 
 zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3


127 
 zip3 _ _ _ = raise UTILS_ERR{func="zip3",mesg="different lengths"};


128 


129 


130 
fun can f x = (f x ; true) handle _ => false;


131 
fun holds P x = P x handle _ => false;


132 


133 


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 *)


145 
nonfix mem union; (* Gag Barf Choke *)


146 
fun mem eq_func i =


147 
let val eqi = eq_func i


148 
fun mm [] = false


149 
 mm (a::rst) = eqi a orelse mm rst


150 
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;


160 


161 
fun mk_set eq_func =


162 
let val mem = mem eq_func


163 
fun mk [] = []


164 
 mk (a::rst) = if (mem a rst) then mk rst else a::(mk rst)


165 
in mk


166 
end;


167 


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. *)


174 
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 


179 


180 
fun sort R =


181 
let fun part (m, []) = ([],[])


182 
 part (m, h::rst) =


183 
let val (l1,l2) = part (m,rst)


184 
in if (R h m) then (h::l1, l2)


185 
else (l1, h::l2) end


186 
fun qsort [] = []


187 
 qsort (h::rst) =


188 
let val (l1,l2) = part(h,rst)


189 
in qsort l1@ [h] @qsort l2


190 
end


191 
in qsort


192 
end;


193 


194 


195 
val int_to_string = int_to_string;


196 


197 
end; (* Utils *)
