(* file "seq/seq.sml" 25.10.1999 *)
functor Seq (Basicseq: BASICSEQUENCE): SEQUENCE =
struct
open Basicseq;
type 'a t = 'a t; (* hide the actual Basicseq in t *)
exception Empty;
exception Subscript;
fun null l = case force l of Nil => true  _ => false;
fun hd l = case force l of Cons c => chd c  _ => raise Empty;
fun tl l = case force l of Cons c => ctl c  _ => raise Empty;
fun last l
= case force l of
Cons c => let val tll = ctl c in if null tll then chd c else last tll end
 _ => raise Empty
;
fun singleton x = cons (x, empty ());
fun toList l = case force l of Cons lc => chd lc :: toList (ctl lc)  _ => [];
fun length l = case force l of Cons lc => 1 + length (ctl lc)  _ => 0 ;
fun take (n, l)
= if n > 0 then
case force l of
Cons lc => chd lc :: take (Global.dec n, ctl lc)
 _ => raise Subscript
else []
;
fun drop (n, l)
= if n > 0 then
case force l of
Cons lc => drop (Global.dec n, ctl lc)
 _ => raise Subscript
else l
;
fun iterate next start = lazycons (start, fn () => iterate next (next start));
fun interleave (k, l)
= case force k of
Cons c => lazycons (chd c, fn () => interleave (l, ctl c))
 _ => l
;
fun append (k, l)
= case force k of
Cons c => lazycons (chd c, fn () => append (ctl c, l))
 _ => l
;
fun mapFromList f l
= List.foldr (fn (x, s) => cons (f x, s)) (empty ()) l
;
fun concatMapFromList f l
= List.foldr (fn (x, s) => append (f x, s)) (empty ()) l
;
fun fromList l = mapFromList Global.I l;
fun map f l
= case force l of
Cons c => lazycons (f (chd c), fn () => map f (ctl c))
 _ => empty ()
;
fun filter p l
= case force l of
Cons c =>
let fun lazytll () = filter p (ctl c) in
if p (chd c) then lazycons (chd c, lazytll)
else lazytll ()
end
 _ => empty ()
;
fun lazyappend (k, lf)
= case force k of
Cons c => lazycons (chd c, fn () => lazyappend (ctl c, lf))
 _ => lf ()
;
fun concat l
= case force l of
Cons c => (* append (chd c, concat (ctl c))
seems nice but loops on all infinite lists *)
(* (case force (chd c) of
Cons cc =>
lazycons (chd cc,
fn () => append (ctl cc, concat (ctl c)))
 _ => concat (ctl c))
is still bugged, since a concat of an infinite list followed by
infinitely many empty list will loop when asked for its tail *)
lazyappend (chd c, fn () => concat (ctl c))
 _ => empty ()
;
fun concatMap f l
= case force l of
Cons c => lazyappend (f (chd c), fn () => concatMap f (ctl c))
 _ => empty ()
