Contributed by Chris Rathman
package Shapes is
-- Shape Class
type Shape_Rec is abstract tagged private;
type Shape_Ptr is access all Shape_Rec'Class;
-- Shape Methods
function GetX(This: Shape_Rec) return Integer;
function GetY(This: Shape_Rec) return Integer;
procedure SetX(This: in out Shape_Rec; Newx: Integer);
procedure SetY(This: in out Shape_Rec; Newy: Integer);
procedure AMoveTo(This: in out Shape_Rec; Newx: Integer; Newy: Integer);
procedure RMoveTo(This: in out Shape_Rec; Deltax: Integer; Deltay: Integer);
procedure Draw(This: Shape_Rec) is abstract;
private
type Shape_Rec is abstract tagged
record
X: Integer;
Y: Integer;
end record;
end Shapes;
|
with Shapes; use Shapes;
package body Shapes is
-- Accessors for X and Y
function GetX(This: Shape_Rec) return Integer is
begin
return This.X;
end GetX;
function GetY(This: Shape_Rec) return Integer is
begin
return This.Y;
end GetY;
procedure SetX(This: in out Shape_Rec; Newx: Integer) is
begin
This.X := Newx;
end SetX;
procedure SetY(This: in out Shape_Rec; Newy: Integer) is
begin
This.Y := Newy;
end SetY;
-- Move the Shape Position
procedure AMoveTo(This: in out Shape_Rec; Newx: Integer; Newy: Integer) is
begin
Setx(This, Newx);
Sety(This, Newy);
end AMoveTo;
procedure RMoveTo(This: in out Shape_Rec; Deltax: Integer; Deltay: Integer) is
begin
AMoveTo(This, Deltax + GetX(This), Deltay + GetY(This));
end RMoveTo;
end Shapes;
|
with Shapes; use Shapes;
package Rectangles is
-- Rectangle Class
type Rectangle_Rec is new Shape_Rec with private;
type Rectangle_Ptr is access all Rectangle_Rec'Class;
-- Rectangle Methods
function MakeRectangle(Newx: Integer; Newy: Integer;
Newwidth: Integer; Newheight: Integer) return Rectangle_Ptr;
function GetWidth(This: Rectangle_Rec) return Integer;
function GetHeight(This: Rectangle_Rec) return Integer;
procedure SetWidth(This: in out Rectangle_Rec; Newwidth: Integer);
procedure SetHeight(This: in out Rectangle_Rec; Newheight: Integer);
procedure Draw(This: Rectangle_Rec);
private
type Rectangle_Rec is new Shape_Rec with
record
Width: Integer;
Height: Integer;
end record;
end Rectangles;
|
with Rectangles; use Rectangles;
with TEXT_IO; use TEXT_IO;
package body Rectangles is
-- Rectangle Constructor
function MakeRectangle(Newx: Integer; Newy: Integer;
Newwidth: Integer; Newheight: Integer) return Rectangle_Ptr is
This: Rectangle_Ptr;
begin
This := new Rectangle_Rec;
AMoveTo(This.all, Newx, Newy);
SetWidth(This.all, Newwidth);
SetHeight(This.all, Newheight);
return This;
end MakeRectangle;
-- Accessors for Width and Height
function GetWidth(This: Rectangle_Rec) return Integer is
begin
return This.Width;
end GetWidth;
function GetHeight(This: Rectangle_Rec) return Integer is
begin
return This.Height;
end GetHeight;
procedure SetWidth(This: in out Rectangle_Rec; Newwidth: Integer) is
begin
This.Width := Newwidth;
end SetWidth;
procedure SetHeight(This: in out Rectangle_Rec; Newheight: Integer) is
begin
This.Height := Newheight;
end SetHeight;
-- Draw the Rectangle
procedure Draw(This: Rectangle_Rec) is
package INT_IO is new INTEGER_IO(Integer); use INT_IO;
begin
Put("Drawing a Rectangle at:(");
Put(GetX(This), WIDTH=>0);
Put(",");
Put(GetY(This), WIDTH=>0);
Put("), width ");
Put(GetWidth(This), WIDTH=>0);
Put(", height ");
Put(GetHeight(This), WIDTH=>0);
New_Line;
end Draw;
end Rectangles;
|
with Shapes; use Shapes;
package Circles is
-- Circle Class
type Circle_Rec is new Shape_Rec with private;
type Circle_Ptr is access all Circle_Rec'Class;
-- Circle Methods
function MakeCircle(Newx: Integer; Newy: Integer;
Newradius: Integer) return Circle_Ptr;
function GetRadius(This: Circle_Rec) return Integer;
procedure SetRadius(This: in out Circle_Rec; Newradius: Integer);
procedure Draw(This: Circle_Rec);
private
type Circle_Rec is new Shape_Rec with
record
Radius: Integer;
end record;
end Circles;
|
with Circles; use Circles;
with TEXT_IO; use TEXT_IO;
package body Circles is
-- Circle Constructor
function MakeCircle(Newx: Integer; Newy: Integer;
Newradius: Integer) return Circle_Ptr is
This: Circle_Ptr;
begin
This := new Circle_Rec;
AMoveTo(This.all, Newx, Newy);
SetRadius(This.all, Newradius);
return This;
end MakeCircle;
-- Accessors for Radius
function GetRadius(This: Circle_Rec) return Integer is
begin
return This.Radius;
end GetRadius;
procedure SetRadius(This: in out Circle_Rec; Newradius: Integer) is
begin
This.Radius := Newradius;
end SetRadius;
-- Draw the Circle
procedure Draw(This: Circle_Rec) is
package INT_IO is new INTEGER_IO(Integer); use INT_IO;
begin
Put("Drawing a Circle at:(");
Put(GetX(This), WIDTH=>0);
Put(",");
Put(GetY(This), WIDTH=>0);
Put("), radius ");
Put(GetRadius(This), WIDTH=>0);
New_Line;
end Draw;
end Circles;
|
with Shapes; use Shapes;
with Circles; use Circles;
with Rectangles; use Rectangles;
procedure Polymorph is
Scribble: array(1..2) of Shape_Ptr;
ARect: Rectangle_Ptr;
begin
-- set up some shape instances
Scribble(1) := Shape_Ptr(MakeRectangle(10, 20, 5, 6));
Scribble(2) := Shape_Ptr(MakeCircle(15, 25, 8));
-- iterate through some shapes and handle polymorphically
for I in Scribble'range loop
Draw(Scribble(I).all);
RMoveTo(Scribble(I).all, 100, 100);
Draw(Scribble(I).all);
end loop;
-- access a rectangle specific function
ARect := MakeRectangle(0, 0, 15, 15);
SetWidth(ARect.all, 30);
Draw(ARect.all);
end Polymorph;
|
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 |