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 #07 Examples in Alice ML *)
import structure Gtk    from "x-alice:/lib/gtk/Gtk"
import structure Gdk    from "x-alice:/lib/gtk/Gdk"
import structure Canvas from "x-alice:/lib/gtk/Canvas"

(* syntactic sugar for solutions using promises/futures *)
open Promise
open Future
infix 3 ?=
val op?= = fulfill
val ? = future;
infix 3 ::=
val op ::= = Gtk.Prop.prop;

(* Functions defined in previous chapters *)
fun known x =
   let
      val p = promise()
   in
      fulfill(p, x); p
   end

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

(* 7.2.1 Classes as complete data abstractions - An example *)

(* Using Wrapped Functions *)
   fun counter (initx) =
      let
         val x = ref initx
         fun inc(deltax) = ( x := !x + deltax; !x )
         fun browse () = inspect (!x:int)
      in
         { inc, browse }
      end

   val c = counter(0);
   #inc c(6);
   #inc c(6);
   #browse c();

   let
      val x = promise()
   in
      (* #inc c(future x); *)       (* waits here if uncommented *)
      x ?= 5
   end;
   #browse c();

   let
      val s = promise()
   in
      let
         val x = promise()
      in
         spawn ( #inc c(future x); s ?= () );
         x ?= 5
      end;
      await s;
      #browse c()
   end;
(* End Using Wrapped Functions *)

(* Using Records *)
   type counter = { inc    : int -> int,
                    browse : unit -> unit }

   signature COUNTER =
      sig
         val new : int -> counter
      end

   structure Counter :> COUNTER =
      struct
         fun new initx =
            let
               val x = ref initx
               fun inc(deltax) = ( x := !x + deltax; !x )
               fun browse () = inspect (!x)
            in
               { inc, browse }
            end
      end

   val c = Counter.new(0);
   #inc c(6);
   #inc c(6);
   #browse c();

   let
      val x = promise()
   in
      (* #inc c(future x); *)       (* waits here if uncommented *)
      x ?= 5
   end;
   #browse c();

   let
      val s = promise()
   in
      let
         val x = promise()
      in
         spawn ( #inc c(future x); s ?= () );
         x ?= 5
      end;
      await s;
      #browse c()
   end;
(* End Using Records *)

(* Using Functors *)
   signature COUNTER =
      sig
         val inc    : int -> int
         val browse : unit -> unit
      end

   functor Counter (val x:int) :> COUNTER =
      struct
         val x = ref x
         fun inc(deltax) = ( x := !x + deltax; !x )
         fun browse () = inspect (!x)
      end

   structure C = Counter(val x=0);
   C.inc(6);
   C.inc(6);
   C.browse();

   let
      val x = promise()
   in
      (* C.inc(future x); *)       (* waits here if uncommented *)
      x ?= 5
   end;
   C.browse();

   let
      val s = promise()
   in
      let
         val x = promise()
      in
         spawn ( C.inc(future x); s ?= () );
         x ?= 5
      end;
      await s;
      C.browse()
   end;
(* End Using Functors *)

(* 7.2.5 Classes as complete data abstractions - Initializing attributes *)

(* Using Records *)
   (* per instance *)
   type oneapt = { streetName : string ref }
   signature ONEAPT =
      sig
         val new : string -> oneapt
      end
   structure OneApt :> ONEAPT =
      struct
         fun new initStreetName =
            let
               val streetName = ref initStreetName
            in
               { streetName }
            end
      end
   val apt1 = OneApt.new("drottinggatan")
   val apt2 = OneApt.new("rueNueve")

   (* per class *)
   type yorkapt = { streetName   : string ref,
                    streetNumber : int ref,
                    wallColor    : string promise ref,
                    floorSurface : string ref }
   signature YORKAPT =
      sig
         val new : unit -> yorkapt
      end
   structure YorkApt :> YORKAPT =
      struct
         val streetName = ref "york"
         val streetNumber = ref 100
         val wallColor = ref (promise())
         val floorSurface = ref "wood"
         fun new () =
            let in
               { streetName, streetNumber, wallColor, floorSurface }
            end
      end
   val apt3 = YorkApt.new()
   val apt4 = YorkApt.new();
   !(#wallColor apt3) ?= "white";
   #wallColor apt3 := known("white");

   (* per brand *)
   val l = ref "linux"
   type redhat = { osType : string ref }
   signature REDHAT =
      sig
         val new : unit -> redhat
      end
   structure RedHat :> REDHAT =
      struct
         fun new () =
            let
               val osType = l
            in
               { osType }
            end
      end
   type suse = { osType : string ref }
   signature SUSE =
      sig
         val new : unit -> suse
      end
   structure SuSe :> SUSE =
      struct
         fun new () =
            let
               val osType = l
            in
               { osType }
            end
      end
   type debian = { osType : string ref }
   signature DEBIAN =
      sig
         val new : unit -> debian
      end
   structure Debian :> DEBIAN =
      struct
         fun new () =
            let
               val osType = l
            in
               { osType }
            end
      end
(* End Using Records *)

(* Using Functors *)
   (* per instance *)
   signature ONEAPT =
      sig
         val streetName : string ref
      end
   functor OneApt (val streetName:string) :> ONEAPT =
      struct
         val streetName = ref streetName
      end
   structure Apt1 = OneApt(val streetName="drottinggatan")
   structure Apt2 = OneApt(val streetName="rueNueve")

   (* per class *)
   signature YORKAPT =
      sig
         val streetName   : string ref
         val streetNumber : int ref
         val wallColor    : string promise ref
         val floorSurface : string ref
      end
   functor YorkApt () :> YORKAPT =
      struct
         val streetName = ref "york"
         val streetNumber = ref 100
         val wallColor = ref (promise())
         val floorSurface = ref "wood"
      end
   structure Apt3 = YorkApt()
   structure Apt4 = YorkApt();
   !(Apt3.wallColor) ?= "white";
   Apt3.wallColor := known("white");

   (* per brand *)
   val l = ref "linux"
   signature REDHAT =
      sig
         val osType : string ref
      end
   functor RedHat () :> REDHAT =
      struct
         val osType = l
      end
   signature SUSE =
      sig
         val osType : string ref
      end
   functor SuSe () :> SUSE =
      struct
         val osType = l
      end
   signature DEBIAN =
      sig
         val osType : string ref
      end
   functor Debian () :> DEBIAN =
      struct
         val osType = l
      end
(* End Using Functors *)

(* 7.2.6 Classes as complete data abstractions - First-class messages *)

(* 1. Fixed argument list *)
signature FOO =
   sig
      val foo : int * int * int -> unit
   end
functor Foo () :> FOO =
   struct
      fun foo (a, b, c) = ()
   end

(* 2. Variable argument list *)
datatype unitype = UTstring    of string
                 | UTint       of int
                 | UTchar      of char
                 | UTword      of word
                 | UTreal      of real
                 | UTlist      of unitype list
                 | UTpair      of unitype*unitype
                 | UTfun       of unitype->unitype
                 | UTunit      of unit;
signature FOO =
   sig
      val foo : int * int * int * unitype -> unit
   end
functor Foo () :> FOO =
   struct
      fun foo (a, b, c, ut) = ()
   end

(* 3. Variable reference to method head *)
signature FOO =
   sig
      val foo : int * int * int -> unit
   end
functor Foo () :> FOO =
   struct
      fun foo (m as (a, b, c)) = ()
   end

(* 4. Optional argument *)
(* Note: Not applicable for static typing languages - skipping for now *)

(* 5. Private method label *)
signature FOO =
   sig
      val fooPublic : int * int * int -> unit
   end
functor Foo () :> FOO =
   struct
      fun fooPublic (a, b, c) = ()
      fun fooPrivate (a, b, c) = ()
   end

(* 6. Dynamic method label *)
(* Note: Not applicable for static typing languages - skipping for now *)

(* 7. The otherwise method *)
(* Note: Not applicable for static typing languages - skipping for now *)

(* 7.2.7 Classes as complete data abstractions - First-class attributes *)

(* Not applicable for static typing languages - can use getter/setters for attributes *)
signature FOO =
   sig
      val getX : unit -> int
      val setX : int -> unit
   end
functor Foo () :> FOO =
   struct
      val x = ref 0
      fun getX () = !x
      fun setX x' = x := x'
   end

(* 7.3.1 Classes as incremental data abstractions - Inheritance graph *)

signature AS =
   sig
      val m : unit -> string
   end

functor Af () :> AS =
   struct
      fun m () = "A"
   end

signature BS =
   sig
      val m : unit -> string
   end
functor Bf () :> BS =
   struct
      fun m () = "B"
   end

signature CS =
   sig
      (* Need to try include signature here *)
      (* include A *)
      (* include B *)
      val m : unit -> string
   end
functor Cf () :> CS =
   struct
      structure Ac = Af()
      structure Bc = Bf()
      open Ac
      open Bc     (* this open will set Bc.m to override Ac.m *)
   end

structure Cx = Cf();
inspect (Cx.m());

(* 7.3.2 Classes as incremental data abstractions - Method access control (static and dynamic binding *)

(* Using Records *)
   type account = { balance       : int ref,
                    transfer      : int -> unit,
                    getBal        : unit -> int,
                    batchTransfer : int list -> unit }
   signature ACCOUNT =
      sig
         val new : unit -> account
      end
   structure Account :> ACCOUNT =
      struct
         fun new () =
            let
               val balance = ref 0
               fun transfer amt = ( balance := (!balance + amt) )
               fun getBal () = !balance
               fun batchTransfer nil = ()
                 | batchTransfer (x::xs) = ( transfer x; batchTransfer xs )
            in
               { balance, transfer, getBal, batchTransfer }
            end
      end

   type log = { addentry : (int -> unit) -> int -> unit }
   signature LOG =
      sig
         val new : unit -> log
      end
   structure Log :> LOG =
      struct
         fun new () =
            let
               fun addentry transfer amt = transfer amt
            in
               { addentry }
            end
      end

   structure LoggedAccount :> ACCOUNT =
      struct
         fun new () =
            let
               val super = Account.new()
               val logObj = Log.new()
               val balance = #balance super
               fun transfer amt = #addentry logObj (#transfer super) amt
               val getBal = #getBal super
               val batchTransfer = #batchTransfer super
            in
               { balance, transfer, getBal, batchTransfer }
            end
      end

   val logAct = LoggedAccount.new();
   #transfer logAct(100);
(* End Using Records *)

(* Using Functors *)
   signature ACCOUNT =
      sig
         val balance       : int ref
         val transfer      : int -> unit
         val getBal        : unit -> int
         val batchTransfer : int list -> unit
      end
   functor Account () :> ACCOUNT =
      struct
         val balance = ref 0
         fun transfer amt = ( balance := (!balance + amt) )
         fun getBal () = !balance
         fun batchTransfer nil = ()
           | batchTransfer (x::xs) = ( transfer x; batchTransfer xs )
      end

   signature LOG =
      sig
         val addentry : (int -> unit) -> int -> unit
      end
   functor Log () :> LOG =
      struct
         fun addentry transfer amt = transfer amt
      end

   functor LoggedAccount () :> ACCOUNT =
      struct
         structure Super = Account()
         structure LogObj = Log()
         open Super
         fun transfer amt = LogObj.addentry (Super.transfer) amt
      end

   structure LogAct = LoggedAccount();
   LogAct.transfer(100);
(* End Using Functors *)

(* 7.3.3 Classes as incremental data abstractions - Encapsulation control *)

(* Private methods *)
signature CS =
   sig
      val a : int -> unit
   end
functor Cf () :> CS =
   struct
      fun a x = ()
      fun b x = ()
   end

(* Protected methods - Not available in Alice but can privatize parent functions *)
signature CS =
   sig
      val a : int -> unit
      val b : int -> unit
   end
functor Cf () :> CS =
   struct
      fun a x = ()
      fun b x = ()
   end

signature DS =
   sig
      val a : int -> unit
   end
functor Df () :> DS =
   struct
      structure Cx = Cf()
      open Cx
   end

(* 7.3.4 Classes as incremental data abstractions - Forwarding and delegation *)

(* Forwarding *)
signature AS =
   sig
      val cube : int -> int
   end
functor Af () :> AS =
   struct
      fun cube x = x*x*x
   end

signature BS =
   sig
      val square : int -> int
      (* include AS *)
      val cube   : int -> int
   end
functor Bf(MixIn: AS) : BS =
   struct
      open MixIn
      fun square x = x*x
   end

structure Bx = Bf(Af());
inspect (Bx.cube(10));

(* Delegation *)

(* Note: The delegation implementation relies on doesNotRespond dynamic runtime behavior *)

signature COUNTER =
   sig
      val x      : int ref
      val inc    : int -> int
      val browse : unit -> unit
   end

functor C1NonDel () :> COUNTER =
   struct
      val x = ref 0
      fun inc(deltax) = ( x := !x + deltax; !x )
      fun browse () = inspect ("c1:" ^ Int.toString(inc 10))
   end

functor C2NonDel () :> COUNTER =
   struct
      structure C1 = C1NonDel()
      open C1
      fun browse () = inspect ("c2:" ^ Int.toString(inc 100))
   end

structure C1 = C1NonDel()
structure C2 = C2NonDel();
C1.browse();
C2.browse();

functor C1Del () : COUNTER =
   struct
      val x = ref 0
      fun inc(deltax) = ( x := !x + deltax; !x )
      fun browse () = inspect ("c1:" ^ Int.toString(inc 10))
   end

functor C2Del (Delegate: COUNTER) :> COUNTER =
   struct
      open Delegate
      fun browse () =
         let in
            inspect ("c2:" ^ Int.toString(inc 100));
            Delegate.browse()
         end
   end

structure C2 = C2Del(C1Del());
C2.browse();

(* 7.3.5 Classes as incremental data abstractions - Reflection *)

(* Method wrapping *)
(* Note: Not applicable for static typing languages - skipping for now *)

(* Reflection of object state *)
(* Note: Not applicable for static typing languages - skipping for now *)

(* 7.4.1 Programming with inheritance - The correct use of inheritance *)

signature ACCOUNT =
   sig
      val balance       : int ref
      val transfer      : int -> unit
      val getBal        : unit -> int
      val batchTransfer : int list -> unit
   end
functor Account () :> ACCOUNT =
   struct
      val balance = ref 0
      fun transfer amt = ( balance := (!balance + amt) )
      fun getBal () = !balance
      fun batchTransfer nil = ()
        | batchTransfer (x::xs) = ( transfer x; batchTransfer xs )
   end

functor VerboseAccount () :> ACCOUNT =
   struct
      structure Super = Account()
      open Super
      fun transfer amt =
         let in
            Super.transfer amt;
            inspect ("Balance: " ^ Int.toString(!balance))
         end
   end

functor AccountWithFee () :> ACCOUNT =
   struct
      structure Super = VerboseAccount()
      open Super
      val fee = 5
      fun transfer amt = Super.transfer(amt-fee);
   end

structure A = AccountWithFee();
A.transfer(100);

(* 7.4.2 Programming with inheritance - Constructing a hierarchy by following the type *)

exception Abstract
signature LISTCLASS =
   sig
      val isNil   : unit -> bool
      val append' : package -> package
      val display : unit -> unit
   end

functor ListClass () :> LISTCLASS =
   struct
      fun isNil _ = raise Abstract
      fun append' _ = raise Abstract
      fun display _ = raise Abstract
   end

functor NilClass () :> LISTCLASS =
   struct
      structure Super = ListClass()
      open Super
      fun isNil () = true
      fun append' u = u
      fun display () = inspect "nil"
   end

functor ConsClass (val head:int val tail:package) : LISTCLASS =
   struct
      structure Super = ListClass()
      open Super
      val head = ref head
      val tail = ref tail
      fun isNil () = false
      (* Recursive modules not supported *)
      (* fun append' u =
         let
            structure Tail = unpack (!tail) : LISTCLASS
            val u2 = Tail.append' u
         in
            pack (ConsClass(val head=(!head) val tail=u2)) : LISTCLASS
         end *)
      (* Use an in-place append instead *)
      fun append' u =
         let
            structure Tail = unpack (!tail) : LISTCLASS
         in
            if Tail.isNil()
               then ( tail := u; u )
               else Tail.append' u
         end
      fun display () =
         let
            structure Tail = unpack (!tail) : LISTCLASS
         in
            inspect ((!head):int);
            Tail.display()
         end
   end

val n1 =
   pack (ConsClass(
      val head=1
      val tail=(
         pack (ConsClass(
            val head=2 val tail=(pack (NilClass()) : LISTCLASS)
         )) : LISTCLASS
      ))) : LISTCLASS

val n2 =
   pack (ConsClass(
      val head=3
      val tail=(pack (NilClass()) : LISTCLASS)
      )) : LISTCLASS

val _ =
   let
      structure N1 = unpack n1 : LISTCLASS
   in
      N1.append' n2;
      N1.display()
   end

(* 7.4.3 Programming with inheritance - Generic classes *)

(* using inheritance *)
signature GENERICSORT =
   sig
      type t
      val qsort : t list -> t list
      val less : (t*t -> bool) promise
   end

functor GenericSort (type t) :> (GENERICSORT where type t = t) =
   struct
      type t = t
      val less = promise()

      fun partition (nil, p, ss, ls) =
            let in
               ss ?= nil;
               ls ?= nil
            end
        | partition (x::xr, p, ss, ls) =
            let
               val sr = promise()
               val lr = promise()
            in
               if (future less)(x, p)
                  then ( ss ?= x::xr; ls ?= future lr )
                  else ( ss ?= future sr; ls ?= x::(future lr) );
               partition(xr, p, sr, lr)
            end

      fun qsort nil = nil
        | qsort (x::xs) =
            let
               val ys = promise()
               val zs = promise()
            in
               partition(xs, x, ys, zs);
               qsort(future ys) @ (x::qsort(future zs))
            end
   end

structure IntegerSort :> (GENERICSORT where type t = int) =
   struct
      type t = int
      structure Super = GenericSort(type t = t)
      open Super
      val _ = less ?= (op< : t*t->bool)
   end

structure RealSort :> (GENERICSORT where type t = real) =
   struct
      type t = real
      structure Super = GenericSort(type t = t)
      open Super
      val _ = less ?= (op< : t*t->bool)
   end

type rational = int * int
structure RationalSort :> (GENERICSORT where type t = rational) =
   struct
      type t = rational
      structure Super = GenericSort(type t = rational)
      open Super
      val _ = less ?= (fn ((xNumerator, xDenominator), (yNumerator, yDenominator)) =>
         let
            val x = Real.fromInt(xNumerator) / Real.fromInt(xDenominator)
            val y = Real.fromInt(yNumerator) / Real.fromInt(yDenominator)
         in
            x < y
         end)
   end;

inspect (IntegerSort.qsort([1, 2, 5, 3, 4]));
inspect (RealSort.qsort([23.0/3.0, 34.0/11.0, 47.0/17.0]));
inspect (RationalSort.qsort([(23,3), (34,11), (47,17)]));

(* using higher-order programming *)
signature GENERICSORT =
   sig
      type t
      val qsort : t list -> t list
   end

functor GenericSort (type t val less : t * t -> bool) :> (GENERICSORT where type t = t) =
   struct
      type t = t
      val less = less

      fun partition (nil, p, ss, ls) =
            let in
               ss ?= nil;
               ls ?= nil
            end
        | partition (x::xr, p, ss, ls) =
            let
               val sr = promise()
               val lr = promise()
            in
               if less(x, p)
                  then ( ss ?= x::xr; ls ?= future lr )
                  else ( ss ?= future sr; ls ?= x::(future lr) );
               partition(xr, p, sr, lr)
            end

      fun qsort nil = nil
        | qsort (x::xs) =
            let
               val ys = promise()
               val zs = promise()
            in
               partition(xs, x, ys, zs);
               qsort(future ys) @ (x::qsort(future zs))
            end
   end

structure IntegerSort :> (GENERICSORT where type t = int) =
   struct
      type t = int
      val less = op< : t*t->bool
      structure Super = GenericSort(type t = t val less = less)
      open Super
   end

structure RealSort :> (GENERICSORT where type t = real) =
   struct
      type t = real
      val less = op< : t*t->bool
      structure Super = GenericSort(type t = t val less = less)
      open Super
   end

type rational = int * int
structure RationalSort :> (GENERICSORT where type t = rational) =
   struct
      type t = rational
      fun less ((xNumerator, xDenominator), (yNumerator, yDenominator)) =
         let
            val x = Real.fromInt(xNumerator) / Real.fromInt(xDenominator)
            val y = Real.fromInt(yNumerator) / Real.fromInt(yDenominator)
         in
            x < y
         end
      structure Super = GenericSort(type t = rational val less = less)
      open Super
   end;

inspect (IntegerSort.qsort([1, 2, 5, 3, 4]));
inspect (RealSort.qsort([23.0/3.0, 34.0/11.0, 47.0/17.0]));
inspect (RationalSort.qsort([(23,3), (34,11), (47,17)]));

structure ISort = GenericSort(type t = int  val less = op< : t*t->bool)
structure FSort = GenericSort(type t = real val less = op< : t*t->bool)
structure RSort = GenericSort(type t = rational val less =
   fn ((xNumerator, xDenominator), (yNumerator, yDenominator)) =>
      let
         val x = Real.fromInt(xNumerator) / Real.fromInt(xDenominator)
         val y = Real.fromInt(yNumerator) / Real.fromInt(yDenominator)
      in
         x < y
      end)

(* 7.4.4 Programming with inheritance - Multiple inheritance *)

fun makeColor colormap (r, g, b) =
   let
      fun colorConv n = Real.round(65535.0 * n)
      val color = Gdk.Color.new { red   = colorConv r,
                                  green = colorConv g,
                                  blue  = colorConv b }
   in
      Gdk.Colormap.allocColor(colormap, color, false, true);
      color
   end
val cmap = Gdk.Colormap.getSystem()
val black = makeColor cmap (0.0, 0.0, 0.0)
val white = makeColor cmap (1.0, 1.0, 1.0)

signature FIGURE =
   sig
      val move    : real * real -> unit
      val display : unit -> unit
   end

functor Line (val group:(Gtk.object) val x1:real val y1:real val x2:real val y2:real) :> FIGURE =
   struct
      val group = group
      val x1 = ref x1
      val y1 = ref y1
      val x2 = ref x2
      val y2 = ref y2
      fun move (dx, dy) =
         let in
            x1 := !x1 + dx;
            y1 := !y1 + dy;
            x2 := !x2 + dx;
            y2 := !y2 + dy
         end
      fun display () =
         let
            val line = Canvas.Group.newItem(group, Canvas.Line.getType())
         in
            Canvas.Prop.setL line
               [Canvas.Line.points       ::= [(!x1,!y1),(!x2,!y2)],
                Canvas.Line.fillColorGdk ::= black,
                Canvas.Line.widthPixels  ::= 1]
         end
   end

functor Circle (val group:(Gtk.object) val x:real val y:real val r:real) :> FIGURE =
   struct
      val group = group
      val x = ref x
      val y = ref y
      val r = ref r
      fun move (dx, dy) =
         let in
            x := !x + dx;
            y := !y + dy
         end
      fun display () =
         let
            val circle = Canvas.Group.newItem(group, Canvas.Ellipse.getType())
         in
            Canvas.Prop.setL circle
               [Canvas.RE.x1                 ::= (!x - !r),
                Canvas.RE.y1                 ::= (!y - !r),
                Canvas.RE.x2                 ::= (!x + !r),
                Canvas.RE.y2                 ::= (!y + !r),
                Canvas.Shape.outlineColorGdk ::= black,
                Canvas.Shape.widthPixels     ::= 0]
         end
   end

signature LINKEDLIST =
   sig
      val add : package -> unit
      (* val forall : (t -> 'a) -> 'a *)
   end

(* cheating on this one - only multiple type (not implementation) inheritance *)
signature COMPOSITEFIGURE =
   sig
      include LINKEDLIST
      include FIGURE
   end

functor CompositeFigure () :> COMPOSITEFIGURE =
   struct
      val figlist = ref nil
      fun add p = figlist := p::(!figlist)
      fun move (x, y) =
         let
            fun moveloop nil = ()
              | moveloop (p::ps) =
                  let
                     structure F = unpack p : FIGURE
                  in
                     F.move(x, y);
                     moveloop ps
                  end
         in
            moveloop (!figlist)
         end
      fun display () =
         let
            fun displayloop nil = ()
              | displayloop (p::ps) =
                  let
                     structure F = unpack p : FIGURE
                  in
                     F.display();
                     displayloop ps
                  end
         in
            displayloop (!figlist)
         end
   end

val window = Gtk.Window.new Gtk.WindowType.TOPLEVEL
val canvas = Canvas.new();
Gtk.signalConnect(window, "destroy-event", fn _ => OS.Process.exit OS.Process.success);
Gtk.Window.setTitle(window, "Composite Figure");
Gtk.Container.setBorderWidth(window, 4);
val group = Canvas.Group.newItem(Canvas.root canvas, Canvas.Group.getType());
Canvas.Prop.setL group
   [Canvas.Group.x ::= 10.0,
    Canvas.Group.y ::= 10.0];
Gtk.Container.add(window, canvas);
Gtk.Widget.show canvas;
Gtk.Widget.setSizeRequest(canvas, 400, 400);
Gtk.Widget.setSizeRequest(window, 400, 400);
Gtk.Widget.showAll window;

structure F1 = CompositeFigure();
F1.add(pack (Line(val group=group val x1=50.0 val y1=50.0 val x2=150.0 val y2=50.0)) : FIGURE);
F1.add(pack (Line(val group=group val x1=150.0 val y1=50.0 val x2=100.0 val y2=125.0)) : FIGURE);
F1.add(pack (Line(val group=group val x1=100.0 val y1=125.0 val x2=50.0 val y2=50.0)) : FIGURE);
F1.add(pack (Circle(val group=group val x=100.0 val y=75.0 val r=20.0)) : FIGURE);
F1.display();

for 1 10 1 (fn i => (F1.display(); F1.move(3.0, ~2.0)));

(* 7.4.7 Programming with inheritance - Design patterns *)

(* Note: Otherwise method not applicable for static typing languages - skipping for now *)
signature COMPOSITE =
   sig
      val add : package -> unit
   end

functor Composite () :> COMPOSITE =
   struct
      val children = ref nil
      fun add p = children := p::(!children)
   end

(* 7.5.2 Relation to other computation models - Higher-order programming *)

fun newSortRoutine orderF =
   let
      fun sortRoutine inL = inL
         (* ... order(x, y) calculates order *)
   in
      sortRoutine
   end

signature SORTROUTINECLASS =
   sig
      type t
      val sort : t -> t
   end

functor SortRoutineClass (type t val order:t*t->bool) :> (SORTROUTINECLASS where type t = t) =
   struct
      type t = t
      val order = order
      fun sort inL = inL
         (* ... order(x, y) calculates order *)
   end

fun order (x, y) = (x < y)

signature ORDERCLASS =
   sig
      type t
      val order : t * t -> bool
   end

functor OrderClass (type t val lt:t*t->bool) :> (ORDERCLASS where type t = t) =
   struct
      type t = t
      fun order (x, y) = lt(x, y)
   end

structure SortRoutine = SortRoutineClass(type t = int val order = order)

(* Note: Batcher messaging class not applicable for static typing languages - skipping for now *)

val lv = [1, 2, 3]

val lv =
   pack (ConsClass(
      val head=1 val tail=(
         pack (ConsClass(
            val head=2 val tail=(
               pack (
                  ConsClass(val head=3 val tail=(pack (NilClass()) : LISTCLASS)
               )) : LISTCLASS
         ))) : LISTCLASS
      ))) : LISTCLASS

(* 7.6.1 Implementing the object system - Abstraction diagram *)

signature COUNTER =
   sig
      val inc    : int -> int
      val browse : unit -> unit
   end

functor Counter (val x:int) :> COUNTER =
   struct
      val x = ref x
      fun inc(deltax) = ( x := !x + deltax; !x )
      fun browse () = inspect (!x)
   end

(* 7.6.2 Implementing the object system - Implementing classes *)

   type counter = { inc    : int -> int,
                    browse : unit -> unit }

   signature COUNTER =
      sig
         val new : int -> counter
      end

   structure Counter :> COUNTER =
      struct
         fun new initx =
            let
               val x = ref initx
               fun inc(deltax) = ( x := !x + deltax; !x )
               fun browse () = inspect (!x)
            in
               { inc, browse }
            end
      end

(* 7.6.3 Implementing the object system - Implementing objects *)

(* Note: Generic New function not applicable for static typing languages - skipping for now *)

val c = counter(0);
#inc c(6);
#inc c(6);
#browse c();

(* 7.6.4 Implementing the object system - Implementing inheritance *)

(* Note: Generic From function not applicable for static typing languages - skipping for now *)

(* 7.7.2 The Java language (sequential part) - Introduction to Java programming *)

(* A simple program *)

   (* Using Wrapped Functions *)
      fun factorial () =
         let
            fun factIterative n =
               let
                  val f = ref 1
               in
                  for 1 n 1 (fn i => f := !f * i);
                  !f
               end
            fun factRecursive n =
               if (n = 0)
                  then 1
                  else n * factRecursive (n-1)
         in
            { factIterative, factRecursive }
         end

      val f = factorial();
      #factIterative f(5);
      #factRecursive f(5);
   (* End Using Wrapped Functions *)

   (* Using Records *)
      type factorial = { factIterative : int -> int,
                         factRecursive : int -> int }

      signature FACTORIAL =
         sig
            val new : unit -> factorial
         end

      structure Factorial :> FACTORIAL =
         struct
            fun new () =
               let
                  fun factIterative n =
                     let
                        val f = ref 1
                     in
                        for 1 n 1 (fn i => f := !f * i);
                        !f
                     end
                  fun factRecursive n =
                     if (n = 0)
                        then 1
                        else n * factRecursive (n-1)
               in
                  { factIterative, factRecursive }
               end
         end

      val f = Factorial.new();
      #factIterative f(5);
      #factRecursive f(5);
   (* End Using Records *)

   (* Using Functors *)
      signature FACTORIAL =
         sig
            val factIterative : int -> int
            val factRecursive : int -> int
         end

      functor Factorial () :> FACTORIAL =
         struct
            fun factIterative n =
               let
                  val f = ref 1
               in
                  for 1 n 1 (fn i => f := !f * i);
                  !f
               end
            fun factRecursive n =
               if (n = 0)
                  then 1
                  else n * factRecursive (n-1)
         end

      structure F = Factorial();
      F.factIterative(5);
      F.factRecursive(5);
   (* End Using Functors *)

(* Defining classes *)

   (* Using Wrapped Functions *)
      type point = { getX   : unit -> real,
                     getY   : unit -> real,
                     origin : unit -> unit,
                     scale  : real -> unit,
                     add    : real * real -> unit }

      fun newPoint (x, y) =
         let
            val x = ref x
            val y = ref y
            fun getX () = !x
            fun getY () = !y
            fun origin () = ( x := 0.0; y := 0.0 )
            fun scale s = ( x := !x * s; y := !y * s )
            fun add (dx, dy) = ( x := !x + dx; y := !y + dy )
         in
            { getX, getY, origin, scale, add }
         end

      val p = newPoint(10.0, 20.0);
      #getX p();
      #getY p();
   (* End Using Wrapped Functions *)

   (* Using Records *)
      type point = { getX   : unit -> real,
                     getY   : unit -> real,
                     origin : unit -> unit,
                     scale  : real -> unit,
                     add    : real * real -> unit }

      signature POINT =
         sig
            val new : real * real -> point
         end

      structure Point :> POINT =
         struct
            fun new (x, y) =
               let
                  val x = ref x
                  val y = ref y
                  fun getX () = !x
                  fun getY () = !y
                  fun origin () = ( x := 0.0; y := 0.0 )
                  fun scale s = ( x := !x * s; y := !y * s )
                  fun add (dx, dy) = ( x := !x + dx; y := !y + dy )
               in
                  { getX, getY, origin, scale, add }
               end
         end

      val p = Point.new(10.0, 20.0);
      #getX p();
      #getY p();
   (* End Using Records *)

   (* Using Functors *)
      signature POINT =
         sig
            val getX   : unit -> real
            val getY   : unit -> real
            val origin : unit -> unit
            val scale  : real -> unit
            val add    : package -> unit
         end

      functor Point (val x:real val y:real) :> POINT =
         struct
            val x = ref x
            val y = ref y
            fun getX () = !x
            fun getY () = !y
            fun origin () = ( x := 0.0; y := 0.0 )
            fun scale s = ( x := !x * s; y := !y * s )
            fun add p =
               let
                  structure P = unpack p : POINT
               in
                  x := !x + P.getX();
                  y := !y + P.getX()
               end
         end

      structure P = Point(val x=10.0 val y=20.0);
      P.getX();
      P.getY();
   (* End Using Functors *)

(* Parameter passing and main program *)
signature MYINTEGER =
   sig
      val x : int ref
   end

functor MyInteger (val x:int) :> MYINTEGER =
   struct
      val x = ref x
   end

fun sqr a =
   let
      structure A = unpack a : MYINTEGER
   in
      A.x := !A.x * !A.x
   end

structure C = MyInteger(val x = 25)
val c = pack C : MYINTEGER;
sqr c;
inspect (!C.x);

(* Inheritance *)
type color = int*int*int

signature COLOR =
   sig
      val setC : color -> unit
      val getC : unit -> color
   end

functor Color (val rgb:color) :> COLOR =
   struct
      val rgb = ref rgb
      fun setC rgbNew = (rgb := rgbNew)
      fun getC () = !rgb
   end

signature PIXEL =
   sig
      include POINT
      include COLOR
   end

functor Pixel (val x:real val y:real) :> POINT =
   struct
      structure Super = Point(val x=x val y=y)
      structure MyColor = Color(val rgb=(0,0,0))
      open Super
      open MyColor
      fun origin () = ( Super.origin(); MyColor.setC(0,0,0) )
   end

(* 7.8.1 Active objects - An example *)

(* not sure how to emulate NewActive since it relies on otherwise dynamic behavior *)
signature BALLGAME =
   sig
      val ball : unit -> unit
      val get  : unit -> int
   end

functor BallGame (val other:package) :> BALLGAME =
   struct
      val other = ref other
      val count = ref 0
      fun ball () = spawn
         let
            structure Other = unpack (!other) : BALLGAME
         in
            count := !count + 1;
            if (!count < 21)
               then Other.ball()
               else ()
         end
      fun get () = !count
   end

val b1 = promise()
val b2 = promise();
structure B1 = BallGame(val other=(future b2))
structure B2 = BallGame(val other=(future b1));
b1 ?= (pack B1 : BALLGAME);
b2 ?= (pack B2 : BALLGAME);
B1.ball();
val x = B1.get();
inspect x;

(* 7.8.2 Active objects - The NewActive abstraction *)

(* Note: NewActive not applicable for static typing languages - skipping for now *)

(* 7.8.3 Active objects - The Flavius Josephus problem *)
signature VICTIM =
   sig
      val setSucc : package -> unit
      val setPred : package -> unit
      val newsucc : package -> unit
      val newpred : package -> unit
      val kill    : int * int -> unit
   end

functor Victim (val ident:int val step:int val last:int promise) =
   struct
      val ident = ident
      val step = step
      val last = last
      val alive = ref true
      val pred = ref (future(promise()))
      val succ = ref (future(promise()))
      fun setPred p = pred := p
      fun setSucc s = succ := s
      fun newsucc s =
         if (!alive)
            then succ := s
            else
               let
                  structure Pred = unpack (!pred) : VICTIM
               in
                  Pred.newsucc(s)
               end
      fun newpred p =
         if (!alive)
            then pred := p
            else
               let
                  structure Succ = unpack (!succ) : VICTIM
               in
                  Succ.newpred(p)
               end
      fun kill (x, n) =
         let
            structure Succ = unpack (!succ) : VICTIM
            structure Pred = unpack (!pred) : VICTIM
         in
            if (!alive)
               then
                  if (n = 1)
                     then last ?= ident
                     else
                        if ((x mod step) = 0)
                           then
                              let in
                                 alive := false;
                                 Pred.newsucc(!succ);
                                 Succ.newpred(!pred);
                                 Succ.kill(x+1, n-1)
                              end
                           else Succ.kill(x+1, n)
               else Succ.kill(x, n)
         end
   end

fun josephus (n, k) =
   let
      val last = promise()
      val a = Array.array(n, (future(promise())))
   in
      for 1 n 1
         (fn i =>
            let
               structure V = Victim(val ident=i val step=k val last=last)
            in
               Array.update(a, (i-1), pack V : VICTIM)
            end);
      for 2 n 1
         (fn i =>
            let
               structure V = unpack (Array.sub(a, i-1)) : VICTIM
            in
               V.setPred(Array.sub(a, i-2))
            end);
      let
         structure V = unpack (Array.sub(a, 0)) : VICTIM
      in
         V.setPred(Array.sub(a, n-1))
      end;
      for 1 (n-1) 1
         (fn i =>
            let
               structure V = unpack (Array.sub(a, i-1)) : VICTIM
            in
               V.setSucc(Array.sub(a, i))
            end);
      let
         structure V = unpack (Array.sub(a, n-1)) : VICTIM
      in
         V.setSucc(Array.sub(a, 0))
      end;
      let
         structure V = unpack (Array.sub(a, 0)) : VICTIM
      in
         V.kill(1, n)
      end;
      future last
   end;

inspect (josephus(40, 3));

(* Note: Thanks to Andreas for help in getting this working. *)
fun pipe (xs, n, h, f) =
   if (n <= h)
      then pipe(f(xs, n), n+1, h, f)
      else xs

fun josephus2 (n, k) =
   let
      datatype kill = Kill of int * int
      val last = promise()
      fun victim (nil, i) = nil
        | victim (Kill(x, s)::xr, i) =
            if (s = 1)
               then ( last ?= i; nil )
               else
                  if ((x mod k) = 0)
                     then Kill(x+1, s-1)::xr
                     else Kill(x+1, s)::(spawn victim(xr, i))
      val zs = promise()
   in
      zs ?= pipe(Kill(1, n)::(future zs), 1, n, fn (is, i) => spawn victim(is, i));
      future last
   end;

inspect (josephus2(40, 3));

(* 7.8.4 Active objects - Other active object abstractions *)

(* Synchronous active objects *)
(* Note: Requires dynamic dispatch - skipping for now *)

(* Active objects with exception handling *)
(* Note: Requires dynamic dispatch - skipping for now *)

(* 7.8.5 Active objects - Event manager with active objects *)

(* Note: Requires dynamic dispatch - skipping for now *)




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