;
fun test ()
= take (10, interleave (iterate Global.inc 0, fromList [111,222,333]))
= [0,111,1,222,2,333,3,4,5,6]
andalso
take (10, interleave (fromList [111,222,333], iterate Global.inc 0))
= [111,0,222,1,333,2,3,4,5,6]
andalso
take (10, drop (10, map Global.dec (drop (1000, filter Global.evenp (iterate
(Global.inc o Global.inc o Global.inc) 100)))))
= [6159,6165,6171,6177,6183,6189,6195,6201,6207,6213]
andalso
take (20, drop(1111, concat (interleave (map (fn x => singleton x)
(iterate Global.inc 0), iterate Global.I (empty ())))))
= [1111,1112,1113,1114,1115,1116,1117,1118,1119,1120,1121,1122,1123,1124,
1125,1126,1127,1128,1129,1130]
andalso
take (20, drop (0, drop(1111, append (empty (), (append (singleton 3,
append(fromList [0,0,0,9],
concat (interleave (map (fn x => singleton x)
(iterate Global.inc 0), iterate Global.I (empty ()))))))))))
= [1106,1107,1108,1109,1110,1111,1112,1113,1114,
1115,1116,1117,1118,1119,1120,1121,1122,1123,1124,1125]
andalso
take (10, fromList [1,2]) = [5] handle Subscript => true
andalso
not (null (drop (10, fromList [1,2]))) handle Subscript => true
andalso
null (empty ())
andalso
not (null (singleton 5))
andalso
toList (fromList ([]:int list)) = []
andalso
toList (lazycons (5,
fn () => cons (3, drop (1, fromList ([1,2,3]:int list))))) = [5,3,2,3]
andalso
hd (tl (drop (111111, iterate Global.inc 0))) = 111112
andalso
hd (drop (3, (concat (cons (iterate Global.inc 0, iterate Global.I (empty ())))))) = 3
(* this concat loops in many bugged implementations *)
;
fun timehelp (x)
= if test () then
let
val l = iterate Global.inc x;
val a0 = hd (drop (100000, l));
val a1 = a0 + hd (drop (100000, l));
val a2 = a1 + hd (drop (100000, l));
val a3 = a2 + hd (drop (100000, l));
val a4 = a3 + hd (drop (100000, l));
val a5 = a4 + hd (drop (100000, l));
val a6 = a5 + hd (drop (100000, l));
val a7 = a6 + hd (drop (100000, l));
val a8 = a7 + hd (drop (100000, l));
fun row (x1, x2, y)
= if x1 > x2 then [] else (x1, y) :: row (x1 + 1, x2, y);
fun interval ((x1, y1), (x2, y2))
= if y1 > y2 then []
else row (x1, x2, y1) @ interval ((x1, y1 + 1), (x2, y2))
;
fun minpoint l
= case l of
x :: k
=>
if List.null k then x
else
let val (x1, y1) = x
val (x2, y2) = minpoint k
in (Int.min (x1, x2), Int.min (y1, y2))
end
 _ => raise Empty
;
fun maxpoint l
= case l of
x :: k
=>
if List.null k then x
else
let val (x1, y1) = x
val (x2, y2) = maxpoint k
in (Int.max (x1, x2), Int.max (y1, y2))
end
 _ => raise Empty
