TFL/utils.sml
author wenzelm
Tue, 05 Sep 2000 18:53:42 +0200
changeset 9867 bf8300fa4238
parent 3391 5e45dd3b64e9
child 9876 a069795f1060
permissions -rw-r--r--
tuned;
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
9867
wenzelm
parents: 3391
diff changeset
     1
(*  Title:      TFL/utils.sml
3302
404fe31fd8d2 New headers and other minor changes
paulson
parents: 3245
diff changeset
     2
    ID:         $Id$
404fe31fd8d2 New headers and other minor changes
paulson
parents: 3245
diff changeset
     3
    Author:     Konrad Slind, Cambridge University Computer Laboratory
404fe31fd8d2 New headers and other minor changes
paulson
parents: 3245
diff changeset
     4
    Copyright   1997  University of Cambridge
2112
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
     5
9867
wenzelm
parents: 3391
diff changeset
     6
Basic utilities.
3302
404fe31fd8d2 New headers and other minor changes
paulson
parents: 3245
diff changeset
     7
*)
3245
241838c01caf Removal of redundant code (unused or already present in Isabelle.
paulson
parents: 3191
diff changeset
     8
9867
wenzelm
parents: 3391
diff changeset
     9
signature Utils_sig =
wenzelm
parents: 3391
diff changeset
    10
sig
wenzelm
parents: 3391
diff changeset
    11
  exception ERR of {module:string,func:string, mesg:string}
wenzelm
parents: 3391
diff changeset
    12
wenzelm
parents: 3391
diff changeset
    13
  val can   : ('a -> 'b) -> 'a -> bool
wenzelm
parents: 3391
diff changeset
    14
  val holds : ('a -> bool) -> 'a -> bool
wenzelm
parents: 3391
diff changeset
    15
  val C : ('a -> 'b -> 'c) -> 'b -> 'a -> 'c
wenzelm
parents: 3391
diff changeset
    16
wenzelm
parents: 3391
diff changeset
    17
  val itlist : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
wenzelm
parents: 3391
diff changeset
    18
  val rev_itlist : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
wenzelm
parents: 3391
diff changeset
    19
  val end_itlist : ('a -> 'a -> 'a) -> 'a list -> 'a
wenzelm
parents: 3391
diff changeset
    20
  val itlist2 :('a -> 'b -> 'c -> 'c) -> 'a list -> 'b list -> 'c -> 'c
wenzelm
parents: 3391
diff changeset
    21
  val pluck : ('a -> bool) -> 'a list -> 'a * 'a list
wenzelm
parents: 3391
diff changeset
    22
  val zip3 : 'a list -> 'b list -> 'c list -> ('a*'b*'c) list
wenzelm
parents: 3391
diff changeset
    23
  val take  : ('a -> 'b) -> int * 'a list -> 'b list
wenzelm
parents: 3391
diff changeset
    24
  val sort  : ('a -> 'a -> bool) -> 'a list -> 'a list
wenzelm
parents: 3391
diff changeset
    25
wenzelm
parents: 3391
diff changeset
    26
end;
wenzelm
parents: 3391
diff changeset
    27
wenzelm
parents: 3391
diff changeset
    28
3245
241838c01caf Removal of redundant code (unused or already present in Isabelle.
paulson
parents: 3191
diff changeset
    29
structure Utils = 
2112
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    30
struct
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    31
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    32
(* Standard exception for TFL. *)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    33
exception ERR of {module:string,func:string, mesg:string};
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    34
fun UTILS_ERR{func,mesg} = ERR{module = "Utils",func=func,mesg=mesg};
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    35
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    36
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    37
(* Simple combinators *)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    38
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    39
fun C f x y = f y x
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    40
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    41
fun itlist f L base_value =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    42
   let fun it [] = base_value
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    43
         | it (a::rst) = f a (it rst)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    44
   in it L 
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    45
   end;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    46
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    47
fun rev_itlist f =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    48
   let fun rev_it [] base = base
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    49
         | rev_it (a::rst) base = rev_it rst (f a base)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    50
   in rev_it
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    51
   end;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    52
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    53
fun end_itlist f =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    54
   let fun endit [] = raise UTILS_ERR{func="end_itlist", mesg="list too short"}
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    55
         | endit alist = 
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    56
            let val (base::ralist) = rev alist
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    57
            in itlist f (rev ralist) base
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    58
            end
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    59
   in endit
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 itlist2 f L1 L2 base_value =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    63
 let fun it ([],[]) = base_value
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    64
       | it ((a::rst1),(b::rst2)) = f a b (it (rst1,rst2))
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    65
       | it _ = raise UTILS_ERR{func="itlist2",mesg="different length lists"}
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    66
 in  it (L1,L2)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    67
 end;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    68
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    69
fun pluck p  =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    70
  let fun remv ([],_) = raise UTILS_ERR{func="pluck",mesg = "item not found"}
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    71
        | 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
    72
  in fn L => remv(L,[])
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    73
  end;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    74
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    75
fun take f =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    76
  let fun grab(0,L) = []
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    77
        | grab(n, x::rst) = f x::grab(n-1,rst)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    78
  in grab
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    79
  end;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    80
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    81
fun zip3 [][][] = []
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    82
  | zip3 (x::l1) (y::l2) (z::l3) = (x,y,z)::zip3 l1 l2 l3
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    83
  | zip3 _ _ _ = raise UTILS_ERR{func="zip3",mesg="different lengths"};
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    84
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    85
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    86
fun can f x = (f x ; true) handle _ => false;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    87
fun holds P x = P x handle _ => false;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    88
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    89
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    90
fun sort R = 
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    91
let fun part (m, []) = ([],[])
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    92
      | part (m, h::rst) =
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    93
         let val (l1,l2) = part (m,rst)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    94
         in if (R h m) then (h::l1, l2)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    95
                       else (l1,  h::l2) end
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    96
    fun qsort [] = []
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    97
      | qsort (h::rst) = 
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    98
        let val (l1,l2) = part(h,rst)
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
    99
        in qsort l1@ [h] @qsort l2
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   100
        end
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   101
in qsort
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   102
end;
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   103
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   104
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   105
3902e9af752f Konrad Slind's TFL
paulson
parents:
diff changeset
   106
end; (* Utils *)