Contributed by Chris Rathman
DEFINITION MODULE ShapeMod;
(*** Note: Later M2 standards may have obsoleted the EXPORT statement.
If so, just remove it *)
EXPORT QUALIFIED Shape;
TYPE Shape;
END ShapeMod.
|
IMPLEMENTATION MODULE ShapeMod;
TYPE
Shape = POINTER TO RECORD
disposeThis: PROCEDURE (VAR Shape);
draw: PROCEDURE (Shape);
moveTo: PROCEDURE (Shape, INTEGER, INTEGER);
rMoveTo: PROCEDURE (Shape, INTEGER, INTEGER);
END;
(*
*** Note: The fields from the Shape structure must be placed first
in any subclass structure. If this Shape structure is redefined,
the structure must also be redefined in the subclasses to
maintain the one-to-one correspondance in the lead in fields.
*)
END ShapeMod.
|
DEFINITION MODULE RectangleMod;
(*** Note: The later M2 standard may have obsoleted the EXPORT statement.
If so, just remove it *)
EXPORT QUALIFIED Rectangle, MakeRectangle;
TYPE Rectangle;
PROCEDURE MakeRectangle(newx: INTEGER; newy: INTEGER;
newwidth: INTEGER; newheight: INTEGER): Rectangle;
END RectangleMod.
|
IMPLEMENTATION MODULE RectangleMod;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM StrIO IMPORT WriteLn, WriteString;
FROM NumberIO IMPORT WriteInt;
(*
*** Note: The later versions of M2 use the InOut Module to hold the
StrIO & NumberIO routines.
FROM InOut IMPORT WriteLn, WriteString, WriteInt;
*)
TYPE
Rectangle = POINTER TO RECORD
(* Fields to manually inherit from Shape superclass *)
disposeThis: PROCEDURE (VAR Rectangle);
draw: PROCEDURE (Rectangle);
moveTo: PROCEDURE (Rectangle, INTEGER, INTEGER);
rMoveTo: PROCEDURE (Rectangle, INTEGER, INTEGER);
(* Fields that are specific to Rectangle subclass *)
setWidth: PROCEDURE (Rectangle, INTEGER);
setHeight: PROCEDURE (Rectangle, INTEGER);
x: INTEGER;
y: INTEGER;
width: INTEGER;
height: INTEGER;
END;
(*
*** Note: The fields from the Shape structure must be placed first
in this structure. If the Shape structure is redefined, this
structure must also be redefined to maintain the one-to-one
correspondance in the lead in fields.
*)
(* move the shape to the specified x & y coordinates *)
PROCEDURE RectangleMoveTo(this: Rectangle; newx: INTEGER; newy: INTEGER);
BEGIN
this^.x := newx;
this^.y := newy;
END RectangleMoveTo;
(* move the shape to the specified x & y relative coordinates *)
PROCEDURE RectangleRMoveTo(this: Rectangle; newx: INTEGER; newy: INTEGER);
BEGIN
this^.x := this^.x + newx;
this^.y := this^.y + newy;
END RectangleRMoveTo;
(* set the width of the rectangle *)
PROCEDURE RectangleSetWidth(this: Rectangle; newwidth: INTEGER);
BEGIN
this^.width := newwidth;
END RectangleSetWidth;
(* set the height of the rectangle *)
PROCEDURE RectangleSetHeight(this: Rectangle; newheight: INTEGER);
BEGIN
this^.height := newheight;
END RectangleSetHeight;
(* draw the rectangle *)
PROCEDURE RectangleDraw(this: Rectangle);
BEGIN
WriteString("Drawing a Rectangle at:(");
WriteInt(this^.x, 1);
WriteString(",");
WriteInt(this^.y, 1);
WriteString("), width ");
WriteInt(this^.width, 1);
WriteString(", height ");
WriteInt(this^.height, 1);
WriteLn();
END RectangleDraw;
(* deallocate the rectangle instance *)
PROCEDURE RectangleDispose(VAR this: Rectangle);
BEGIN
DISPOSE(this);
END RectangleDispose;
(* allocate and initialize a Rectangle instance *)
PROCEDURE MakeRectangle(newx: INTEGER; newy: INTEGER;
newwidth: INTEGER; newheight: INTEGER): Rectangle;
VAR this: Rectangle;
BEGIN
(* allocate a new rectangle instance *)
NEW(this);
(* set up the functon pointers *)
this^.disposeThis := RectangleDispose;
this^.draw := RectangleDraw;
this^.moveTo := RectangleMoveTo;
this^.rMoveTo := RectangleRMoveTo;
this^.setWidth := RectangleSetWidth;
this^.setHeight := RectangleSetHeight;
(* initialize the instance attributes *)
this^.x := newx;
this^.y := newy;
this^.width := newwidth;
this^.height := newheight;
(* return a handle to the created instance *)
RETURN this;
END MakeRectangle;
END RectangleMod.
|
DEFINITION MODULE CircleMod;
(*** Note: The later M2 standard may have obsoleted the EXPORT statement.
If so, just remove it *)
EXPORT QUALIFIED Circle, MakeCircle;
TYPE Circle;
PROCEDURE MakeCircle(newx: INTEGER; newy: INTEGER; newradius: INTEGER): Circle;
END CircleMod.
|
IMPLEMENTATION MODULE CircleMod;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM StrIO IMPORT WriteLn, WriteString;
FROM NumberIO IMPORT WriteInt;
(*
*** Note: The later versions of M2 use the InOut Module to hold the
StrIO & NumberIO routines.
FROM InOut IMPORT WriteLn, WriteString, WriteInt;
*)
TYPE
Circle = POINTER TO RECORD
(* Fields to manually inherit from Shape superclass *)
disposeThis: PROCEDURE (VAR Circle);
draw: PROCEDURE (Circle);
moveTo: PROCEDURE (Circle, INTEGER, INTEGER);
rMoveTo: PROCEDURE (Circle, INTEGER, INTEGER);
(* Fields that are specific to Rectangle subclass *)
setRadius: PROCEDURE (Circle, INTEGER);
x: INTEGER;
y: INTEGER;
radius: INTEGER;
END;
(*
*** Note: The fields from the Shape structure must be placed first
in this structure. If the Shape structure is redefined, this
structure must also be redefined to maintain the one-to-one
correspondance in the lead in fields.
*)
(* move the shape to the specified x & y coordinates *)
PROCEDURE CircleMoveTo(this: Circle; newx: INTEGER; newy: INTEGER);
BEGIN
this^.x := newx;
this^.y := newy;
END CircleMoveTo;
(* move the shape to the specified x & y relative coordinates *)
PROCEDURE CircleRMoveTo(this: Circle; newx: INTEGER; newy: INTEGER);
BEGIN
this^.x := this^.x + newx;
this^.y := this^.y + newy;
END CircleRMoveTo;
(* set the radius of the circle *)
PROCEDURE CircleSetRadius(this: Circle; newradius: INTEGER);
BEGIN
this^.radius := newradius;
END CircleSetRadius;
(* draw the circle *)
PROCEDURE CircleDraw(this: Circle);
BEGIN
WriteString("Drawing a Circle at:(");
WriteInt(this^.x, 1);
WriteString(",");
WriteInt(this^.y, 1);
WriteString("), radius ");
WriteInt(this^.radius, 1);
WriteLn();
END CircleDraw;
(* deallocate the circle instance *)
PROCEDURE CircleDispose(VAR this: Circle);
BEGIN
DISPOSE(this);
END CircleDispose;
(* allocate and initialize a Circle instance *)
PROCEDURE MakeCircle(newx: INTEGER; newy: INTEGER; newradius: INTEGER): Circle;
VAR this: Circle;
BEGIN
(* allocate a new circle instance *)
NEW(this);
(* set up the functon pointers *)
this^.disposeThis := CircleDispose;
this^.draw := CircleDraw;
this^.moveTo := CircleMoveTo;
this^.rMoveTo := CircleRMoveTo;
this^.setRadius := CircleSetRadius;
(* initialize the instance attributes *)
this^.x := newx;
this^.y := newy;
this^.radius := newradius;
(* return a handle to the created instance *)
RETURN this;
END MakeCircle;
END CircleMod.
|
MODULE MainProgram;
FROM ShapeMod IMPORT Shape;
FROM CircleMod IMPORT Circle, MakeCircle;
FROM RectangleMod IMPORT Rectangle, MakeRectangle;
VAR
i: INTEGER;
scribble: ARRAY[1..2] OF Shape;
rect: Rectangle;
BEGIN
(* set up some shape instances *)
scribble[1] := Shape(MakeRectangle(10,20,5,6));
scribble[2] := Shape(MakeCircle(15,25,8));
(*
*** Note: I think the above form of the Type Transfer Function has
been obsoleted. Newer form is:
scribble[1] := SYSTEM.CAST(Shape, MakeRectangle(10,20,5,6));
scribble[2] := SYSTEM.CAST(Shape, MakeCircle(15,25,8));
*** Note: This form also requires an IMPORT statement at the
top of this module of the form:
FROM SYSTEM IMPORT CAST;
*** Note: It's possible that a Modula-2 compiler may complain about
the type casting here? I ran the code through the XDS
compiler and it went through with no complaints, but
the demo version does not allow executables so I didn't
get a chance to test it.
*)
(* iterate through the shapes and handle polymorphically *)
FOR i := 1 TO 2 DO
scribble[i]^.draw(scribble[i]);
scribble[i]^.rMoveTo(scribble[i], 100, 100);
scribble[i]^.draw(scribble[i]);
END;
(* access a rectangle specific function *)
rect := MakeRectangle(0,0,15,15);
rect^.setWidth(rect, 30);
rect^.draw(rect);
(* deallocate the shape instances *)
FOR i := 1 TO 2 DO
scribble[i]^.disposeThis(scribble[i]);
END;
rect^.disposeThis(rect);
END MainProgram.
|
Drawing a Rectangle at:(10,20), width 5, height 6 Drawing a Rectangle at:(110,120), width 5, height 6 Drawing a Circle at:(15,25), radius 8 Drawing a Circle at:(115,125), radius 8 Drawing a Rectangle at:(0,0), width 30, height 15 |