Modula-2

Contributed by Chris Rathman

ShapeMod.def

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.

ShapeMod.mod

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.

RectangleMod.def

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.

RectangleMod.mod

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.

CircleMod.def

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.

CircleMod.mod

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.

MainProgram.mod

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.

Output

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

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