;
fun rectangle (l)
= let val (x1, y1) = minpoint l
val (x2, y2) = maxpoint l
in (List.length l = (x2  x1 + 1) * (y2  y1 + 1))
end
;
fun incrX (x, y) = (x + 1, y);
fun incrY (x, y) = (x, y + 1);
fun line (l: (int * int) list) = (#2 (List.last l) = #2 (List.hd l));
fun lowRightCorner (l: (int * int) list)
= (#1 (List.last l), #2 (List.hd l))
;
fun search (C, outputstack, x, inputstack)
= case inputstack of
topinputstack :: popinputstack
=>
let
fun next ()
= search (C, topinputstack :: outputstack, x, popinputstack)
in
if C topinputstack then
lazycons
((x :: topinputstack) :: (outputstack @ popinputstack), next)
else next ()
end
 _ => empty ()
;
fun partC (n, C, x :: L)
= if List.null L then singleton [[x]]
else
let
fun glue sQ
= if null sQ then empty ()
else
let val partition = hd sQ
in
lazyappend
(if List.all rectangle partition then
let
fun rectAR l
= (incrY x = lowRightCorner l
orelse
(incrX x = List.hd l
andalso
line l))
andalso
C (x :: l)
fun next ()
= search (rectAR, [], x, partition)
in
if List.length partition < n then
lazycons ([x] :: partition, next)
else next ()
end
else
let
fun nonRect l
= (incrX x = List.hd l)
andalso
C (x :: l)
in
search (nonRect, [], x, partition)
end
,fn () => glue (tl sQ)
)
end
in
glue (partC (n, C, L))
end
;
val allsol = partC (20,
fn l => List.length l <= 20,
interval ((1, 1), (10, 8)));
in
(a8 + hd (drop (100000, l)),
[take(10, allsol)
,
take(20, allsol)
,
take(30, allsol)
,
take(100, allsol)
,
take(101, allsol)
,
take(102, allsol)
,
take(103, allsol)
]
)
end
else (0, [])
;
fun time () = Global.timeit timehelp 0;
end; (* structure *)
(* without the following type
ML complains that type cell is not abstract enough *)
abstype ('a, 'b) abspair = Pair of 'a * 'b
with
fun makepair (a, b) = Pair (a, b);
fun firstpair (Pair (a, b)) = a;
fun seconpair (Pair (a, b)) = b;
end;
structure Seqbasic1: BASICSEQUENCE =
(* head is present. call by name.
Like p. 191 ff. of Paulson (1996) ML for the working programmer. *)
struct
datatype 'a eager = Nil
 Cons of 'a cell
withtype 'a t = 'a eager
and 'a cell = ('a, (unit > 'a t)) abspair
;
fun force (l: 'a t) = l;
fun chd (c: 'a cell) = firstpair c;
fun ctl (c: 'a cell) = (seconpair c) ();
fun empty () = Nil;
fun cons (x, l) = Cons (makepair (x, fn () => l));
fun lazycons (x, y) = Cons (makepair(x, y));
end;
structure Seqbasic2: LAZYBASICSEQUENCE =
(* head may not be present. call by name.
Ex 5.25 on p. 194 of Paulson (1996) ML for the working programmer. *)
(* When lazylazycons is not needed, this version is definite worse than
Seqbasic1, because hd (lazycons (x, lf)) calls lf (),
which in combination with callbyname is desastrous. *)
(* time () runs more than 1000 times slower than with Seqbasic1
and more than 2000 times slower than with Seqbasic5 which
also provides lazylazycons *)
struct
datatype 'a eager = Nil
 Cons of 'a cell
withtype 'a t = 'a eager
and 'a cell = unit > 'a * 'a t
;
fun force (l: 'a t) = l;
fun chd (c: 'a cell) = #1 (c ()); (* Seqbasic1 is much better here *)
fun ctl (c: 'a cell) = #2 (c ());
fun empty () = Nil;
fun cons (x , l ) = Cons (fn () => (x , l ));
fun lazycons (x , lf) = Cons (fn () => (x , lf()));
(* Seqbasic1 is better here *)
fun lazylazycons (xf, lf) = Cons (fn () => (xf(), lf()));
;
end;
structure Seqbasic3: BASICSEQUENCE =
(* head is present, call by need realized with ref *)
(* improved type structure compared to
p. 326 ff., Paulson (1996) ML for the working programmer. *)
(* time () runs nearly thrice as fast as with Seqbasic1 *)
struct
datatype 'a eager = Nil
 Cons of 'a cell
and 'a deref = Imme of 'a eager (* immediate. *)
 Wait of unit > 'a eager
(* lazy. "ctl" computes next element and updates ref for call by need *)
withtype 'a t = 'a eager
and 'a cell = ('a, 'a deref ref) abspair
;
(* 'a t = 'a eager: Nil  Cons

v
'a cell: 'a * ref

v
'a deref: Imme of 'a t  Wait of unit > 'a eager
*)
fun force (l: 'a t): 'a eager = l;
val chd: 'a cell > 'a = firstpair;
fun ctl (c: 'a cell): 'a t
= let val l = (seconpair c) in
case ! l of
Imme i => i
 Wait w => let val res = w () in l := Imme res; res end
end
;
fun empty () = Nil;
fun cons (x , l ) = Cons (makepair (x, ref (Imme l )));
fun lazycons (x , lf) = Cons (makepair (x, ref (Wait lf)));
end;
structure Seqbasic4: LAZYBASICSEQUENCE =
(* head may not be present, call by need realized with ref *)
(* This version is definitely worse than
Seqbasic3 (when lazylazycons is not needed) and Seqbasic5
because "empty()" and "hd (lazycons(x, fn))" are more expensive,
although (due to callbyneed) this is not desastrous as with Seqbasic2 *)
(* Nevertheless, time () runs only 5 % slower than with Seqbasic 3
for old sml and 3 % faster than Seqbasic 3 with new sml *)
struct
datatype 'a eager = Nil
 Cons of 'a cell
and 'a tderef = Imme of 'a eager(* immediate. "force" just strips Imme *)
 Wait of unit > 'a eager
(* lazy. "force" computes next element and updates ref for call by need *)
withtype 'a t = 'a tderef ref
and 'a cell = ('a, 'a t) abspair
;
(* 'a t: ref

v
'a tderef: Imme  Wait of unit > 'a eager

v
'a eager: Nil  Cons

v
'a cell: 'a * 'a t
*)
fun force (l: 'a t): 'a eager
= case ! l of
Imme i => i
 Wait w => let val res = w () in l := Imme res; res end
;
val chd: 'a cell > 'a = firstpair;
val ctl: 'a cell > 'a t = seconpair;
fun empty () = ref (Imme Nil); (* Seqbasic3&5 are better here *)
fun cons (x , l ) = ref (Imme (Cons (makepair (x, l))));
fun lazycons (x , lf) = ref (Wait (fn () => Cons (makepair (x , lf()))));
(* Seqbasic3&5 are much better here:
They don't have to call lf for reading x *)
fun lazylazycons(xf, lf) = ref (Wait (fn () => Cons (makepair (xf(), lf()))));
(* Seqbasic3 is cannot do this *)
end;
structure Seqbasic5: LAZYBASICSEQUENCE =
(* head may not be present, call by need realized with ref *)
(* This is to be preferred to Seqbasic3 iff lazylazycons is needed *)
(* Nevertheless, time () runs only 5  10 % slower than with Seqbasic 3 *)
struct
datatype 'a eager = Nil
 Cons of 'a cell
and 'a lazyt = Immet of 'a t (* immediate. *)
 Waitt of unit > 'a t
(* lazy. "chd" computes next element and updates ref for call by need *)
and 'a lazya = Immea of 'a (* immediate. *)
 Waita of unit > 'a
(* lazy. "ctl" computes next element and updates ref for call by need *)
withtype 'a t = 'a eager
and 'a cell = ('a lazya ref, 'a lazyt ref) abspair
;
(* 'a t = a' eager: Nil  Cons

v
'a cell: ref * ref
 
v v
'a lazya: Immea  Waita 'a lazyt: Immet  Waitt
   
v v v v
'a unit>'a 'a t unit > 'a t
*)
fun force (l: 'a t): 'a eager = l;
fun chd (c: 'a cell): 'a
= let val r = (firstpair c) in
case ! r of
Immea i => i
 Waita w => let val res = w () in r := Immea res; res end
end
;
fun ctl (c: 'a cell): 'a t
= let val r = (seconpair c) in
case ! r of
Immet i => i
 Waitt w => let val res = w () in r := Immet res; res end
end
;
fun empty () = Nil;
fun cons (x , l ) = Cons (makepair (ref (Immea x ), ref (Immet l )));
fun lazycons (x , lf) = Cons (makepair (ref (Immea x ), ref (Waitt lf)));
fun lazylazycons(xf, lf) = Cons (makepair (ref (Waita xf), ref (Waitt lf)));
(* Seqbasic3 is cannot do this *)
end;
structure Seq1 = Seq (Seqbasic1); Seq1.test ();
structure Seq2 = Seq (Seqbasic2); Seq2.test ();
structure Seq3 = Seq (Seqbasic3); Seq3.test ();
structure Seq4 = Seq (Seqbasic4); Seq4.test ();
structure Seq5 = Seq (Seqbasic5); Seq5.test ();
Seq1.time ();
(* Seq2.time (); *)
Seq3.time ();
Seq4.time ();
Seq5.time ();