src/Pure/General/seq.ML
author wenzelm
Wed Jun 22 19:41:19 2005 +0200 (2005-06-22)
changeset 16534 95460b6eb712
parent 16002 e0557c452138
child 17347 fb3d42ef61ed
permissions -rw-r--r--
tuned;
     1 (*  Title:      Pure/General/seq.ML
     2     ID:         $Id$
     3     Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
     4     Author:     Markus Wenzel, TU Munich
     5 
     6 Unbounded sequences implemented by closures.  RECOMPUTES if sequence
     7 is re-inspected.  Memoing, using polymorphic refs, was found to be
     8 slower!  (More GCs)
     9 *)
    10 
    11 signature SEQ =
    12 sig
    13   type 'a seq
    14   val make: (unit -> ('a * 'a seq) option) -> 'a seq
    15   val pull: 'a seq -> ('a * 'a seq) option
    16   val empty: 'a seq
    17   val cons: 'a * 'a seq -> 'a seq
    18   val single: 'a -> 'a seq
    19   val try: ('a -> 'b) -> 'a -> 'b seq
    20   val hd: 'a seq -> 'a
    21   val tl: 'a seq -> 'a seq
    22   val chop: int * 'a seq -> 'a list * 'a seq
    23   val list_of: 'a seq -> 'a list
    24   val of_list: 'a list -> 'a seq
    25   val map: ('a -> 'b) -> 'a seq -> 'b seq
    26   val mapp: ('a -> 'b) -> 'a seq -> 'b seq -> 'b seq
    27   val append: 'a seq * 'a seq -> 'a seq
    28   val filter: ('a -> bool) -> 'a seq -> 'a seq
    29   val flat: 'a seq seq -> 'a seq
    30   val interleave: 'a seq * 'a seq -> 'a seq
    31   val print: (int -> 'a -> unit) -> int -> 'a seq -> unit
    32   val it_right : ('a * 'b seq -> 'b seq) -> 'a seq * 'b seq -> 'b seq
    33   val commute: 'a seq list -> 'a list seq
    34   val succeed: 'a -> 'a seq
    35   val fail: 'a -> 'b seq
    36   val THEN: ('a -> 'b seq) * ('b -> 'c seq) -> 'a -> 'c seq
    37   val ORELSE: ('a -> 'b seq) * ('a -> 'b seq) -> 'a -> 'b seq
    38   val APPEND: ('a -> 'b seq) * ('a -> 'b seq) -> 'a -> 'b seq
    39   val EVERY: ('a -> 'a seq) list -> 'a -> 'a seq
    40   val FIRST: ('a -> 'b seq) list -> 'a -> 'b seq
    41   val TRY: ('a -> 'a seq) -> 'a -> 'a seq
    42   val REPEAT: ('a -> 'a seq) -> 'a -> 'a seq
    43   val REPEAT1: ('a -> 'a seq) -> 'a -> 'a seq
    44   val INTERVAL: (int -> 'a -> 'a seq) -> int -> int -> 'a -> 'a seq
    45   val DETERM: ('a -> 'b seq) -> 'a -> 'b seq
    46 end;
    47 
    48 structure Seq: SEQ =
    49 struct
    50 
    51 
    52 (** lazy sequences **)
    53 
    54 datatype 'a seq = Seq of unit -> ('a * 'a seq) option;
    55 
    56 (*the abstraction for making a sequence*)
    57 val make = Seq;
    58 
    59 (*return next sequence element as NONE or SOME (x, xq)*)
    60 fun pull (Seq f) = f ();
    61 
    62 
    63 (*the empty sequence*)
    64 val empty = Seq (fn () => NONE);
    65 
    66 (*prefix an element to the sequence -- use cons (x, xq) only if
    67   evaluation of xq need not be delayed, otherwise use
    68   make (fn () => SOME (x, xq))*)
    69 fun cons x_xq = make (fn () => SOME x_xq);
    70 
    71 fun single x = cons (x, empty);
    72 
    73 (*head and tail -- beware of calling the sequence function twice!!*)
    74 fun hd xq = #1 (the (pull xq))
    75 and tl xq = #2 (the (pull xq));
    76 
    77 (*partial function as procedure*)
    78 fun try f x =
    79   (case Library.try f x of
    80     SOME y => single y
    81   | NONE => empty);
    82 
    83 
    84 (*the list of the first n elements, paired with rest of sequence;
    85   if length of list is less than n, then sequence had less than n elements*)
    86 fun chop (n, xq) =
    87   if n <= 0 then ([], xq)
    88   else
    89     (case pull xq of
    90       NONE => ([], xq)
    91     | SOME (x, xq') => apfst (Library.cons x) (chop (n - 1, xq')));
    92 
    93 (*conversion from sequence to list*)
    94 fun list_of xq =
    95   (case pull xq of
    96     NONE => []
    97   | SOME (x, xq') => x :: list_of xq');
    98 
    99 (*conversion from list to sequence*)
   100 fun of_list xs = foldr cons empty xs;
   101 
   102 
   103 (*map the function f over the sequence, making a new sequence*)
   104 fun map f xq =
   105   make (fn () =>
   106     (case pull xq of
   107       NONE => NONE
   108     | SOME (x, xq') => SOME (f x, map f xq')));
   109 
   110 (*map over a sequence xq, append the sequence yq*)
   111 fun mapp f xq yq =
   112   let
   113     fun copy s =
   114       make (fn () =>
   115         (case pull s of
   116           NONE => pull yq
   117         | SOME (x, s') => SOME (f x, copy s')))
   118   in copy xq end;
   119 
   120 (*sequence append:  put the elements of xq in front of those of yq*)
   121 fun append (xq, yq) =
   122   let
   123     fun copy s =
   124       make (fn () =>
   125         (case pull s of
   126           NONE => pull yq
   127         | SOME (x, s') => SOME (x, copy s')))
   128   in copy xq end;
   129 
   130 (*filter sequence by predicate*)
   131 fun filter pred xq =
   132   let
   133     fun copy s =
   134       make (fn () =>
   135         (case pull s of
   136           NONE => NONE
   137         | SOME (x, s') => if pred x then SOME (x, copy s') else pull (copy s')));
   138   in copy xq end;
   139 
   140 (*flatten a sequence of sequences to a single sequence*)
   141 fun flat xqq =
   142   make (fn () =>
   143     (case pull xqq of
   144       NONE => NONE
   145     | SOME (xq, xqq') => pull (append (xq, flat xqq'))));
   146 
   147 (*interleave elements of xq with those of yq -- fairer than append*)
   148 fun interleave (xq, yq) =
   149   make (fn () =>
   150     (case pull xq of
   151       NONE => pull yq
   152     | SOME (x, xq') => SOME (x, interleave (yq, xq'))));
   153 
   154 (*print a sequence, up to "count" elements*)
   155 fun print print_elem count =
   156   let
   157     fun prnt k xq =
   158       if k > count then ()
   159       else
   160         (case pull xq of
   161           NONE => ()
   162         | SOME (x, xq') => (print_elem k x; writeln ""; prnt (k + 1) xq'));
   163   in prnt 1 end;
   164 
   165 (*accumulating a function over a sequence; this is lazy*)
   166 fun it_right f (xq, yq) =
   167   let
   168     fun its s =
   169       make (fn () =>
   170         (case pull s of
   171           NONE => pull yq
   172         | SOME (a, s') => pull (f (a, its s'))))
   173   in its xq end;
   174 
   175 (*turn a list of sequences into a sequence of lists*)
   176 fun commute [] = single []
   177   | commute (xq :: xqs) =
   178       make (fn () =>
   179         (case pull xq of
   180           NONE => NONE
   181         | SOME (x, xq') =>
   182             (case pull (commute xqs) of
   183               NONE => NONE
   184             | SOME (xs, xsq) =>
   185                 SOME (x :: xs, append (map (Library.cons x) xsq, commute (xq' :: xqs))))));
   186 
   187 
   188 
   189 (** sequence functions **)      (*some code copied from Pure/tctical.ML*)
   190 
   191 fun succeed x = single x;
   192 fun fail _ = empty;
   193 
   194 fun op THEN (f, g) x = flat (map g (f x));
   195 
   196 fun op ORELSE (f, g) x =
   197   (case pull (f x) of
   198     NONE => g x
   199   | some => make (fn () => some));
   200 
   201 fun op APPEND (f, g) x =
   202   append (f x, make (fn () => pull (g x)));
   203 
   204 fun EVERY fs = foldr THEN succeed fs;
   205 fun FIRST fs = foldr ORELSE fail fs;
   206 
   207 fun TRY f = ORELSE (f, succeed);
   208 
   209 fun REPEAT f =
   210   let
   211     fun rep qs x =
   212       (case pull (f x) of
   213         NONE => SOME (x, make (fn () => repq qs))
   214       | SOME (x', q) => rep (q :: qs) x')
   215     and repq [] = NONE
   216       | repq (q :: qs) =
   217           (case pull q of
   218             NONE => repq qs
   219           | SOME (x, q) => rep (q :: qs) x);
   220   in fn x => make (fn () => rep [] x) end;
   221 
   222 fun REPEAT1 f = THEN (f, REPEAT f);
   223 
   224 fun INTERVAL f i j x =
   225   if i > j then single x
   226   else op THEN (f j, INTERVAL f i (j - 1)) x;
   227 
   228 fun DETERM f x =
   229   (case pull (f x) of
   230     NONE => empty
   231   | SOME (x', _) => cons (x', empty));
   232 
   233 end;