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