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