About CTM The following Alice ML code is derived from the examples provided in the book:
      "Concepts, Techniques, and Models of Computer Programming" by Peter Van Roy and Seif Haridi.
      http://www2.info.ucl.ac.be/people/PVR/book.html

(* 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




Chris Rathman / Chris.Rathman@tx.rr.com