Rosetta Code

Visitor pattern: Difference between revisions

Page Discussion

Visitor pattern (view source)

Revision as of 01:55, 30 June 2024

926 bytes removed ,  5 days ago
changed to jere's much better approach
(Ada implementation with tagged types)
(changed to jere's much better approach)
 
Line 38:
An Ada implementation of the Wikipedia Java example.
===Method 1: via Tagged Types (the object-oriented approach)===
Perhaps more packages than needed (7), which makes for quite a few files (specification + implementation). OnlyAn the `Visitors` files are long; the rest are much shorter.overview:
* <code>Vehicle_Elements</code> (spec + body) provides a base <code>Element</code> class for <code>Car</code> and its parts, as well as an <code>Element_Interface</code> for visitors. It's sufficiently abstract that you could, in principle, easily define a <code>Bicycle</code>, or a <code>Truck</code>, or an <code>Airplane</code>.
<syntaxhighlight lang="ada">pragma Ada_2022;
* The elements of a <code>Car</code> are defined in:
 
:* <code>Bodies</code>
package Base is
:* <code>Engines</code>
:* <code>Wheels</code>
 
* <code>Car_Visitors</code> (spec + body) provides an implementation of <code>Element_Visitor</code> for <code>Cars</code>, defining two visitors:
type Base_Record is abstract tagged null record;
:* <code>Perform_Visitor</code>
:* <code>Print_Visitor</code>
* <code>Cars</code> (spec + body) "builds" a <code>Car</code> from its various parts and overrides <code>Accept_Visitor</code>.
* <code>Visitor_Pattern</code> instantiates a car and invokes both visitors on it.
====<code>Vehicle_Elements</code>====
<syntaxhighlight lang="ada">private with Ada.Strings.Unbounded;
 
package Vehicle_Elements is
end Base;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragma Ada_2022;
 
-- Forward declaration for visitor operation parameter
limited with Base;
type Element is tagged;
limited with Bodies;
limited with Cars;
limited with Engines;
limited with Wheels;
 
-- Generic visitor interface
package Visitors is
type Element_Visitor is interface;
 
-- Interface visiting procedure
type Visitor is abstract tagged null record;
procedure Visit
(Self : Element_Visitor;
Part : in out Vehicle_Elements.Element'Class) is abstract;
 
-- Base class type for all car things
procedure Visit_Base
type Element is abstract tagged private;
(Self : Visitor; Dest : Base.Base_Record'Class) is null;
 
-- Using 'Class here so I can provide a generic base class constructor
procedure Visit_Body (Self : Visitor; Dest : Bodies.Body_Record'Class);
-- Name - Name of the part: "Body", "Engine", "Wheel"
procedure Visit_Car (Self : Visitor; Dest : Cars.Car_Record'Class);
-- NOTE: When using to make an aggregate, type convert the result of this
procedure Visit_Engine (Self : Visitor; Dest : Engines.Engine_Record'Class);
-- operation to the Element type
procedure Visit_Wheel (Self : Visitor; Dest : Wheels.Wheel_Record'Class);
function Make (Name : String) return Element'Class;
 
-- To get the supplied name
type Perform is new Visitor with null record;
function Name (Self : Element'Class) return String;
type Print is new Visitor with null record;
 
overriding-- This procedure Visit_Bodycalls Visitor.Visit(Self) by default
-- We can't call it `Accept` because `accept` is an Ada keyword...
(Self : Perform; Dest : Bodies.Body_Record'Class);
overriding procedure Visit_BodyAccept_Visitor
(Self : Printin out Element; DestVisitor : Bodies.Body_RecordElement_Visitor'Class);
 
private
overriding procedure Visit_Car
(Self : Perform; Dest : Cars.Car_Record'Class);
overriding procedure Visit_Car (Self : Print; Dest : Cars.Car_Record'Class);
 
use Ada.Strings.Unbounded;
overriding procedure Visit_Engine
(Self : Perform; Dest : Engines.Engine_Record'Class);
overriding procedure Visit_Engine
(Self : Print; Dest : Engines.Engine_Record'Class);
 
type Element is abstract tagged record
overriding procedure Visit_Wheel
Name : Unbounded_String;
(Self : Perform; Dest : Wheels.Wheel_Record'Class);
end record;
overriding procedure Visit_Wheel
(Self : Print; Dest : Wheels.Wheel_Record'Class);
 
end VisitorsVehicle_Elements;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragmapackage Ada_2022;body Vehicle_Elements is
 
-- Need a non abstract type to actually work in the Make function
with Ada.Text_IO;
type Factory is new Element with null record;
with Ada.Strings.Unbounded;
use all type Ada.Strings.Unbounded.Unbounded_String;
 
function Make (Name : String) return Element'Class is
with Wheels;
(Factory'(Name => To_Unbounded_String (Name)));
 
function Name (Self : Element'Class) return String is
package body Visitors is
(To_String (Self.Name));
 
procedure Accept_Visitor
package IO renames Ada.Text_IO;
(Self : in out Element; Visitor : Element_Visitor'Class)
 
procedure Visit_Body (Self : Visitor; Dest : Bodies.Body_Record'Class) is
begin
Self.Visit_Body (Dest);
end Visit_Body;
 
overriding procedure Visit_Body
(Self : Perform; Dest : Bodies.Body_Record'Class)
is
begin
IOVisitor.Put_LineVisit ("Moving my Body"Self);
end Visit_BodyAccept_Visitor;
 
end Vehicle_Elements;
overriding procedure Visit_Body
</syntaxhighlight>
(Self : Print; Dest : Bodies.Body_Record'Class)
====<code>Car_Visitors</code>====
is
<syntaxhighlight lang="ada">with Vehicle_Elements;
begin
IO.Put_Line ("Visiting Body");
end Visit_Body;
 
package Car_Visitors is
procedure Visit_Car (Self : Visitor; Dest : Cars.Car_Record'Class) is
begin
Self.Visit_Car (Dest);
end Visit_Car;
 
type Print_Visitor is new Vehicle_Elements.Element_Visitor with null record;
overriding procedure Visit_Car
overriding procedure Visit
(Self : Perform; Dest : Cars.Car_Record'Class)
(Self : Print_Visitor; Part : in out Vehicle_Elements.Element'Class);
is
begin
IO.Put_Line ("Starting my car");
end Visit_Car;
 
type Perform_Visitor is
overriding procedure Visit_Car (Self : Print; Dest : Cars.Car_Record'Class)
new Vehicle_Elements.Element_Visitor with null record;
is
overriding procedure Visit
begin
(Self : Perform_Visitor; Part : in out Vehicle_Elements.Element'Class);
IO.Put_Line ("Visiting Car");
end Visit_Car;
 
end Car_Visitors;
procedure Visit_Engine (Self : Visitor; Dest : Engines.Engine_Record'Class)
</syntaxhighlight>
is
<syntaxhighlight lang="ada">with Ada.Text_IO; use Ada.Text_IO;
begin
with Bodies;
Self.Visit_Engine (Dest);
with Engines;
end Visit_Engine;
with Wheels;
with Cars;
 
package body Car_Visitors is
overriding procedure Visit_Engine
(Self : Perform; Dest : Engines.Engine_Record'Class)
is
begin
IO.Put_Line ("Revving my Engine");
end Visit_Engine;
 
overriding procedure Visit_EngineVisit
(Self : PrintPrint_Visitor; DestPart : Enginesin out Vehicle_Elements.Engine_RecordElement'Class)
is
begin
IO.Put_Line ("Visiting Engine" & Part.Name);
end Visit_EngineVisit;
 
overriding procedure Visit
procedure Visit_Wheel (Self : Visitor; Dest : Wheels.Wheel_Record'Class) is
(Self : Perform_Visitor; Part : in out Vehicle_Elements.Element'Class)
begin
Self.Visit_Wheel (Dest);
end Visit_Wheel;
 
overriding procedure Visit_Wheel
(Self : Perform; Dest : Wheels.Wheel_Record'Class)
is
begin
if Part in Cars.Car then
IO.Put_Line ("Rolling my " & To_String (Dest.Name) & " wheel");
Put_Line ("Starting the " & Part.Name);
end Visit_Wheel;
elsif Part in Bodies.Car_Body then
Put_Line ("Moving the " & Part.Name);
elsif Part in Engines.Engine then
Put_Line ("Revving the " & Part.Name);
elsif Part in Wheels.Wheel then
Put_Line ("Rolling the " & Part.Name);
else
raise Constraint_Error
with "Peform_Visitor does not support part type";
end if;
end Visit;
 
end Car_Visitors;
overriding procedure Visit_Wheel
(Self : Print; Dest : Wheels.Wheel_Record'Class)
is
begin
IO.Put_Line ("Visiting " & To_String (Dest.Name) & " wheel");
end Visit_Wheel;
 
end Visitors;
</syntaxhighlight>
====The parts of a <code>Car</code>====
<syntaxhighlight lang="ada">pragma Ada_2022;
<syntaxhighlight lang="ada">with Vehicle_Elements;
 
with Base;
 
limited with Visitors;
 
package Bodies is
 
type Body_RecordCar_Body is new BaseVehicle_Elements.Base_RecordElement with privatenull record;
function Make return Car_Body is
(Vehicle_Elements.Element (Vehicle_Elements.Make ("Body")) with
null record);
 
end Bodies;
procedure Visit (Self : Body_Record; Visitor : Visitors.Visitor'Class);
</syntaxhighlight>
<syntaxhighlight lang="ada">with Vehicle_Elements;
 
package Engines is
private
 
type Body_RecordEngine is new BaseVehicle_Elements.Base_RecordElement with null record;
function Make return Engine is
(Vehicle_Elements.Element (Vehicle_Elements.Make ("Engine")) with
null record);
 
end BodiesEngines;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragmawith Ada_2022Vehicle_Elements;
 
package Wheels is
with Visitors;
 
type Wheel is new Vehicle_Elements.Element with null record;
package body Bodies is
function Make (Name : String) return Wheel is
(Vehicle_Elements.Element (Vehicle_Elements.Make (Name & " Wheel")) with
null record);
 
end Wheels;
procedure Visit (Self : Body_Record; Visitor : Visitors.Visitor'Class) is
begin
Visitor.Visit_Body (Self);
end Visit;
 
end Bodies;
</syntaxhighlight>
====<code>Cars</code>====
<syntaxhighlight lang="ada">pragma Ada_2022;
<syntaxhighlight lang="ada">private with Wheels;
 
with Base;
with Bodies;
with Engines;
with WheelsVehicle_Elements;
 
limited with Visitors;
 
package Cars is
 
type Car_RecordCar is new BaseVehicle_Elements.Base_RecordElement with private;
 
overriding procedure Accept_Visitor
procedure Visit (Self : Car_Record; Visitor : Visitors.Visitor'Class);
(Self : in out Car; Visitor : Vehicle_Elements.Element_Visitor'Class);
 
function InitializeMake return Car_RecordCar;
 
private
 
type Wheel_Position is (Left_Front, Right_Front, Left_Back, Right_Back);
type Wheel_Array is array (1 .. 4) of Wheels.Wheel_Record;
 
type Car_RecordWheel_Array is newarray Base.Base_Record(Wheel_Position) withof recordWheels.Wheel;
 
Bod : Bodies.Body_Record;
type Car is new Vehicle_Elements.Element with record
Eng : Engines.Engine_Record;
WhsCar_Body : Wheel_ArrayBodies.Car_Body;
Engine : Engines.Engine;
All_Wheels : Wheel_Array;
end record;
 
Line 242 ⟶ 230:
</syntaxhighlight>
<syntaxhighlight lang="ada">pragma Ada_2022;
 
with Ada.Strings.Unbounded;
 
with Visitors;
 
package body Cars is
 
function Make return Car is
subtype Unbounded_String is Ada.Strings.Unbounded.Unbounded_String;
(Vehicle_Elements.Element (Vehicle_Elements.Make ("Car")) with
use all type Unbounded_String;
Car_Body => Bodies.Make, Engine => Engines.Make,
All_Wheels =>
(for Wheel in Wheel_Position => Wheels.Make (Wheel'Image)));
 
overriding procedure Accept_Visitor
procedure Visit (Self : Car_Record; Visitor : Visitors.Visitor'Class) is
(Self : in out Car; Visitor : Vehicle_Elements.Element_Visitor'Class)
is
begin
VisitorVehicle_Elements.Visit_CarElement (Self).Accept_Visitor (Visitor);
VisitorSelf.Visit_BodyCar_Body.Accept_Visitor (Self.BodVisitor);
VisitorSelf.Visit_EngineEngine.Accept_Visitor (Self.EngVisitor);
for Wheel of Self.WhsAll_Wheels loop
VisitorWheel.Visit_WheelAccept_Visitor (WheelVisitor);
end loop;
end VisitAccept_Visitor;
 
function Initialize return Car_Record is
Result : Car_Record;
begin
Result.Whs :=
[Wheels.Initialize (To_Unbounded_String ("front left")),
Wheels.Initialize (To_Unbounded_String ("front right")),
Wheels.Initialize (To_Unbounded_String ("back left")),
Wheels.Initialize (To_Unbounded_String ("back right"))];
return Result;
end Initialize;
 
end Cars;
</syntaxhighlight>
====Putting it all together====
<syntaxhighlight lang="ada">pragma Ada_2022;
<syntaxhighlight lang="ada">with Cars;
 
with BaseCar_Visitors;
 
limited with Visitors;
 
package Engines is
 
type Engine_Record is new Base.Base_Record with private;
 
procedure Visit (Self : Engine_Record; Visitor : Visitors.Visitor'Class);
 
private
 
type Engine_Record is new Base.Base_Record with null record;
 
end Engines;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragma Ada_2022;
 
with Visitors;
 
package body Engines is
 
procedure Visit (Self : Engine_Record; Visitor : Visitors.Visitor'Class) is
begin
Visitor.Visit_Engine (Self);
end Visit;
 
end Engines;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragma Ada_2022;
 
with Ada.Strings.Unbounded;
 
with Base;
 
limited with Visitors;
 
package Wheels is
 
subtype Unbounded_String is Ada.Strings.Unbounded.Unbounded_String;
use all type Unbounded_String;
 
type Wheel_Record is new Base.Base_Record with private;
 
procedure Visit (Self : Wheel_Record; Visitor : Visitors.Visitor'Class);
 
function Initialize (Name : Unbounded_String) return Wheel_Record;
 
function Name (Me : Wheel_Record) return Unbounded_String;
 
private
 
type Wheel_Record is new Base.Base_Record with record
My_Name : Unbounded_String;
end record;
 
end Wheels;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragma Ada_2022;
 
with Visitors;
 
package body Wheels is
 
procedure Visit (Self : Wheel_Record; Visitor : Visitors.Visitor'Class) is
begin
Visitor.Visit_Wheel (Self);
end Visit;
 
function Initialize (Name : Unbounded_String) return Wheel_Record is
(My_Name => Name);
 
function Name (Me : Wheel_Record) return Unbounded_String is (Me.My_Name);
 
end Wheels;
</syntaxhighlight>
<syntaxhighlight lang="ada">pragma Ada_2022;
 
with Cars;
with Visitors;
 
procedure Visitor_Pattern is
Car : Cars.Car_RecordCar := Cars.InitializeMake;
Printer : Car_Visitors.Print_Visitor;
Performer : aliased Visitors.Perform;
Performer : Car_Visitors.Perform_Visitor;
Printer : aliased Visitors.Print;
begin
Car.VisitAccept_Visitor (PerformerPrinter);
Car.VisitAccept_Visitor (PrinterPerformer);
end Visitor_Pattern;
</syntaxhighlight>
===Method 2: Discriminated Types===
Coming soon...
 
=={{header|Julia}}==
<syntaxhighlight lang="julia">abstract type CarElementVisitor end
Cantanima
14

edits

Retrieved from "https://rosettacode.org/wiki/Special:MobileDiff/365878"