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