(* CTM Chapter #06 Examples in Alice ML *)
import signature IMP_MAP from "x-alice:/lib/data/IMP_MAP-sig"
import functor MkHashImpMap from "x-alice:/lib/data/MkHashImpMap"
import functor MkRedBlackImpMap from "x-alice:/lib/data/MkRedBlackImpMap"
(* syntactic sugar for solutions using promises/futures *)
open Promise
open Future
infix 3 ?=
val op?= = fulfill
val ? = future;
(* Functions defined in previous chapters *)
fun forall nil f = ()
| forall (x::xs) f = (f x; forall xs f);
fun for a b s f =
let
fun loopup c where (c <= b) = (f c; loopup (c+s))
| loopup c = ()
fun loopdown c where (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;
fun member (n, nil) = false
| member (n, x::xs) = (n = x) orelse (member(n, xs))
fun known x =
let
val p = promise()
in
fulfill(p, x); p
end
(* 6.1.1 What is state? - Implicit (declarative) state *)
fun sumList (nil, s) = s
| sumList (x::xs, s) = sumList(xs, x+s);
(* 6.1.2 What is state? - Explicit state *)
let
val c = ref 0
fun sumList (xs, s) =
let
val _ = c := !c + 1
in
case xs
of nil => s
| x::xr => sumList(xr, x+s)
end
in
sumList([1,2,3], 0)
end;
(* 6.3.3 The declarative model with explicit state - Relation to declarative programming *)
fun reverse xs =
let
val rs = ref nil
in
forall xs (fn x => rs := x::(!rs));
!rs
end
(* 6.3.4 The declarative model with explicit state - Sharing *)
(* sharing *)
val x = ref 0
val y = x;
y := 10;
inspect (!x);
(* token equality and structure equality *)
datatype person = Person of { name:string, age:int };
val x = Person{ name="George", age=25 }
val y = Person{ name="George", age=25 };
inspect (x = y);
val x = ref 10
val y = ref 10;
inspect (x = y);
inspect (!x = !y);
val x = ref 10
val y = x;
inspect (x = y);
(* 6.4.2 Data abstraction - Variations on a stack *)
signature T = sig type t end
(* Odu: Open declarative unbundled stack *)
signature ODUSTACK =
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 OduStack : ODUSTACK =
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) = ( e ?= x; xs )
fun isEmpty nil = true
| isEmpty _ = false
end
val e = promise()
val s1 = OduStack.newStack();
inspect (OduStack.isEmpty s1);
val s2 = OduStack.push(s1, 23);
val s3 = OduStack.pop(s2, e);
inspect (future e);
(* Sdu: Secure declarative unbundled stack *)
signature SDUSTACK =
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 SduStack :> (SDUSTACK where type t = int) =
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) = ( e ?= x; xs )
fun isEmpty s = null s
end
val e = promise()
val s1 = SduStack.newStack();
inspect (SduStack.isEmpty s1);
val s2 = SduStack.push(s1, 23);
val s3 = SduStack.pop(s2, e);
inspect (future e);
(* Sdb: Secure declarative bundled stack *)
signature SDBSTACK =
sig
type t
type stack
val newStack : unit -> stack
val push : stack -> t -> stack
val pop : stack -> t promise -> stack
val isEmpty : stack -> unit -> bool
end
structure SdbStack :> (SDBSTACK where type t = int) =
struct
type t = int
datatype 'a sdbbundle = SdbBundle of { push : 'a -> 'a sdbbundle,
pop : 'a promise -> 'a sdbbundle,
isEmpty : unit -> bool }
type stack = t sdbbundle
fun stackObject xs =
let
fun push e = stackObject(e::xs)
fun pop e =
case xs
of nil => raise Empty
| x::xr => ( e ?= x; stackObject xr )
fun isEmpty () = null(xs)
in
SdbBundle{ push=push, pop=pop, isEmpty=isEmpty }
end
fun newStack() = stackObject nil
fun push (SdbBundle{push=f, ...}) = f
fun pop (SdbBundle{pop=f, ...}) = f
fun isEmpty (SdbBundle{isEmpty=f, ...}) = f
end
val e = promise()
val s1 = SdbStack.newStack();
inspect (SdbStack.isEmpty s1 ());
val s2 = SdbStack.push s1 23
val s3 = SdbStack.pop s2 e;
inspect (future e);
(* Ssb: Secure stateful bundled stack *)
signature SSBSTACK =
sig
type t
type stack
val push : t -> unit
val pop : unit -> t
val isEmpty : unit -> bool
val toChunk : unit -> stack
end
functor SsbStack(AType: T) :> (SSBSTACK where type t = AType.t
where type stack = AType.t list ref) =
struct
type t = AType.t
type stack = t list ref
val c = ref nil
fun push e = ( c := e::(!c) )
fun pop () =
if (null(!c))
then raise Empty
else
let
val x = hd (!c)
in
c := tl (!c);
x
end
fun isEmpty () = null(!c)
(* toChunk function used in OO examples below. *)
fun toChunk () = c
end
structure S = SsbStack(type t = int);
inspect (S.isEmpty());
S.push(23);
val x = S.pop();
inspect x;
(* Alternate implementation *)
signature SSBSTACK2 =
sig
type t
type stack
val newStack : unit -> stack
val push : stack -> t -> unit
val pop : stack -> unit -> t
val isEmpty : stack -> unit -> bool
end
structure SsbStack2 :> (SSBSTACK2 where type t = int) =
struct
type t = int
datatype 'a ssbbundle = SsbBundle of { push : 'a -> unit,
pop : unit -> 'a,
isEmpty : unit -> bool }
type stack = t ssbbundle
fun stackObject c =
let
fun push e = ( c := (e::(!c)) )
fun pop () =
if (null(!c))
then raise Empty
else
let
val x = hd (!c)
in
c := tl (!c);
x
end
fun isEmpty () = null(!c)
in
SsbBundle{ push=push, pop=pop, isEmpty=isEmpty }
end
fun newStack() = stackObject (ref nil)
fun push (SsbBundle{push=f, ...}) = f
fun pop (SsbBundle{pop=f, ...}) = f
fun isEmpty (SsbBundle{isEmpty=f, ...}) = f
end
val s1 = SsbStack2.newStack();
inspect (SsbStack2.isEmpty s1 ());
SsbStack2.push s1 23;
inspect (SsbStack2.pop s1 ());
(* End Alternate implementation *)
(* Alternate implementation - with help from Andreas Rossberg *)
signature SSBSTACK3 =
sig
type t
type stack = { push : t -> unit,
pop : unit -> t,
isEmpty : unit -> bool }
val newStack : unit -> stack
end
structure SsbStack3 :> (SSBSTACK3 where type t = int) =
struct
type t = int
type stack = { push : t -> unit,
pop : unit -> t,
isEmpty : unit -> bool }
fun newStack () =
let
val c = ref nil
fun push e = ( c := (e::(!c)) )
fun pop () =
if (null(!c))
then raise Empty
else
let
val x = hd (!c)
in
c := tl (!c);
x
end
fun isEmpty () = null(!c)
in
{push, pop, isEmpty}
end
end
val s1 = SsbStack3.newStack();
inspect (#isEmpty s1());
#push s1 23;
inspect (#pop s1());
(* End Alternate implementation *)
(* Secure stateful unbundled stack *)
signature SSUSTACK =
sig
type t
type stack
val newStack : unit -> stack
val push : stack * t -> unit
val pop : stack -> t
val isEmpty : stack -> bool
end
structure SsuStack :> (SSUSTACK where type t = int) =
struct
type t = int
type stack = t list ref
fun newStack () = ref nil
fun push (s, e) = ( s := e::(!s) )
fun pop s =
case (!s) of
nil => raise Empty
| x::xs => ( s := xs; x )
fun isEmpty s = null(!s)
end
val s1 = SsuStack.newStack();
inspect (SsuStack.isEmpty s1);
SsuStack.push(s1, 23);
val x = SsuStack.pop s1;
inspect x;
(* 6.4.3 Data abstraction - Polymorphism *)
(* An example: a Collection type *)
signature ADTCOLLECTION =
sig
type t
type collection
val newCollection : unit -> collection
val put : collection * t -> unit
val get : collection -> t
val isEmpty : collection -> bool
end
structure ADTCollection :> (ADTCOLLECTION where type t = int) =
struct
type t = SsuStack.t
type collection = SsuStack.stack
fun newCollection () = SsuStack.newStack()
fun put (c, e) = SsuStack.push(c, e)
fun get c = SsuStack.pop c
fun isEmpty c = SsuStack.isEmpty c
end
val c = ADTCollection.newCollection();
ADTCollection.put(c, 1);
ADTCollection.put(c, 2);
inspect (ADTCollection.get c);
inspect (ADTCollection.get c);
signature OOCOLLECTION =
sig
type t
val put : t -> unit
val get : unit -> t
val isEmpty : unit -> bool
end
functor OOCollection(AType: T) :> (OOCOLLECTION where type t = AType.t) =
struct
type t = AType.t
structure C = SsbStack(type t = t)
fun put e = C.push e
fun get () = C.pop()
fun isEmpty () = C.isEmpty()
end
structure C = OOCollection(type t = int);
C.put 1;
C.put 2;
inspect (C.get());
inspect (C.get());
(* Alternate implementation *)
signature OOCOLLECTION2 =
sig
type t
type collection
val newCollection : unit -> collection
val put : collection -> t -> unit
val get : collection -> unit -> t
val isEmpty : collection -> unit -> bool
end
structure OOCollection2 :> (OOCOLLECTION2 where type t = int) =
struct
type t = int
datatype 'a collectionbundle = CollectionBundle of { put : 'a -> unit,
get : unit -> 'a,
isEmpty : unit -> bool }
type collection = t collectionbundle
fun collectionObject c =
let
fun put e = SsbStack2.push c e
fun get () = SsbStack2.pop c ()
fun isEmpty () = SsbStack2.isEmpty c ()
in
CollectionBundle{ put=put, get=get, isEmpty=isEmpty }
end
fun newCollection() = collectionObject (SsbStack2.newStack())
fun put (CollectionBundle{put=f, ...}) = f
fun get (CollectionBundle{get=f, ...}) = f
fun isEmpty (CollectionBundle{isEmpty=f, ...}) = f
end
val s1 = OOCollection2.newCollection();
inspect (OOCollection2.isEmpty s1 ());
OOCollection2.put s1 1;
OOCollection2.put s1 2;
inspect (OOCollection2.get s1 ());
inspect (OOCollection2.get s1 ());
(* End Alternate implementation *)
(* Alternate implementation - with help from Andreas Rossberg *)
signature OOCOLLECTION3 =
sig
type t
type collection = { put : t -> unit,
get : unit -> t,
isEmpty : unit -> bool }
val new : unit -> collection
end
structure OOCollection3 :> (OOCOLLECTION3 where type t = int) =
struct
type t = int
type collection = { put : t -> unit,
get : unit -> t,
isEmpty : unit -> bool }
fun new () =
let
val c = SsbStack3.newStack()
val put = #push c
val get = #pop c
val isEmpty = #isEmpty c
in
{put, get, isEmpty}
end
end
val s1 = OOCollection3.new();
inspect (#isEmpty s1());
#put s1 1;
#put s1 2;
inspect (#get s1());
inspect (#get s1());
(* End Alternate implementation *)
(* Adding a union operation in the ADT case *)
fun doWhile b f =
if b()
then
let
val _ = f()
in
doWhile b f
end
else ()
fun doUntil b f = doWhile (not o b) f
signature ADTCOLLECTION =
sig
type t
type collection
val newCollection : unit -> collection
val put : collection * t -> unit
val get : collection -> t
val isEmpty : collection -> bool
val union : collection * collection -> collection
end
structure ADTCollection :> (ADTCOLLECTION where type t = int) =
struct
type t = SsuStack.t
type collection = SsuStack.stack
fun newCollection () = SsuStack.newStack()
fun put (c, e) = SsuStack.push(c, e)
fun get c = SsuStack.pop c
fun isEmpty c = SsuStack.isEmpty c
fun union (c1, c2) =
let in
doUntil (fn () => SsuStack.isEmpty c2)
(fn () => SsuStack.push(c1, SsuStack.pop c2));
c1
end
end
val c1 = ADTCollection.newCollection();
val c2 = ADTCollection.newCollection();
ADTCollection.put(c1, 1);
ADTCollection.put(c1, 2);
ADTCollection.put(c2, 3);
ADTCollection.put(c2, 4);
val c3 = ADTCollection.union(c1, c2);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
structure ADTCollection :> (ADTCOLLECTION where type t = int) =
struct
type t = SsuStack.t
type collection = SsuStack.stack
fun newCollection () = SsuStack.newStack()
fun put (c, e) = SsuStack.push(c, e)
fun get c = SsuStack.pop c
fun isEmpty c = SsuStack.isEmpty c
fun union (c1, c2) =
let in
doUntil (fn () => SsuStack.isEmpty c2)
(fn () => put(c1, get c2));
c1
end
end
val c1 = ADTCollection.newCollection();
val c2 = ADTCollection.newCollection();
ADTCollection.put(c1, 1);
ADTCollection.put(c1, 2);
ADTCollection.put(c2, 3);
ADTCollection.put(c2, 4);
val c3 = ADTCollection.union(c1, c2);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
(* Adding a union operation in the object case *)
signature OOCOLLECTION =
sig
type t
type collection
val put : t -> unit
val get : unit -> t
val isEmpty : unit -> bool
val union : collection -> unit
val toChunk : unit -> collection
end
functor OOCollection(AType: T) :> (OOCOLLECTION where type t = AType.t
where type collection = AType.t list ref) =
struct
type t = AType.t
type collection = t list ref
structure C = SsbStack(type t = t)
fun put e = C.push e
fun get () = C.pop()
fun isEmpty () = C.isEmpty()
fun union (ref nil) = ()
| union (ref (x::xs)) = ( C.push(x); union (ref xs) )
| union (ref _) = ()
fun toChunk () = C.toChunk()
end
structure C1 = OOCollection(type t = int);
structure C2 = OOCollection(type t = int);
C1.put 1;
C1.put 2;
C2.put 3;
C2.put 4;
C1.union(C2.toChunk());
inspect (C1.get());
inspect (C1.get());
inspect (C1.get());
inspect (C1.get());
functor OOCollection(AType: T) :> (OOCOLLECTION where type t = AType.t
where type collection = AType.t list ref) =
struct
type t = AType.t
type collection = t list ref
structure C = SsbStack(type t = t)
fun put e = C.push e
fun get () = C.pop()
fun isEmpty () = C.isEmpty()
fun union (ref nil) = ()
| union (ref (x::xs)) = ( put(x); union (ref xs) )
| union (ref _) = ()
fun toChunk () = C.toChunk()
end
structure C1 = OOCollection(type t = int);
structure C2 = OOCollection(type t = int);
C1.put 1;
C1.put 2;
C2.put 3;
C2.put 400;
C1.union(C2.toChunk());
inspect (C1.get());
inspect (C1.get());
inspect (C1.get());
inspect (C1.get());
(* Discussion *)
fun union (c1, c2, isEmptyC2, getC2) =
let in
doUntil (fn () => isEmptyC2 c2)
(fn () => ADTCollection.put(c1, getC2 c2));
c1
end
val c1 = ADTCollection.newCollection();
val c2 = ADTCollection.newCollection();
ADTCollection.put(c1, 10);
ADTCollection.put(c1, 20);
ADTCollection.put(c2, 30);
ADTCollection.put(c2, 40);
val c3 = union(c1, c2, ADTCollection.isEmpty, ADTCollection.get);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
inspect (ADTCollection.get c3);
(* 6.4.4 Data abstraction - Parameter passing *)
(* Call by variable *)
fun sqr a =
a := !a * !a;
let
val c = ref 0
in
c := 25;
sqr c;
inspect (!c)
end;
(* Call by value *)
fun sqr d =
let
val a = ref d
in
a := !a + 1;
inspect (!a * !a)
end;
sqr 25;
(* Call by value-result *)
fun sqr a =
let
val d = ref (!a)
in
d := !d * !d;
a := !d;
!a
end;
let
val c = ref 0
in
c := 25;
sqr c;
inspect (!c)
end;
(* Call by name *)
fun sqr a =
a() := (!(a())) * (!(a()));
let
val c = ref 0
in
c := 25;
sqr (fn () => c);
inspect (!c)
end;
(* Call by need *)
fun sqr a =
let
val b = a()
in
b := !b * !b;
!b
end;
let
val c = ref 0
in
c := 25;
sqr (fn () => c);
inspect (!c)
end;
(* 6.4.5 Data abstraction - Revocable capabilities *)
exception RevokedError
datatype 'a revoker = Revoker of { grant:'a, revoke:unit->'a }
fun revocable obj =
let
val c = ref obj
fun r () = ( c := (fn m => raise RevokedError); !c )
fun robj m = !c(m)
in
Revoker{ grant=robj, revoke=r }
end
datatype 'a collector = Add of 'a | Get of 'a
fun newCollector () =
let
val lst = ref nil
in
fn (m, Add(x)) =>
let
val t = promise()
in
Ref.exchange(lst, x::(future t));
!lst
end
| (m, Get(xs)) => List.rev(!lst)
end
val c = revocable(newCollector())
(* 6.5.1 State collections - Indexed collections *)
(* Array - new *)
val a = Array.array(4, 0)
(* Array - put *)
val x = Array.update(a, 0, 44)
val x = Array.update(a, 1, 22)
val x = Array.update(a, 2, 11)
val x = Array.update(a, 3, 33)
(* Array - get *)
val x = Array.sub(a, 0)
val x = Array.sub(a, 1)
val x = Array.sub(a, 2)
val x = Array.sub(a, 3)
(* Array - low/high - ML arrays have low=0 and high=length()-1 *)
val x = Array.length a
(* Array - toArray *)
val a = Array.fromList [4,2,1,3]
(* Array - clone *)
val b = Array.array(Array.length a, 0)
val _ = Array.copy { src=a, dst=b, di=0 }
(* Array - misc *)
val a = Array.tabulate(4, fn i => i)
val _ = Array.modifyi (fn (i, x) => i*x) a
(* Stateful Dictionary - new *)
structure Dictionary = MkRedBlackImpMap String
val d = Dictionary.map()
(* Dictionary - put *)
val _ = Dictionary.insert(d, "mykey", 123)
(* Dictionary - get *)
val x = Dictionary.lookup(d, "mykey")
(* Dictionary - member *)
val x = Dictionary.member(d, "mykey")
(* Dictionary - remove *)
val _ = Dictionary.remove(d, "mykey")
(* Alternate implementation of a stateful dictionary *)
signature DICTIONARY =
sig
type keytype
type valtype
type dictionary
val newDictionary : unit -> dictionary ref
val put : dictionary ref * keytype * valtype -> dictionary ref
val get : dictionary ref * keytype -> valtype option
val condGet : dictionary ref * keytype * valtype -> valtype
val member : dictionary ref * keytype -> bool
val remove : dictionary ref * keytype -> dictionary ref
val domain : dictionary ref -> keytype list
end
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 ref * dictionary ref
fun newDictionary () = ( ref Leaf )
fun put (ref Leaf as d, key, value) =
( d := Tree(key, value, ref Leaf, ref Leaf); d )
| put (ref (Tree(k, v, l, r)) as d, key, value) where (key < k) =
( d := Tree(k, v, put(l, key, value), r); d )
| put (ref (Tree(k, v, l, r)) as d, key, value) where (key > k) =
( d := Tree(k, v, l, put(r, key, value)); d )
| put (ref (Tree(k, v, l, r)) as d, key, value) =
( d := Tree(key, value, l, r); d )
| put _ = raise Domain
fun get (ref Leaf, key) = NONE
| get (ref (Tree(k, v, l, r)), key) where (key < k) = get(l, key)
| get (ref (Tree(k, v, l, r)), key) where (key > k) = get(r, key)
| get (ref (Tree(k, v, l, r)), key) = SOME v
| get _ = raise Domain
fun condGet (d, key, default) =
case get(d, key)
of NONE => default
| SOME v => v
fun member (d, key) =
case get(d, key)
of NONE => false
| SOME v => true
fun domain ds =
let
fun domainD (ref Leaf, s1, sn) = fulfill(s1, future sn)
| domainD (ref (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
| domainD _ = raise Domain
val d = promise()
val p = promise()
in
fulfill(p, nil);
domainD(ds, d, p);
future d
end
(* note: need to code the remove function here *)
fun remove (d, key) = d
end
(* Dictionary - new *)
val d = Dictionary.newDictionary()
(* Dictionary - put *)
val _ = Dictionary.put(d, "mykey", 123)
(* Dictionary - get *)
val x = Dictionary.get(d, "mykey")
val x = Dictionary.condGet(d, "mykey", 456)
(* Dictionary - member *)
val x = Dictionary.member(d, "mykey")
(* Dictionary - remove *)
val _ = Dictionary.remove(d, "mykey")
(* End Alternate implementation *)
(* 6.5.3 State collections - Indexed collections *)
signature EXTENSIBLEARRAY =
sig
type t
val put : int * t -> unit
val get : int -> t
end
signature A =
sig
type t
val high : int
val init : t
end
functor ExtensibleArray(AType: A) :> (EXTENSIBLEARRAY where type t = AType.t) =
struct
type t = AType.t
val a = ref (Array.array(AType.high, AType.init))
fun checkOverflow i =
if (i >= Array.length (!a))
then
let
val b = ref (Array.array(Int.max(i, (Array.length (!a)) + AType.high), AType.init))
in
for 0 ((Array.length(!a))-1) 1 (fn n => Array.update(!a, n, Array.sub(!a, n)));
a := !b
end
else ()
fun put (i, x) =
let
val _ = checkOverflow i
in
Array.update(!a, i, x)
end
fun get i =
let
val _ = checkOverflow i
in
Array.sub(!a, i)
end
end
(* 6.6.2 Reasoning with state - An example *)
structure S = SsbStack(type t = int);
S.push(23);
val y = S.pop()
val x = S.isEmpty()
functor SsbStack(AType: T) :> (SSBSTACK where type t = AType.t
where type stack = AType.t list ref) =
struct
type t = AType.t
type stack = t list ref
val c = ref nil
fun push e = ( c := e::(!c) )
fun pop () =
if (null(!c))
then raise Empty
else
let
val x = hd (!c)
in
c := tl (!c);
x
end
fun isEmpty () = null(!c)
fun toChunk () = c
end
(* 6.8.1 Case studies - Transitive closure *)
(* converting between representations *)
fun array2list a =
let
fun a2l i =
if (i < Array.length a)
then Array.sub(a, i)::a2l(i+1)
else nil
in
a2l 0
end
fun l2m gl =
let
val h = foldl (fn ((x,_),y) => Int.max(x, y)) (#1(hd gl)) gl
val gm = Array2.array(h+1, h+1, false)
in
forall gl
(fn (i, ns) =>
forall ns (
fn j => Array2.update(gm, i, j, true)));
gm
end
fun m2l gm =
let
val (h,_) = Array2.dimensions gm
val gl = Array.fromList(ListPair.zip(List.tabulate(h, fn i=>i), List.tabulate(h, fn i=>nil)))
in
for 0 (h-1) 1
(fn i =>
for (h-1) 0 ~1
(fn j => (
if (Array2.sub(gm, i, j))
then
let
val (n, xs) = Array.sub(gl, i)
in
Array.update(gl, i, (n, j::xs))
end
else ())));
array2list gl
end
val gl = [(0,[1,2]), (1,[0]), (2,nil)]
val gm = l2m gl
val gl = m2l gm
(* Declarative algorithm *)
fun succ' (x, (y, sy)::g) =
if (x = y)
then sy
else succ'(x, g)
| succ' _ = nil
fun union (a, nil) = a
| union (nil, b) = b
| union (x::a2 as a, y::b2 as b) =
if (x = y)
then x::(union(a2, b2))
else
if (x < y)
then x::(union(a2, b))
else y::(union(a, b2))
fun declTrans g =
let
val xs = map (fn (x, _) => x) g
in
foldl (
fn (x, inG) =>
let
val sx = succ'(x, inG)
in
map (
fn (y, sy) =>
if (member(x, sy))
then (y, union(sy, sx))
else (y, sy)
) inG
end
) g xs
end;
inspect (declTrans [(0,[1,2]), (1,[0]), (2,nil)]);
(* Stateful algorithm *)
fun stateTrans gm =
let
val (h,_) = Array2.dimensions gm
in
for 0 (h-1) 1
(fn k =>
for 0 (h-1) 1
(fn i =>
if Array2.sub(gm, i, k)
then
for 0 (h-1) 1
(fn j =>
if Array2.sub(gm, k, j)
then Array2.update(gm, i, j, true)
else ())
else ()));
gm
end;
inspect (m2l(stateTrans(l2m [(0,[1,2]), (1,[0]), (2,nil)])));
(* Second declarative algorithm *)
(* Alice does not support dynamic tuple manipulation - using lists instead *)
fun makeList 0 = nil
| makeList n = promise()::makeList(n-1)
fun declTrans2 gt =
let
val h = List.length gt
fun loop (k, inG) =
if (k < h)
then
let
val g = makeList h
in
for 0 (h-1) 1
(fn i =>
let
val _ = List.nth(g, i) ?= makeList h
in
for 0 (h-1) 1
(fn j =>
List.nth(future(List.nth(g, i)), j) ?=
((future(List.nth(future(List.nth(inG, i)), j))) orelse
(((future(List.nth(future(List.nth(inG, i)), k))) andalso
((future(List.nth(future(List.nth(inG, k)), j))))))))
end);
loop(k+1, g)
end
else inG
in
loop(0, gt)
end
val gt = [known [known false, known true, known true],
known [known true, known false, known false],
known [known false, known false, known false]];
inspect (declTrans2 gt);
fun declTrans2 gt =
let
val h = List.length gt
fun loop (k, inG) =
if (k < h)
then
let
val g = makeList h
in
spawn
for 0 (h-1) 1
(fn i =>
spawn
let
val _ = List.nth(g, i) ?= makeList h
in
for 0 (h-1) 1
(fn j =>
List.nth(future(List.nth(g, i)), j) ?=
((future(List.nth(future(List.nth(inG, i)), j))) orelse
(((future(List.nth(future(List.nth(inG, i)), k))) andalso
((future(List.nth(future(List.nth(inG, k)), j))))))))
end);
loop(k+1, g)
end
else inG
in
loop(0, gt)
end
val gt = [known [known false, known true, known true],
known [known true, known false, known false],
known [known false, known false, known false]];
inspect (declTrans2 gt);
(* 6.8.2 Case studies - Word frequencies (with stateful dictionary *)
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) where (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."
val d = Dictionary.domain(wordFreq(explode t))
in
inspect d
end;
(* 6.8.3 Case studies - Generating random numbers *)
(* Uniformly distributed random numbers *)
fun newRand () =
let
val a = 33367 (* note: chopped off a digit *)
val b = 21345332
val m = 10000000
val x = ref 0
fun rand () =
let in
x := (IntInf.toInt(
((IntInf.fromInt a) * (IntInf.fromInt (!x)) + (IntInf.fromInt b)) mod
(IntInf.fromInt m)));
!x
end
fun init seed = (x := seed)
in
(rand, init, m)
end
(* Using laziness instead of state *)
fun lazy randList s0 =
let
val a = 33367
val b = 21345332
val m = 10000000
val s1 = IntInf.toInt(
(((IntInf.fromInt a) * (IntInf.fromInt s0)) + (IntInf.fromInt b)) mod
(IntInf.fromInt m))
in
s1::(randList s1)
end
(* Nonuniform distributions *)
val (rand, init, max) = newRand()
val fmax = Real.fromInt max
fun uniform () =
Real.fromInt(rand()) / fmax
fun uniformI (a, b) =
a + (Real.round(uniform() * (Real.fromInt(b) - Real.fromInt(a))))
fun exponential lambda =
~((Math.ln 1.0) - uniform()) / lambda
val twoPi = 4.0 * (Math.acos 0.0)
fun gauss () =
(Math.sqrt(~2.0)) * (Math.ln(uniform())) * (Math.cos(twoPi) * uniform())
local
val nan = Math.sqrt ~1.0
val gaussCell = ref nan
in
fun gauss () =
let
val prev = Ref.exchange(gaussCell, nan)
in
if not(Real.isNan prev)
then prev
else
let
val r = Math.sqrt(~2.0 * (Math.ln(uniform())))
val phi = twoPi * uniform()
in
gaussCell := (r * (Math.cos phi));
r * (Math.sin phi)
end
end
end
(* 6.8.4 Case studies - "Word-of-mouth" simulation *)
datatype siteinfo = SiteInfo of { hits:int ref, performance:real }
datatype userinfo = UserInfo of { currentSite:int ref }
datatype roundinfo = RoundInfo of { time:int, nonZeroSites:int }
val n = 100
val m = 500
val t = 20
val _ = init 0
val outfile = TextIO.openOut "wordofmouth.txt"
fun outSite (SiteInfo{hits, performance}, j) =
TextIO.output(outfile,
"SiteInfo{hits:" ^ Int.toString(!hits) ^
", performance:" ^ Real.toString(performance) ^
", name:" ^ Int.toString(j) ^
"}\n")
fun outRound (RoundInfo{time, nonZeroSites}) =
TextIO.output(outfile,
"RoundInfo{time:" ^ Int.toString(time) ^
", nonZeroSites:" ^ Int.toString(nonZeroSites) ^
"}\n")
val sites = makeList n;
for 0 (n-1) 1
(fn i =>
let
val s = uniformI(0, n-1)
in
List.nth(sites, i) ?= (SiteInfo{hits=(ref 0), performance=Real.fromInt(uniformI(0, 80000-1))})
end);
val users = makeList m;
for 0 (m-1) 1
(fn i =>
let
val s = uniformI(0, n-1)
val SiteInfo{hits, ...} = future(List.nth(sites, s))
in
List.nth(users, i) ?= (UserInfo{currentSite=(ref s)});
hits := !hits + 1
end);
fun userStep i =
let
val UserInfo{currentSite=u, ...} = future(List.nth(users, i))
(* ask three users for their performance information *)
val xs = map
(fn x =>
let
val UserInfo{currentSite, ...} = future(List.nth(users, x))
val SiteInfo{performance, ...} = future(List.nth(sites, !currentSite))
in
(!currentSite, performance + abs(gauss() * Real.fromInt (n-1)) )
end)
[uniformI(0, m-1), uniformI(0, m-1), uniformI(0, m-1)]
(* calculate the best site *)
val (ms, mp) = foldl
(fn (x1, x2) =>
let
val (_, p1) = x1
val (_, p2) = x2
in
if (p2 > p1)
then x2 else x1
end)
let
val SiteInfo{performance, ...} = future(List.nth(sites, !u))
in
(!u, performance + abs(gauss() * Real.fromInt (n-1)))
end
xs
in
if (ms <> !u)
then
let
val SiteInfo{hits, ...} = future(List.nth(sites, !u))
val _ = hits := !hits - 1
val SiteInfo{hits, ...} = future(List.nth(sites, ms))
val _ = hits := !hits + 1
in
u := ms
end
else ()
end;
for 0 (n-1) 1
(fn j =>
outSite(future(List.nth(sites, j)), j));
outRound(RoundInfo{time=0, nonZeroSites=0});
for 0 (t-1) 1
(fn i =>
let
val x = ref 0
in
for 0 (m-1) 1 (fn u => userStep u);
for 0 (n-1) 1
(fn j =>
let
val SiteInfo{hits, ...} = future(List.nth(sites, j))
in
if (!hits <> 0)
then
let in
outSite(future(List.nth(sites, j)), j);
x := !x + 1
end
else ()
end);
outRound(RoundInfo{time=i, nonZeroSites=(!x)})
end);
TextIO.closeOut outfile;
(* 6.9.2 Advanced topics - Memory management and external references *)
fun readListLazy fname =
let
val infile = TextIO.openIn fname
fun lazy readNext () =
let
val xs = explode(TextIO.inputN(infile, 100))
in
if (null xs)
then TextIO.closeIn infile
else ( readNext(); () );
xs
end
in
(* Alice does not currently have finalize support *)
readNext()
end
|