(* CTM Chapter #03 Examples in Alice ML *)
import structure Url from "x-alice:/lib/system/Url"
import structure HttpClient from "x-alice:/lib/system/HttpClient"
import structure Gtk from "x-alice:/lib/gtk/Gtk"
(* syntactic sugar for solutions using promises/futures *)
open Promise
open Future
infix 3 ?=
val op?= = fulfill
val ? = future
(* 3.1.3 Implementing components in the declarative model *)
val x = 1
val y = 2
val z = promise();
if (x > y) then z ?= x else z ?=y;
(* 3.2.1 Iterative computation - A general schema *)
fun abs' x =
if (x < 0.0)
then ~x
else x
fun goodEnough guess x =
(abs'(x - guess*guess) / x) < 0.00001
fun improve guess x =
(guess + x/guess) / 2.0
fun sqrtIter guess x =
if (goodEnough guess x)
then guess
else sqrtIter (improve guess x) x
fun sqrt x =
let
val guess = 1.0
in
sqrtIter guess x
end;
(* 3.2.3 Iterative computation - Using local procedures *)
local
fun goodEnough guess x =
(abs'(x - guess*guess) / x) < 0.00001
fun improve guess x =
(guess + x/guess) / 2.0
fun sqrtIter guess x =
if (goodEnough guess x)
then guess
else sqrtIter (improve guess x) x
in
fun sqrt x =
let
val guess = 1.0
in
sqrtIter guess x
end;
end;
fun sqrt x =
let
fun goodEnough guess x =
(abs'(x - guess*guess) / x) < 0.00001
fun sqrtIter guess x =
let
fun improve guess x =
(guess + x/guess) / 2.0
in
if (goodEnough guess x)
then guess
else sqrtIter (improve guess x) x
end
val guess = 1.0
in
sqrtIter guess x
end;
fun sqrt x =
let
fun sqrtIter guess =
let
fun improve() =
(guess + x/guess) / 2.0
fun goodEnough() =
(abs'(x - guess*guess) / x) < 0.00001
in
if goodEnough()
then guess
else sqrtIter (improve())
end
val guess = 1.0
in
sqrtIter guess
end;
(* 3.2.4 Iterative computation - From general schema to control abstraction *)
fun sqrt x =
let
fun improve guess =
(guess + x/guess) / 2.0
fun goodEnough guess =
(abs'(x - guess*guess) / x) < 0.00001
fun sqrtIter guess =
if (goodEnough guess)
then guess
else sqrtIter (improve guess)
val guess = 1.0
in
sqrtIter guess
end;
fun iterate transform isdone s =
if (isdone s)
then s
else iterate transform isdone (transform(s))
fun sqrt x =
iterate
(fn guess => (guess + x/guess) / 2.0)
(fn guess => (abs'(x - guess*guess) / x) < 0.00001)
1.0;
(* 3.3 Recursive computation *)
fun fact n =
if (n = 0)
then 1
else
if (n > 0)
then n * fact (n-1)
else raise Domain;
inspect (fact 5);
(* 3.3.1 Recursive computation - Growing stack size *)
fun fact n r =
if (n = 0)
then r ?= 1
else
if (n > 0)
then
let
val n1 = n - 1
val r1 = promise()
in
fact n1 r1;
r ?= n * ?r1
end
else raise Domain;
val r = promise();
fact 5 r;
(* 3.3.3 Converting a recursive to an iterative computation *)
fun fact n =
let
fun factIter n a =
if (n = 0)
then a
else
if (n > 0)
then factIter (n-1) (a*n)
else raise Domain
in
factIter n 1
end;
(* 3.4.2.1 Programming with lists - Thinking recursively *)
fun length' [] = 0
| length' (x::xs) = 1 + length' xs;
inspect (length' ["a", "b", "c"]);
fun append' [] ys = ys
| append' (x::xs) ys = x :: (append' xs ys);
inspect (append' [1, 2, 3] [4, 5, 6]);
(* 3.4.2.2 Programming with lists - Recursive functions and their domains *)
fun nth' xs n if (n = 1) = hd xs
| nth' xs n if (n > 1) = nth' (tl xs) (n - 1)
| nth' xs n = raise Domain;
inspect (nth' ["a", "b", "c", "d"] 5) handle Empty => ();
inspect (nth' [1, 2, 3] 2);
fun sumList [] = 0
| sumList (x::xs) = x + sumList(xs);
inspect (sumList [1, 2, 3]);
(* 3.4.2.3 Programming with lists - Naive implementations are often slow *)
fun reverse [] = []
| reverse (x::xs) = append' (reverse xs) [x];
(* 3.4.2.4 Programming with lists - Converting recursive to iterative computations *)
fun length' [] = 0
| length' (x::xs) = 1 + length' xs;
fun iterLength i [] = i
| iterLength i (_::xs) = iterLength (i + 1) (xs);
local
fun iterLength i [] = i
| iterLength i (_::xs) = iterLength (i + 1) (xs)
in
fun length' xs =
iterLength 0 xs
end;
local
fun iterReverse rs [] = rs
| iterReverse rs (y::yr) = iterReverse (y::rs) yr
in
fun reverse xs =
iterReverse [] xs
end;
(* 3.4.2.6 Programming with lists - Constructing programs by following the type *)
datatype 'a nestedlist = Leaf of 'a
| Branch of 'a nestedlist list
fun lengthL (Branch []) = 0
| lengthL (Branch (x::xs)) = lengthL(x) + lengthL(Branch xs)
| lengthL (Leaf x) = 1
fun lengthL2 (Branch []) = 1
| lengthL2 (Branch (x::xs)) = lengthL2(x) + lengthL2(Branch xs)
| lengthL2 (Leaf x) = 1
val x = Branch [
Branch [Leaf 1, Leaf 2],
Leaf 4,
Branch [],
Branch [Branch [Leaf 5], Leaf 10]
];
inspect (lengthL x);
inspect (lengthL2 x);
(* additional info *)
(* lengthL is the same as counting the number of leaves *)
fun leaves (Leaf _) = 1
| leaves (Branch kids) = foldl op+ 0 (map leaves kids)
val x = Branch [
Branch [Leaf "hello"],
Leaf "lovely",
Branch [Leaf "world", Leaf "!"]];
inspect (leaves x);
(* end additional info *)
(* 3.4.2.7 Programming with lists - Sorting with mergesort *)
(* note: probably need to convert these to iterative form *)
fun merge (nil, ys) = ys
| merge (xs, nil) = xs
| merge (x::xs, y::ys) =
if (x < y)
then x::merge(xs, y::ys)
else y::merge(x::xs, ys)
fun split nil = (nil, nil)
| split (x::nil) = ([x], nil)
| split (x::y::xs) =
let
val (ys, zs) = split xs
in
(x::ys, y::zs)
end
fun mergesort nil = nil
| mergesort (x::nil) = [x]
| mergesort xs =
let
val (ys, zs) = split xs
in
merge(mergesort ys, mergesort zs)
end;
inspect (mergesort [3,2,4,1]);
(* 3.4.3 Programming with lists - Accumulators *)
datatype 'a expression = Item of 'a
| Plus of 'a expression * 'a expression;
datatype 'a compiled = CLeaf
| CPlus of 'a compiled
| CPush of 'a * 'a compiled
fun exprcode(Plus(a, b), c1, cn, s1, sn) =
let
val c2 = CPlus c1
val s2 = s1 + 1
val c3 = promise()
val s3 = promise()
in
exprcode(b, c2, c3, s2, s3);
exprcode(a, future c3, cn, future s3, sn)
end
| exprcode(Item i, c1, cn, s1, sn) =
let
in
cn ?= CPush(i, c1);
sn ?= s1 + 1
end
val code = promise()
val siz = promise()
val _ = exprcode(Plus(Plus(Item "a", Item "3"), Item "b"), CLeaf, code, 0, siz);
inspect (future code);
inspect (future siz);
fun merge (nil, ys) = ys
| merge (xs, nil) = xs
| merge (x::xs, y::ys) =
if (x < y)
then x::merge(xs, y::ys)
else y::merge(x::xs, ys)
fun mergesort xs =
let
fun mergesortacc(xs, 0) = (nil, xs)
| mergesortacc(x::xs, 1) = ([x], xs)
| mergesortacc(xs, n) =
let
val nl = n div 2
val nr = n - nl
val (ys, x2) = mergesortacc(xs, nl)
val (zs, x3) = mergesortacc(x2, nr)
in
(merge(ys, zs), x3)
end
val (sorted, _) = mergesortacc(xs, length xs)
in
sorted
end;
inspect (mergesort [3,2,4,1]);
(* 3.4.4 Programming with lists - Difference lists *)
fun appendD(d1, d2) =
let
val (s1, p1) = d1
val (s2, p2) = d2
in
fulfill(p1, s2);
(s1, p2)
end;
val px = promise()
val py = promise();
inspect (appendD((1::2::3::future(px), px), (4::5::future(py), py)));
fun append' (nil, ys) = ys
| append' (x::xs, ys) = x::append'(xs, ys);
datatype 'a nestedlist = Leaf of 'a
| Branch of 'a nestedlist list
fun flatten (Leaf x) = [x]
| flatten (Branch nil) = nil
| flatten (Branch (x::xs)) = append'(flatten x, flatten (Branch xs))
val x = Branch [
Branch [Leaf #"a", Leaf #"b"],
Branch [Branch [Leaf #"c"], Branch [Leaf #"d"]],
Branch [],
Branch [Leaf #"e", Branch [Leaf #"f"]]];
inspect (flatten x);
fun flatten xs =
let
fun flattenD (Branch nil, e) = e
| flattenD (Branch ((Branch x)::xr), e) = flattenD(Branch x, flattenD(Branch xr, e))
| flattenD (Branch ((Leaf x)::xr), e) = x::flattenD(Branch xr, e)
| flattenD (Leaf x, e) = x::e
in
flattenD(xs, [])
end
fun flatten xs =
let
fun flattenD (Branch nil, ds) =
let
val (s, e) = ds
in
fulfill(s, e)
end
| flattenD (Branch ((Branch x)::xr), ds) =
let
val (s, e) = ds
val y2 = promise()
in
flattenD(Branch x, (s, future(y2)));
flattenD(Branch xr, (y2, e))
end
| flattenD (Branch ((Leaf x)::xr), ds) =
let
val (s, e) = ds
val y1 = promise()
in
fulfill(s, x::(future y1));
flattenD(Branch xr, (y1, e))
end
| flattenD (Leaf x, ds) =
let
val (s, e) = ds
in
fulfill(s, x::e)
end
val s = promise()
in
flattenD(xs, (s, []));
future(s)
end
fun flatten xs =
let
fun flattenD (Branch nil, s, e) = fulfill(s, e)
| flattenD (Branch ((Branch x)::xr), s, e) =
let
val y2 = promise()
in
flattenD(Branch x, s, future(y2));
flattenD(Branch xr, y2, e)
end
| flattenD (Branch ((Leaf x)::xr), s, e) =
let
val y1 = promise()
in
fulfill(s, x::(future y1));
flattenD(Branch xr, y1, e)
end
| flattenD (Leaf x, s, e) = fulfill(s, x::e)
val s = promise()
in
flattenD(xs, s, []);
future(s)
end
fun flatten xs =
let
fun flattenD (Branch nil, e) = e
| flattenD (Branch ((Branch x)::xr), e) = flattenD(Branch x, flattenD(Branch xr, e))
| flattenD (Branch ((Leaf x)::xr), e) = x::flattenD(Branch xr, e)
| flattenD (Leaf x, e) = x::e
in
flattenD(xs, [])
end
fun reverse' xs =
let
fun reverseD (Branch nil, y1, y) = fulfill(y1, y)
| reverseD (Branch (x::xr), y1, Branch y) =
reverseD(Branch xr, y1, Branch (x::y))
| reverseD (Leaf x, y1, y) = fulfill(y1, Leaf x)
val y1 = promise()
in
reverseD(xs, y1, Branch nil);
future(y1)
end
(* 3.4.5 Queues *)
(* naive queue *)
fun butLast ([y], x, l1) =
let
val _ = fulfill(x, y)
val _ = fulfill(l1, [])
in
(future x, future l1)
end
| butLast (y::l2, x, l1) =
let
val l3 = promise()
val _ = fulfill(l1, y::(future l3))
in
butLast (l2, x, l3);
(future(x), future(l1))
end
| butLast ([], x, l1) = raise Empty
val x = [1, 2, 3, 4];
inspect (butLast(x, promise(), promise()));
(* amortized constant-time ephemeral queue *)
datatype 'a queue = Queue of 'a list * 'a list
fun newQueue () = Queue(nil, nil)
fun checkQ (Queue(nil, r)) = Queue(reverse r, nil)
| checkQ q = q
fun insertQ (Queue(f, r), x) = checkQ(Queue(f, x::r))
fun deleteQ (Queue(f::fs, r), px) =
let
val _ = fulfill(px, f)
in
checkQ(Queue(fs, r))
end
| deleteQ (Queue([], r), px) = raise Empty
fun isEmpty' (Queue(f::fs, r)) = false
| isEmpty' (Queue([], r)) = true
val q1 = newQueue()
val q2 = insertQ(q1, "peter")
val q3 = insertQ(q2, "paul");
val p4 = promise()
val q4 = deleteQ(q3, p4);
inspect (future p4);
val q5 = insertQ(q4, "mary")
val p6 = promise()
val q6 = deleteQ(q5, p6);
inspect (future p6);
val p7 = promise()
val q7 = deleteQ(q6, p7);
inspect (future p7);
(* Worst-case constant-time ephemeral queue *)
datatype 'a queue = Queue of int * 'a promise list promise * 'a promise list promise
fun newQueue () =
let
val x = promise()
in
Queue(0, x, x)
end
fun insertQ (Queue(n, s, e), x) if (n >= 0) =
let
val e1 = promise()
val px = promise()
in
fulfill(px, x);
fulfill(e, px::(future e1));
Queue(n+1, s, e1)
end
| insertQ (Queue(n, s, e), x) if (n = ~1) =
let
val e1 = promise()
val px = hd(future e)
in
fulfill(px, x);
Queue(n+1, e1, e1)
end
| insertQ (Queue(n, s, e), x) =
let
val e1 = promise()
val px = hd(future e)
in
fulfill(px, x);
fulfill(e1, tl(future e));
Queue(n+1, s, e1)
end
fun deleteQ (Queue(n, s, e), px) if (n <= 0) =
let
val s1 = promise()
in
fulfill(s, px::(future s1));
Queue(n-1, s1, e)
end
| deleteQ (Queue(n, s, e), px) if (n = 1) =
let
val s1 = promise()
in
fulfill(px, future (hd(future s)));
Queue(n-1, s1, s1)
end
| deleteQ (Queue(n, s, e), px) =
let
val s1 = promise()
in
fulfill(px, future (hd(future s)));
fulfill(s1, tl(future s));
Queue(n-1, s1, e)
end
fun isEmpty' (Queue(n, s, e)) = (n = 0)
val q1 = newQueue()
val q2 = insertQ(q1, "peter")
val q3 = insertQ(q2, "paul")
val p4 = promise()
val q4 = deleteQ(q3, p4);
inspect (future p4);
val p5 = promise()
val q5 = deleteQ(q4, p5);
inspect (future p5);
val p6 = promise()
val q6 = deleteQ(q5, p6);
inspect (future p6);
val q7 = insertQ(q6, "mary");
(* persistent queues *)
fun forkD (d, e, f) =
let
val (d1, _) = d
val (e1, e0) = e
val (f1, f0) = f
in
(* need to figure out what {Append D1 E0 E1} does in Oz
appendD(appendD(d1, e0), e1);
appendD(appendD(d1, f0), f1);
*)
d
end
fun forkQ (Queue(n, s, e)) =
let
val s1 = promise()
val s2 = promise()
val e1 = promise()
val e2 = promise()
val q1 = Queue(n, s1, e1)
val q2 = Queue(n, s2, e2)
in
forkD((s, e), (s1, e1), (s2, e2));
(q1, q2)
end
| forkQ (_) = raise Empty;
val q1 = newQueue()
val q2 = insertQ(q1, "peter")
val (qa, qb) = forkQ(q2);
inspect qa;
inspect qb;
(* 3.4.6.2 Trees - Storing information in trees *)
datatype ('a, 'b) obtree = Leaf
| Tree of 'a * 'b * ('a, 'b) obtree * ('a, 'b) obtree
val xtree = Tree(#"c", 10, Tree(#"a", 20, Leaf, Leaf), Tree(#"e", 30, Leaf, Leaf));
fun lookupOBT (x, Leaf, lt) = NONE
| lookupOBT (x, Tree(y, v, t1, t2), lt) =
if (lt(x, y))
then lookupOBT(x, t1, lt)
else
if (lt(y, x))
then lookupOBT(x, t2, lt)
else SOME v;
inspect (lookupOBT(#"c", xtree, op<));
inspect (lookupOBT(#"a", xtree, op<));
inspect (lookupOBT(#"e", xtree, op<));
inspect (lookupOBT(#"b", xtree, op<));
fun lookupOBT (x, Leaf, lt) = NONE
| lookupOBT (x, Tree(y, v, t1, t2), lt) if (lt(x, y)) =
lookupOBT(x, t1, lt)
| lookupOBT (x, Tree(y, v, t1, t2), lt) if (lt(y, x)) =
lookupOBT(x, t2, lt)
| lookupOBT (x, Tree(y, v, t1, t2), lt) = SOME v;
inspect (lookupOBT(#"c", xtree, op<));
inspect (lookupOBT(#"a", xtree, op<));
inspect (lookupOBT(#"e", xtree, op<));
inspect (lookupOBT(#"b", xtree, op<));
fun insertOBT (x, v, Leaf, lt) = Tree(x, v, Leaf, Leaf)
| insertOBT (x, v, Tree(y, w, t1, t2), lt) if (lt(x, y)) =
Tree(y, w, insertOBT(x, v, t1, lt), t2)
| insertOBT (x, v, Tree(y, w, t1, t2), lt) if (lt(y, x)) =
Tree(y, w, t1, insertOBT(x, v, t2, lt))
| insertOBT (x, v, Tree(y, w, t1, t2), lt) =
Tree(x, v, t1, t2);
inspect (insertOBT(#"b", 15, xtree, op<));
(* 3.4.6.3 Trees - Deletion and tree reorganization *)
fun deleteSubTree (x, Leaf, lt) = Leaf
| deleteSubTree (x, Tree(y, w, t1, t2), lt) if (lt(x, y)) =
Tree(y, w, deleteSubTree(x, t1, lt), t2)
| deleteSubTree (x, Tree(y, w, t1, t2), lt) if (lt(y, x)) =
Tree(y, w, t1, deleteSubTree(x, t2, lt))
| deleteSubTree (x, Tree(y, w, t1, t2), lt) = Leaf;
inspect (deleteSubTree(#"c", xtree, op<));
fun removeSmallest (Leaf) = NONE
| removeSmallest (Tree(y, v, t1, t2)) =
let
val tx = removeSmallest(t1)
in
case tx of
NONE => SOME (y, v, t2)
| SOME (yp, vp, tp) => SOME (yp, vp, Tree(y, v, tp, t2))
end
fun deleteOBT (x, Leaf, lt) = Leaf
| deleteOBT (x, Tree(y, w, t1, t2), lt) if (lt(x, y)) =
Tree(y, w, deleteOBT(x, t1, lt), t2)
| deleteOBT (x, Tree(y, w, t1, t2), lt) if (lt(y, x))=
Tree(y, w, t1, deleteOBT(x, t2, lt))
| deleteOBT (x, Tree(y, w, t1, t2), lt) =
let
val tx = removeSmallest(t2)
in
case tx of
NONE => t1
| SOME (yp, vp, tp) => Tree(yp, vp, t1, tp)
end;
inspect (deleteOBT(#"c", xtree, op<));
(* 3.4.6.4 Trees - Tree traversal *)
(* Depth-first traversal *)
fun dfs (Leaf) = ()
| dfs (Tree(key, v, l, r)) = (inspect (key:char, v:int); dfs l; dfs r);
dfs(xtree);
fun dfsAccLoop (Leaf, s1, sn) = fulfill(sn, future s1)
| dfsAccLoop (Tree(key, v, l, r), s1, sn) =
let
val s2 = promise()
val s3 = promise()
in
fulfill(s2, (key, v)::(future s1));
dfsAccLoop(l, s2, s3);
dfsAccLoop(r, s3, sn)
end
fun dfsAcc t =
let
val s1 = promise()
val sn = promise()
in
fulfill(s1, nil);
dfsAccLoop(t, s1, sn);
reverse(future sn)
end;
inspect (dfsAcc(xtree));
fun dfsAccLoop2 (Leaf, s1, sn) = fulfill(s1, future sn)
| dfsAccLoop2 (Tree(key, v, l, r), s1, sn) =
let
val s2 = promise()
val s3 = promise()
in
fulfill(s1, (key, v)::(future s2));
dfsAccLoop2(l, s2, s3);
dfsAccLoop2(r, s3, sn)
end
fun dfsAcc2 t =
let
val s1 = promise()
val sn = promise()
in
fulfill(sn, []);
dfsAccLoop2(t, s1, sn);
future s1
end;
inspect (dfsAcc2(xtree));
(* Breath-first traversal *)
fun bfs t =
let
fun treeInsert (q, Leaf) = q
| treeInsert (q, t) = insertQ(q, t)
fun bfsQueue q1 =
if (isEmpty' q1)
then ()
else
let
val x = promise()
val q2 = promise()
in
fulfill(q2, deleteQ(q1, x));
case future x of
Tree(key, v, l, r) => (
inspect (key:char, v:int);
bfsQueue(treeInsert(treeInsert(future q2, l), r)))
| Leaf => ()
end
in
bfsQueue(treeInsert(newQueue(), t))
end;
bfs(xtree);
fun bfsAcc t =
let
fun treeInsert (q, Leaf) = q
| treeInsert (q, t) = insertQ(q, t)
fun bfsQueue (q1, s1, sn) =
if (isEmpty' q1)
then fulfill(s1, future sn)
else
let
val x = promise()
val q2 = promise()
val s2 = promise()
in
fulfill(q2, deleteQ(q1, x));
case future x of
Tree(key, v, l, r) => (
fulfill(s1, (key, v)::(future s2));
bfsQueue(treeInsert(treeInsert(future q2, l), r), s2, sn))
| Leaf => ()
end
val s1 = promise()
val sn = promise()
in
fulfill(sn, nil);
bfsQueue(treeInsert(newQueue(), t), s1, sn);
future s1
end;
inspect (bfsAcc(xtree));
fun dfs t =
let
fun treeInsert (s, Leaf) = s
| treeInsert (s, t) = t::s
fun dfsStack (Tree(key, v, l, r)::s) = (
inspect (key:char, v:int);
dfsStack(treeInsert(treeInsert(s, r), l)))
| dfsStack _ = ()
in
dfsStack(treeInsert(nil, t))
end;
dfs(xtree);
(* 3.4.7 Trees - Drawing Trees *)
(* Don't like the Oz Adjoin function - so I just attached the coordinates directly in the tree *)
datatype ('a, 'b, 'c) obtree = Leaf
| Tree of { key : 'a,
value : 'b,
x : 'c promise,
y : 'c promise,
left : ('a, 'b, 'c) obtree,
right : ('a, 'b, 'c) obtree }
val scale = 30
fun depthFirst (Tree{x, y, left=Leaf, right=Leaf, ...}, level, leftLim, rootX, rightLim) =
let
in
fulfill(x, future rootX);
fulfill(rootX, future rightLim);
fulfill(rightLim, future leftLim);
fulfill(y, scale * level)
end
| depthFirst (Tree{x, y, left, right=Leaf, ...}, level, leftLim, rootX, rightLim) =
let
in
fulfill(x, future rootX);
fulfill(y, scale * level);
depthFirst(left, level+1, leftLim, rootX, rightLim)
end
| depthFirst (Tree{x, y, left=Leaf, right, ...}, level, leftLim, rootX, rightLim) =
let
in
fulfill(x, future rootX);
fulfill(y, scale * level);
depthFirst(right, level+1, leftLim, rootX, rightLim)
end
| depthFirst (Tree{x, y, left, right, ...}, level, leftLim, rootX, rightLim) =
let
val lRootX = promise()
val rRootX = promise()
val lRightLim = promise()
val rLeftLim = promise()
in
fulfill(y, scale * level);
depthFirst(left, level+1, leftLim, lRootX, lRightLim);
fulfill(rLeftLim, scale + (future lRightLim));
depthFirst(right, level+1, rLeftLim, rRootX, rightLim);
fulfill(x, future rootX);
fulfill(rootX, (future lRootX + future rRootX) div 2)
end
| depthFirst (Leaf, _, _, _, _) = ();
val xtree = Tree{key=(#"a"), value=111, x=promise(), y=promise(),
left=Tree{key=(#"b"), value=55, x=promise(), y=promise(),
left=Tree{key=(#"x"), value=100, x=promise(), y=promise(),
left=Tree{key=(#"z"), value=56, x=promise(), y=promise(),
left=Leaf,
right=Leaf},
right=Tree{key=(#"w"), value=23, x=promise(), y=promise(),
left=Leaf,
right=Leaf}},
right=Tree{key=(#"y"), value=105, x=promise(), y=promise(),
left=Leaf,
right=Tree{key=(#"r"), value=77, x=promise(), y=promise(),
left=Leaf,
right=Leaf}}},
right=Tree{key=(#"c"), value=123, x=promise(), y=promise(),
left=Tree{key=(#"d"), value=119, x=promise(), y=promise(),
left=Tree{key=(#"g"), value=44, x=promise(), y=promise(),
left=Leaf,
right=Leaf},
right=Tree{key=(#"h"), value=50, x=promise(), y=promise(),
left=Tree{key=(#"i"), value=5, x=promise(), y=promise(),
left=Leaf,
right=Leaf},
right=Tree{key=(#"j"), value=6, x=promise(), y=promise(),
left=Leaf,
right=Leaf}}},
right=Tree{key=(#"e"), value=133, x=promise(), y=promise(),
left=Leaf,
right=Leaf}}}
val leftLim = promise();
fulfill(leftLim, scale);
depthFirst(xtree, 1, leftLim, promise(), promise());
inspect xtree;
(* 3.4.8 Trees - Parsing *)
(* Not finished - skipping over this section for the time being *)
fun isInt s = foldl (fn (x,y) => Char.isDigit(x) andalso y) true (explode (future s))
fun isIdent s = foldl (fn (x,y) => Char.isAlphaNum(x) andalso y) true (explode (future s))
fun id (s1, sn) =
let
val x = promise()
in
fulfill(x, hd (future s1));
(x)
end
fun cop y =
case y of
"<" => true
| ">" => true
| "=<" => true
| ">=" => true
| "==" => true
| "!=" => true
| _ => false
fun eop y =
case y of
"+" => true
| "-" => true
| _ => false
fun top y =
case y of
"*" => true
| "/" => true
| _ => false
fun sequence (nonterm, sep, s1, sn) =
let
val s2 = promise()
val s3 = promise()
val x1 = nonterm(s1, s2)
val t = hd(future s2)
in
fulfill(s3, tl(future s2));
if (sep(t))
then
let
val x2 = sequence(nonterm, sep, s3, sn)
in
(* T(X1 X2) in Oz - not sure how to make consisten return type *)
(x1)
end
else
let
val _ = fulfill(s2, future sn)
in
(x1)
end
end
fun comp (s1, sn) = sequence(expr, cop, s1, sn)
and expr (s1, sn) = sequence(term, eop, s1, sn)
and term (s1, sn) = sequence(fact, top, s1, sn)
and fact (s1, sn) =
let
val t = promise()
val s2 = promise()
in
fulfill(t, hd(future s1));
fulfill(s2, tl(future s1));
if (isInt(t) orelse isIdent(t))
then
let
val _ = fulfill(sn, future s2)
in
(t)
end
else
let
val e = promise()
val s4 = promise()
val s3 = promise()
in
(* S1 = '('|S4 - not quite there *)
fulfill(s4, tl(future s1));
e = expr(s4, s3);
(* S3 = ')'|Sn - not quite there *)
fulfill(s3, tl(future sn));
(e)
end
end
fun prog (s1, sn) =
let
val y = promise()
val z = promise()
val s2 = promise()
val s3 = promise()
val s4 = promise()
val s5 = promise()
in
fulfill(s1, "program"::(future s2));
fulfill(y, id(s2, 34));
fulfill(s3, ";"::(future s4))
end
(* Here's the Oz code (unverified)
declare
fun {IsIdent X} { IsAtom X } end
fun {Id S1 Sn} X in S1=X|Sn true={IsIdent X} X end
fun {COP Y}
Y=='<' orelse Y=='>' orelse Y=='=<' orelse
Y=='>=' orelse Y=='==' orelse Y=='!='
end
fun {EOP Y} Y=='+' orelse Y=='-' end
fun {TOP Y} Y=='*' orelse Y=='/' end
fun {Sequence NonTerm Sep S1 Sn}
X1 S2 T S3 in
X1={NonTerm S1 S2}
S2=T|S3
if {Sep T} then X2 in
X2={Sequence NonTerm Sep S3 Sn}
T(X1 X2) % Dynamic Record Creation
else
S2=Sn
X1
end
end
fun {Comp S1 Sn} {Sequence Expr COP S1 Sn} end
fun {Expr S1 Sn} {Sequence Expr EOP S1 Sn} end
fun {Term S1 Sn} {Sequence Expr TOP S1 Sn} end
fun {Fact S1 Sn}
T|S2=S1 in
if {IsInt T} orelse {IsIdent T} then
S2=Sn
T
else E S2 S3 in
S1='('|S2
E={Expr S2 S3}
S3=')'|Sn
E
end
end
fun {Stat S1 Sn}
T|S2=S1 in
case T
of begin then
{Sequence Stat fun {$ X} X==';' end S2 'end'|Sn}
[] 'if' then C X1 X2 S3 S4 S5 S6 in
{Comp C S2 S3}
S3='then'|S4
X1={Stat S4 S5}
S5='else'|S6
X2={Stat S4 S5}
'if'(C X1 X2)
[] while then C X S3 S4 in
C={Comp S2 S3}
S3='do'|S4
X={Stat S4 Sn}
while(C X)
[] read then I in
I={Id S2 Sn}
read(I)
[] write then E in
E={Expr S2 Sn}
write(E)
elseif {IsIdent T} then E S3 in
S2=':='|S3
E={Expr S3 Sn}
assign(T E)
else
S1=Sn
raise error(S1) end
end
end
fun {Prog S1 Sn}
Y Z S2 S3 S4 S5 in
S1=program|S2
Y={Id S2 S3}
S3=';'|S4
Z={Stat S2 S5}
S5='end'|Sn
prog(Y Z)
end
declare A Sn in
A = {Prog
[program foo ';'
while a '+' 3 '<'b 'do' b ':=' b '+' 1 'end']
Sn}
{Browse A}
% local R={MakeRecord T [1 2]} in X1=R.1 X2=R.2 R end
*)
(* 3.5.1 Time and space efficiency - Execution time *)
fun append' (nil, ys) = ys
| append' (x::xs, ys) = x::append'(xs, ys)
fun append' (nil, ys, zs) = fulfill(zs, ys)
| append' (x::xr, ys, zs) =
let
val zr = promise()
in
fulfill(zs, x::(future zr));
append'(xr, ys, zr)
end
fun shiftLeft [] = [0]
| shiftLeft (n::ns) = n::shiftLeft(ns);
fun shiftRight ns = 0::ns;
fun addList [] _ = []
| addList _ [] = []
| addList (n1::ns1) (n2::ns2) = (n1 + n2)::(addList ns1 ns2)
fun fastPascal 1 = [1]
| fastPascal n =
let
val ns = fastPascal(n-1)
in
addList (shiftLeft ns) (shiftRight ns)
end
fun mergesort nil = nil
| mergesort (x::nil) = [x]
| mergesort xs =
let
val (ys, zs) = split xs
in
merge(mergesort ys, mergesort zs)
end;
(* 3.6.1 Higher-order programming - Basic operations *)
let
val a = 1.0
val b = 3.0
val c = 2.0
val d = b*b - 4.0*a*c
val realSol = promise()
val x1 = promise()
val x2 = promise()
in
if (d >= 0.0)
then (
fulfill(realSol, true);
fulfill(x1, (~b + Math.sqrt(d))/(2.0*a));
fulfill(x2, (~b - Math.sqrt(d))/(2.0*a))
)
else (
fulfill(realSol, false);
fulfill(x1, ~b/(2.0*a));
fulfill(x2, Math.sqrt(d)/(2.0*a))
)
end;
fun quadraticEquation (a, b, c) =
let
val d = b*b - 4.0*a*c
in
if (d >= 0.0)
then (true, (~b + Math.sqrt(d))/(2.0*a), (~b - Math.sqrt(d))/(2.0*a))
else (false, ~b/(2.0*a), Math.sqrt(d)/(2.0*a))
end;
inspect (quadraticEquation(1.0, 3.0, 2.0));
fun sumList nil = 0
| sumList (x::xs) = x + sumList(xs)
fun foldr' nil f u = u
| foldr' (x::xs) f u = f (x, foldr' xs f u)
fun sumList xs =
foldr' xs (fn (x, y) => x + y) 0
fun prodList xs =
foldr' xs (fn (x, y) => x * y) 0
fun some xs =
foldr' xs (fn (x, y) => x orelse y) false
fun genericMergeSort f xs =
let
fun merge (nil, ys) = ys
| merge (xs, nil) = xs
| merge (x::xr as xs, y::yr as ys) =
if f(x, y)
then x::merge(xr, ys)
else y::merge(xs, yr)
fun mergesort nil = nil
| mergesort (x::nil) = [x]
| mergesort xs =
let
val (ys, zs) = split xs
in
merge(mergesort ys, mergesort zs)
end
in
mergesort xs
end
fun mergesort xs = genericMergeSort (fn (a, b) => a < b) xs
fun makeSort f = genericMergeSort f
(* 3.6.2 Higher-order programming - Loop abstractions *)
fun for a b s f =
let
fun loopup c if (c <= b) = (f c; loopup (c+s))
| loopup c = ()
fun loopdown c if (c >= b) = (f c; loopdown (c+s))
| loopdown c = ()
in
if (s > 0)
then loopup a
else
if (s < 0)
then loopdown a
else ()
end;
for 1 10 1 inspect;
for 10 1 ~2 inspect;
fun forall nil f = ()
| forall (x::xs) f = (f x; forall xs f);
forall [#"a",#"b",#"c"] inspect;
fun foracc inx a b s f =
let
fun loopup (c, inx) if (c <= b) = loopup(c+s, f(inx, c))
| loopup (c, inx) = inx
fun loopdown (c, inx) if (c <= b) = loopdown(c+s, f(inx, c))
| loopdown (c, inx) = inx
in
if (s > 0)
then loopup(a, inx)
else
if (s < 0)
then loopup(a, inx)
else raise Domain
end;
inspect (foracc 0 1 10 1 (fn (x,y) => x+y));
fun forallacc inx nil f = inx
| forallacc inx (x::xs) f = forallacc (f(inx, x)) xs f;
inspect (forallacc 0 [1,2,3,4] (fn (x,y) => x+y));
fun foldl' f u nil = u
| foldl' f u (x::xs) = foldl' f (f(u,x)) xs;
inspect (foldl' (fn (x,y) => x+y) 0 [1,2,3,4]);
fun foldr' f u xs =
let
fun loop (u, nil) = u
| loop (u, x::xs) = loop(f(u,x), xs)
in
loop(u, reverse xs)
end;
inspect (foldr' (fn (x,y) => x+y) 0 [1,2,3,4]);
(* foldr that doesn't require a reverse *)
fun foldr' f u nil = u
| foldr' f u (x::xs) = f(x, foldr' f u xs);
inspect (foldr' (fn (x,y) => x+y) 0 [1,2,3,4]);
(* 3.6.3 Higher-order programming - Linquistic support for loops *)
(* Note: ML does not sport linguistic support for declarative loops *)
val ps = {name="hello", price=2000, coordinates=(1,2)} ::
{name="alice", price=200, coordinates=(3,4)} :: []
(* pattern matching loop via recursive function *)
fun patternloop nil = ()
| patternloop ({name=n, price=p, coordinates=c}::xs) = (
if (p < 1000)
then inspect (n:string)
else ();
patternloop(xs));
patternloop(ps);
(* pattern matching loop via anonymous recursive function *)
(rec f => fn nil => ()
| ({name=n, price=p, coordinates=c}::xs) => (
if (p < 1000)
then inspect (n:string)
else ();
f(xs)))
ps;
(* pattern matching loop via while state loop *)
let
val xr = ref ps
in
while (null(!xr)) do
let
val {name=n, price=p, coordinates=c} = hd (!xr)
in
if (p < 1000)
then inspect n
else ();
xr := tl (!xr)
end
end;
(* collecting via recursive function *)
fun collectloop (i, b, f) if (i > b) = []
| collectloop (i, b, f) = (f i)@collectloop(i+1, b, f)
val c = fn i => if (i mod 2 <> 0) andalso (i mod 3 <> 0) then [i] else [];
inspect (collectloop(1, 1000, c));
(* using foracc iterator *)
inspect (foracc [] 1 1000 1 (fn (a, i) => a @ c(i)));
(* collection via nested recursive functions *)
fun collectnested i if (i > 1000) = []
| collectnested i =
let
fun collectinner j if (j > 10) = []
| collectinner j =
if (i mod j = 0)
then [(i, j)] @ collectinner(j+1)
else collectinner(j+1)
in
if (i mod 2 <> 0) andalso (i mod 3 <> 0)
then (collectinner 2) @ collectnested(i+1)
else collectnested(i+1)
end;
inspect (collectnested 1);
(* 3.6.4.1 Higher-order programming - List-based techniques *)
fun map' f nil = nil
| map' f (x::xs) = (f x)::(map' f xs);
inspect (map' (fn i => i*i) [1,2,3]);
fun map' f xs =
foldr' (fn (i, a) => (f i)::a) nil xs;
inspect (map' (fn i => i*i) [1,2,3]);
fun filter' f nil = nil
| filter' f (x::xs) =
if (f x)
then x::(filter' f xs)
else (filter' f xs);
inspect (filter' (fn a => (a < 3)) [1,2,3,4]);
fun filter' f xs =
foldr' (fn (i, a) => if (f i) then i::a else a) nil xs;
inspect (filter' (fn a => (a < 3)) [1,2,3,4]);
fun foldr' f u xs =
#2(iterate
(fn (xr, a) => (tl xr, f (hd xr, a)))
(fn (xr, a) => null xr)
(reverse xs, u));
inspect (foldr' (fn (x,y) => x+y) 0 [1,2,3,4]);
(* 3.6.4.2 Higher-order programming - Tree-based techniques *)
datatype 'a tree = Tree of {node:'a, sons:'a tree list}
val ts = Tree{node=1,
sons=[Tree{node=2, sons=nil},
Tree{node=3, sons=[Tree{node=4, sons=nil}]}]}
fun dfs (Tree{node=n, sons=xs}) = (
inspect (n:int);
forall xs dfs);
dfs ts;
fun visitnodes f (t as Tree{sons=xs, ...}) = (
f t;
forall xs (visitnodes f));
visitnodes (fn (Tree{node=n, ...}) => inspect n) ts;
fun visitlinks f (t as Tree{sons=xs, ...}) =
forall xs (f t; visitnodes f);
visitlinks (fn Tree{node=n, ...} => inspect n) ts;
fun foldtreer tf lf u nil = u
| foldtreer tf lf u (x::xs) =
lf(foldtree tf lf u x, foldtreer tf lf u xs)
and foldtree tf lf u (Tree{node=n, sons=xs}) =
tf(n, (foldtreer tf lf u xs))
fun add (a, b) = a + b;
inspect (foldtree add add 0 ts);
(* 3.6.6 Higher-order programming - Currying *)
fun max' x y =
if (x >= y) then x else y
fun max' x =
fn y => if (x >= y) then x else y;
inspect ((max' 10) 20);
val lowerbound10 = max' 10
fun lowerbound10 y =
max' 10 y
(* 3.7.1 Abstract data types - A declarative stack *)
signature STACK' =
sig
type t
type stack
val newStack : unit -> stack
val push : stack * t -> stack
val pop : stack * t promise -> stack
val isEmpty : stack -> bool
end
structure Stack' : STACK' =
struct
type t = int
type stack = t list
fun newStack () = nil
fun push (s, e) = e::s
fun pop (nil, e) = raise Empty
| pop (x::xs, e) = (
fulfill(e, x);
xs)
fun isEmpty nil = true
| isEmpty _ = false
end;
let
val x = 123
val px = promise()
val sn = Stack'.newStack()
val s0 = Stack'.push(sn, x)
val s1 = Stack'.pop(s0, px)
in
assert (Stack'.isEmpty sn) of true;
assert (sn = s1) of true;
assert (x = future px) of true;
assert (Stack'.pop(sn, px); false) handle Empty => true of true
end;
structure Stack' : STACK' =
struct
type t = int
datatype stack = EmptyStack
| StackCons of t * stack
fun newStack () = EmptyStack
fun push (s, e) = StackCons(e, s)
fun pop (EmptyStack, e) = raise Empty
| pop (StackCons (x, s), e) = (
fulfill(e, x);
s)
fun isEmpty EmptyStack = true
| isEmpty _ = false
end;
let
val x = 123
val px = promise()
val sn = Stack'.newStack()
val s0 = Stack'.push(sn, x)
val s1 = Stack'.pop(s0, px)
in
assert (Stack'.isEmpty sn) of true;
assert (sn = s1) of true;
assert (x = future px) of true;
assert (Stack'.pop(sn, px); false) handle Empty => true of true
end;
(* a functional programming look *)
signature STACK' =
sig
type t
type stack
val newStack : unit -> stack
val push : stack * t -> stack
val pop : stack -> stack * t
val isEmpty : stack -> bool
end
structure Stack' : STACK' =
struct
type t = int
type stack = t list
fun newStack () = nil
fun push (s, e) = e::s
fun pop nil = raise Empty
| pop (x::xs) = (xs, x)
fun isEmpty nil = true
| isEmpty _ = false
end;
let
val x = 123
val sn = Stack'.newStack()
val s0 = Stack'.push(sn, x)
val (s1, y) = Stack'.pop(s0)
in
assert (Stack'.isEmpty sn) of true;
assert (sn = s1) of true;
assert (x = y) of true;
assert (Stack'.pop(sn); false) handle Empty => true of true
end;
structure Stack' : STACK' =
struct
type t = int
datatype stack = EmptyStack
| StackCons of t * stack
fun newStack () = EmptyStack
fun push (s, e) = StackCons(e, s)
fun pop (EmptyStack) = raise Empty
| pop (StackCons(x, s)) = (s, x)
fun isEmpty EmptyStack = true
| isEmpty _ = false
end;
let
val x = 123
val sn = Stack'.newStack()
val s0 = Stack'.push(sn, x)
val (s1, y) = Stack'.pop(s0)
in
assert (Stack'.isEmpty sn) of true;
assert (sn = s1) of true;
assert (x = y) of true;
assert (Stack'.pop(sn); false) handle Empty => true of true
end;
(* 3.7.2 Abstract data types - A declarative dictionary *)
signature DICTIONARY =
sig
type keytype
type valtype
type dictionary
val newDictionary : unit -> dictionary
val put : dictionary * keytype * valtype -> dictionary
val get : dictionary * keytype -> valtype option
val condGet : dictionary * keytype * valtype -> valtype
val domain : dictionary -> keytype list
end
structure Dictionary : DICTIONARY =
struct
type keytype = string
type valtype = int
type dictionary = (keytype * valtype) list
fun newDictionary () = nil
fun put (nil, key:keytype, value:valtype) = [(key, value)]
| put ((k, v)::ds, key, value) if (k = key) = (key, value)::ds
| put ((k, v)::ds, key, value) if (k > key) = (key, value)::(k, v)::ds
| put ((k, v)::ds, key, value) = (k, v)::put(ds, key, value)
fun get (nil, key:keytype) = NONE
| get ((k, v)::ds, key) if (k > key) = NONE
| get ((k, v)::ds, key) if (k = key) = SOME v
| get ((k, v)::ds, key) = get(ds, key)
fun condGet (nil, key:keytype, default:valtype) = default
| condGet ((k, v)::ds, key, default) if (k > key) = default
| condGet ((k, v)::ds, key, _) if (k = key) = v
| condGet ((k, v)::ds, key, default) = condGet(ds, key, default)
fun domain ds = map' (fn (x,y) => x) ds
end
structure Dictionary : DICTIONARY =
struct
type keytype = string
type valtype = int
datatype dictionary = Leaf
| Tree of keytype * valtype * dictionary * dictionary
fun newDictionary () = Leaf
fun put (Leaf, key, value) = Tree(key, value, Leaf, Leaf)
| put (Tree(k, v, l, r), key, value) if (key < k) = Tree(k, v, put(l, key, value), r)
| put (Tree(k, v, l, r), key, value) if (key > k) = Tree(k, v, l, put(r, key, value))
| put (Tree(k, v, l, r), key, value) = Tree(key, value, l, r)
fun get (Leaf, key) = NONE
| get (Tree(k, v, l, r), key) if (key < k) = get(l, key)
| get (Tree(k, v, l, r), key) if (key > k) = get(r, key)
| get (Tree(k, v, l, r), key) = SOME v
fun condGet (Leaf, key, default) = default
| condGet (Tree(k, v, l, r), key, default) if (key < k) = condGet(l, key, default)
| condGet (Tree(k, v, l, r), key, default) if (key > k) = condGet(r, key, default)
| condGet (Tree(k, v, l, r), key, default) = v
fun domain ds =
let
fun domainD (Leaf, s1, sn) = fulfill(s1, future sn)
| domainD (Tree(k, v, l, r), s1, sn) =
let
val s2 = promise()
val s3 = promise()
in
domainD(l, s1, s2);
fulfill(s2, k::(future s3));
domainD(r, s3, sn)
end
val d = promise()
val p = promise()
in
fulfill(p, nil);
domainD(ds, d, p);
future d
end
end
(* 3.7.3 Abstract data types - A word frequency application *)
fun wordChar c =
(#"a" <= c andalso c <= #"z") orelse
(#"A" <= c andalso c <= #"Z") orelse
(#"0" <= c andalso c <= #"9")
fun stringToAtom pw = implode pw
fun wordToAtom pw =
stringToAtom (List.rev pw)
fun incWord (d, w) =
Dictionary.put(d, w, Dictionary.condGet(d, w, 0) + 1)
fun charsToWords (nil, nil) = nil
| charsToWords (pw, nil) = [wordToAtom pw]
| charsToWords (pw, c::cs) if (wordChar c) =
charsToWords ((Char.toLower c)::pw, cs)
| charsToWords (nil, c::cs) = charsToWords(nil, cs)
| charsToWords (pw, c::cs) =
(wordToAtom pw)::(charsToWords(nil, cs))
fun countWords (d, w::ws) = countWords(incWord(d, w), ws)
| countWords (d, nil) = d
fun wordFreq cs =
countWords(Dictionary.newDictionary(), charsToWords(nil, cs));
let
val t = "Oh my darling, oh my darling. oh my darling Clementine." ^
"She is lost and gone forever. oh my darling Clementine."
in
inspect (wordFreq(explode t))
end;
(* 3.7.5 Abstract data types - The declarative model with secure types *)
fun newName () = promise()
val s = [#"a", #"b", #"c"]
val key = newName()
val ss = fn k => if (k = key) then s else raise Match
val x = ss key
exception Wrapper
exttype 'a key
fun newWrapper () =
let
constructor Key of 'a : 'a key
fun unKey (Key x) = x | unKey _ = raise Wrapper
in
(Key, unKey)
end
val (wrap, unwrap) = newWrapper()
val ss = wrap "abc"
val s = unwrap ss
local
val (wrap, unwrap) = newWrapper()
in
fun newStack () = wrap nil
fun push (s, e) = wrap(e::(unwrap s))
fun pop (s, e) =
case (unwrap s) of
nil => raise Empty
| x::xs => (fulfill(e, x); wrap xs)
fun isEmpty s = (unwrap s = nil)
end;
val p = promise();
newStack();
inspect (isEmpty(pop(push(push(newStack(), "abc"), "def"), p)));
inspect (future p);
(* 3.7.6 Abstract data types - A secure declarative dictionary *)
structure SecureDictionary : DICTIONARY =
let
val (wrap, unwrap) = newWrapper()
in
struct
eqtype keytype = Dictionary.keytype
eqtype valtype = Dictionary.valtype
type dictionary = Dictionary.dictionary key
fun newDictionary () = wrap(Dictionary.newDictionary())
fun put (ds, k, v) = wrap(Dictionary.put(unwrap ds, k, v))
fun get (ds, k) = Dictionary.get(unwrap ds, k)
fun condGet (ds, k, default) = Dictionary.condGet(unwrap ds, k, default)
fun domain ds = Dictionary.domain(unwrap ds)
end
end
val ds = SecureDictionary.put(SecureDictionary.newDictionary(), "abc", 123);
inspect (SecureDictionary.domain(ds));
(* Note: Opaque signatures provide secure types without need for wrappers *)
structure Dictionary :> (DICTIONARY where type keytype = string
where type valtype = int) =
struct
type keytype = string
type valtype = int
datatype dictionary = Leaf
| Tree of keytype * valtype * dictionary * dictionary
fun newDictionary () = Leaf
fun put (Leaf, key, value) = Tree(key, value, Leaf, Leaf)
| put (Tree(k, v, l, r), key, value) if (key < k) = Tree(k, v, put(l, key, value), r)
| put (Tree(k, v, l, r), key, value) if (key > k) = Tree(k, v, l, put(r, key, value))
| put (Tree(k, v, l, r), key, value) = Tree(key, value, l, r)
fun get (Leaf, key) = NONE
| get (Tree(k, v, l, r), key) if (key < k) = get(l, key)
| get (Tree(k, v, l, r), key) if (key > k) = get(r, key)
| get (Tree(k, v, l, r), key) = SOME v
fun condGet (Leaf, key, default) = default
| condGet (Tree(k, v, l, r), key, default) if (key < k) = condGet(l, key, default)
| condGet (Tree(k, v, l, r), key, default) if (key > k) = condGet(r, key, default)
| condGet (Tree(k, v, l, r), key, default) = v
fun domain ds =
let
fun domainD (Leaf, s1, sn) = fulfill(s1, future sn)
| domainD (Tree(k, v, l, r), s1, sn) =
let
val s2 = promise()
val s3 = promise()
in
domainD(l, s1, s2);
fulfill(s2, k::(future s3));
domainD(r, s3, sn)
end
val d = promise()
val p = promise()
in
fulfill(p, nil);
domainD(ds, d, p);
future d
end
end
val ds = Dictionary.put(Dictionary.newDictionary(), "abc", 123);
inspect (Dictionary.domain(ds));
(* 3.8.1 Nondeclarative needs - Text input/output with a file *)
val infile = TextIO.openIn "foo.txt"
val s = explode(TextIO.input infile);
TextIO.closeIn infile;
val response = HttpClient.get(Url.fromString "http://localhost/");
inspect (#body response);
val outfile = TextIO.openOut "foo.txt";
TextIO.output(outfile, "This comes in the file.\n");
TextIO.output(outfile, "The result of 43*43 in " ^ Int.toString(43*43) ^ ".\n");
TextIO.output(outfile, "Strings are ok too.\n");
TextIO.closeOut outfile;
(* test of SecureDictionary with appropriate redefinitions from section 3.7.3 *)
fun incWord (d, w) = SecureDictionary.put(d, w, SecureDictionary.condGet(d, w, 0) + 1)
fun countWords (d, w::ws) = countWords(incWord(d, w), ws)
| countWords (d, nil) = d
fun wordFreq cs = countWords(SecureDictionary.newDictionary(), charsToWords(nil, cs))
val infile = TextIO.openIn "foo.txt"
val s = TextIO.input infile;
TextIO.closeIn infile;
val d = wordFreq(explode s)
val outfile = TextIO.openOut "wordfreq.txt";
map
(fn k => TextIO.output(outfile, k^": "^Int.toString(SecureDictionary.condGet(d, k, 0))^"\n"))
(SecureDictionary.domain d);
TextIO.closeOut outfile;
(* 3.8.2 Nondeclarative needs - Text input/output with a graphical user interface *)
datatype gtkglue = NOGLUE | N | S | W | E | NS | NW | NE | SW | SE | WE | NSW | NWE | SWE | NSWE
datatype gtk = GtkTD of gtk list
| GtkLR of gtk list
| GtkTitle of {text:string}
| GtkLabel of {text:string}
| GtkText of {object:(Gtk.object promise), tdscrollbar:bool, glue:gtkglue}
| GtkButton of {text:string, action:(Gtk.callback_function), glue:gtkglue}
| GtkGlue of gtkglue
fun gtkBuild d =
let
val window = Gtk.Window.new Gtk.WindowType.TOPLEVEL
val destroyEvent = fn _ => OS.Process.exit OS.Process.success
fun gtkPack (box, widget) =
if (widget <> Gtk.NULL)
then Gtk.Box.packStart(box, widget, false, false, 0)
else ()
fun build (GtkTD xs) =
let
val vBox = Gtk.VBox.new(false, 0)
in
map (fn x => let val widget = build x in gtkPack(vBox, widget) end) xs;
vBox
end
| build (GtkLR xs) =
let
val hBox = Gtk.HBox.new(false, 0)
in
map (fn x => let val widget = build x in gtkPack(hBox, widget) end) xs;
hBox
end
| build (GtkTitle {text}) =
let
val _ = Gtk.Window.setTitle(window, text)
in
Gtk.NULL
end
| build (GtkLabel {text}) =
let
val label = Gtk.Label.new text
in
label
end
| build (GtkText {object, tdscrollbar, glue}) =
let
val _ = fulfill(object, Gtk.TextView.new())
in
future object
end
| build (GtkButton {text, action, glue}) =
let
val button = Gtk.Button.newWithLabel text
in
Gtk.signalConnect(button, "clicked", action);
button
end
| build (GtkGlue x) = Gtk.NULL
in
Gtk.signalConnect(window, "destroy-event", destroyEvent);
Gtk.Container.setBorderWidth(window, 4);
Gtk.Container.add(window, build d);
window
end
val pWindow = promise()
val textIn = promise()
val textOut = promise()
fun a1 _ =
let
val textBuffer = Gtk.TextView.getBuffer(future textIn)
val textIterStart = Gtk.TextIter.new()
val textIterEnd = Gtk.TextIter.new()
in
Gtk.TextBuffer.getBounds(textBuffer, textIterStart, textIterEnd);
Gtk.TextBuffer.setText(
Gtk.TextView.getBuffer(future textOut),
Gtk.TextBuffer.getText(textBuffer, textIterStart, textIterEnd, false),
Gtk.TextBuffer.getCharCount(textBuffer))
end
fun a2 _ = Gtk.Widget.destroy(future pWindow) (* OS.Process.exit OS.Process.success *)
val d = GtkTD[
GtkTitle {text="Simple text I/O interface"},
GtkLR[GtkLabel {text="Input:"},
GtkText {object=textIn, tdscrollbar=true, glue=NSWE},
GtkGlue NSWE],
GtkLR[GtkLabel {text="Output:"},
GtkText {object=textOut, tdscrollbar=true, glue=NSWE},
GtkGlue NSWE],
GtkLR[GtkButton {text="Do It", action=a1, glue=NSWE},
GtkButton {text="Quit", action=a2, glue=NSWE}]
]
val window = gtkBuild(d);
fulfill(pWindow, window);
Gtk.Widget.showAll window;
val d = GtkTD[GtkButton {text="Ouch", action=(fn _ => inspect "ouch"), glue=NSWE}]
val window = gtkBuild(d);
Gtk.Widget.showAll window;
(* 3.8.3 Nondeclarative needs - Stateless data I/O with files *)
Pickle.save("Test."^Pickle.extension, pack (val x = "alice-ctm") : (val x:string));
structure Test = unpack Pickle.load("Test."^Pickle.extension) : (val x:string)
val x = Test.x;
signature FACT =
sig
val fact : int -> int
val f10 : int
val f10gen1 : unit -> int
val f10gen2 : unit -> int
val fngen1 : int -> int
val fngen2 : int -> int
end
structure Fact : FACT =
struct
fun fact 0 = 1
| fact n = n * fact(n-1)
val f10 = fact 10
val f10gen1 = fn () => f10
val f10gen2 = fn () => fact 10
fun fngen1 n = let val f = fact n in f end
fun fngen2 n = fact n
end;
Pickle.save("Fact."^Pickle.extension, pack Fact : FACT);
structure Fact' = unpack Pickle.load("Fact."^Pickle.extension) : FACT;
inspect (Fact'.fact 10);
inspect (Fact'.f10);
inspect (Fact'.f10gen1());
inspect (Fact'.f10gen2());
inspect (Fact'.fngen1 10);
inspect (Fact'.fngen2 10);
Pickle.save("Dictionary."^Pickle.extension, pack Dictionary : DICTIONARY);
structure Dictionary' = unpack Pickle.load("Dictionary."^Pickle.extension) : DICTIONARY;
(* 3.9.3 Program design in the small - Software components *)
structure MyList =
let
fun merge (nil, ys) = ys
| merge (xs, nil) = xs
| merge (x::xs, y::ys) =
if (x < y)
then x::merge(xs, y::ys)
else y::merge(x::xs, ys)
fun split nil = (nil, nil)
| split (x::nil) = ([x], nil)
| split (x::y::xs) =
let
val (ys, zs) = split xs
in
(x::ys, y::zs)
end
fun mergesort nil = nil
| mergesort (x::nil) = [x]
| mergesort xs =
let
val (ys, zs) = split xs
in
merge(mergesort ys, mergesort zs)
end
in
struct
fun append [] ys = ys
| append (x::xs) ys = x :: (append xs ys)
fun sort xs = mergesort xs
fun member (n, nil) = false
| member (n, x::xs) = (n = x) orelse (member(n, xs))
end
end
functor MyListFunctor () =
let
fun merge (nil, ys) = ys
| merge (xs, nil) = xs
| merge (x::xs, y::ys) =
if (x < y)
then x::merge(xs, y::ys)
else y::merge(x::xs, ys)
fun split nil = (nil, nil)
| split (x::nil) = ([x], nil)
| split (x::y::xs) =
let
val (ys, zs) = split xs
in
(x::ys, y::zs)
end
fun mergesort nil = nil
| mergesort (x::nil) = [x]
| mergesort xs =
let
val (ys, zs) = split xs
in
merge(mergesort ys, mergesort zs)
end
in
struct
fun append [] ys = ys
| append (x::xs) ys = x :: (append xs ys)
fun sort xs = mergesort xs
fun member (n, nil) = false
| member (n, x::xs) = (n = x) orelse (member(n, xs))
end
end
(* define export list through inline signature *)
functor MyListFunctor2 () :
sig
val append : 'a list -> 'a list -> 'a list
val sort : int list -> int list
val member : 'a * 'a list -> bool
end =
struct
fun merge (nil, ys) = ys
| merge (xs, nil) = xs
| merge (x::xs, y::ys) =
if (x < y)
then x::merge(xs, y::ys)
else y::merge(x::xs, ys)
fun split nil = (nil, nil)
| split (x::nil) = ([x], nil)
| split (x::y::xs) =
let
val (ys, zs) = split xs
in
(x::ys, y::zs)
end
fun mergesort nil = nil
| mergesort (x::nil) = [x]
| mergesort xs =
let
val (ys, zs) = split xs
in
merge(mergesort ys, mergesort zs)
end
fun append [] ys = ys
| append (x::xs) ys = x :: (append xs ys)
fun sort xs = mergesort xs
fun member (n, nil) = false
| member (n, x::xs) = (n = x) orelse (member(n, xs))
end
(* 3.9.4 Program design in the small - Example of a standalone program *)
signature DICTIONARY =
sig
type keytype
type valtype
type dictionary
val newDictionary : unit -> dictionary
val put : dictionary * keytype * valtype -> dictionary
val condGet : dictionary * keytype * valtype -> valtype
val pairs : dictionary -> (keytype * valtype) list
end
structure Dictionary : DICTIONARY =
struct
type keytype = string
type valtype = int
datatype dictionary = Leaf
| Tree of keytype * valtype * dictionary * dictionary
fun newDictionary () = Leaf
fun put (Leaf, key, value) = Tree(key, value, Leaf, Leaf)
| put (Tree(k, v, l, r), key, value) if (key < k) = Tree(k, v, put(l, key, value), r)
| put (Tree(k, v, l, r), key, value) if (key > k) = Tree(k, v, l, put(r, key, value))
| put (Tree(k, v, l, r), key, value) = Tree(key, value, l, r)
fun condGet (Leaf, key, default) = default
| condGet (Tree(k, v, l, r), key, default) if (key < k) = condGet(l, key, default)
| condGet (Tree(k, v, l, r), key, default) if (key > k) = condGet(r, key, default)
| condGet (Tree(k, v, l, r), key, default) = v
fun pairs ds =
let
fun pairsD (Leaf, s1, sn) = fulfill(s1, future sn)
| pairsD (Tree(k, v, l, r), s1, sn) =
let
val s2 = promise()
val s3 = promise()
in
pairsD(l, s1, s2);
fulfill(s2, (k, v)::(future s3));
pairsD(r, s3, sn)
end
val d = promise()
val p = promise()
in
fulfill(p, nil);
pairsD(ds, d, p);
future d
end
end
functor WordApp () =
struct
fun wordChar c =
(#"a" <= c andalso c <= #"z") orelse
(#"A" <= c andalso c <= #"Z") orelse
(#"0" <= c andalso c <= #"9")
fun stringToAtom pw = implode pw
fun wordToAtom pw =
stringToAtom (List.rev pw)
fun incWord (d, w) =
Dictionary.put(d, w, Dictionary.condGet(d, w, 0) + 1)
fun charsToWords (nil, nil) = nil
| charsToWords (pw, nil) = [wordToAtom pw]
| charsToWords (pw, c::cs) if (wordChar c) =
charsToWords ((Char.toLower c)::pw, cs)
| charsToWords (nil, c::cs) = charsToWords(nil, cs)
| charsToWords (pw, c::cs) =
(wordToAtom pw)::(charsToWords(nil, cs))
fun countWords (d, w::ws) = countWords(incWord(d, w), ws)
| countWords (d, nil) = d
fun wordFreq cs =
countWords(Dictionary.newDictionary(), charsToWords(nil, cs))
(* Note: should probably get filename from stdin as per the oz code *)
val infile = TextIO.openIn "foo.txt"
val l = TextIO.input infile
val _ = TextIO.closeIn infile
val d = wordFreq(explode l)
val s = genericMergeSort (fn ((_, a), (_, b)) => a > b) (Dictionary.pairs d)
val h = promise()
val des = GtkTD[GtkTitle {text="Word frequency count"},
GtkText {object=h, tdscrollbar=true, glue=NSWE}]
val w = gtkBuild(des)
val _ = Gtk.Widget.showAll w
val t = foldl (fn ((k, v), x) => x ^ k ^ ": " ^ Int.toString(v) ^ " times\n") "" s
val _ = Gtk.TextBuffer.setText(Gtk.TextView.getBuffer(future h), t, size t)
val s1 = genericMergeSort (fn ((a, _), (b, _)) => a < b) (Dictionary.pairs d)
val s2 = genericMergeSort (fn ((_, a), (_, b)) => a > b) (Dictionary.pairs d)
val h1 = promise()
val h2 = promise()
val des = GtkTD[GtkTitle {text="Word frequency count"},
GtkText {object=h1, tdscrollbar=true, glue=NSWE},
GtkText {object=h2, tdscrollbar=true, glue=NSWE}]
val w = gtkBuild(des)
val _ = Gtk.Widget.showAll w
val t1 = foldl (fn ((k, v), x) => x ^ k ^ ": " ^ Int.toString(v) ^ " times\n") "" s1
val t2 = foldl (fn ((k, v), x) => x ^ k ^ ": " ^ Int.toString(v) ^ " times\n") "" s2
val _ = Gtk.TextBuffer.setText(Gtk.TextView.getBuffer(future h1), t1, size t1)
val _ = Gtk.TextBuffer.setText(Gtk.TextView.getBuffer(future h2), t2, size t2)
end
structure _ = WordApp()
|