add 170

labs_solar_system.gpr

@@ -12,6 +12,7 @@ project Labs_Solar_System is
        "Private_Types",
        "Access_Types",
        "Genericity",
+       "Multiple_Inheritance",
        "Exceptions",
        "Interfacing_With_C",
        "Tasking_Protected_Objects",
@@ -34,6 +35,7 @@ project Labs_Solar_System is
    Lab_Name := "";
    Lab_Languages := ("Ada");
    Lab_Source_Dir := ();
+   Lab_Switches_Ada := ();
    case Lab is
    when "Getting_Started" =>
       Lab_Number := "000";
@@ -62,6 +64,10 @@ project Labs_Solar_System is
       Lab_Number := "160";
       Lab_Name := "genericity";
       Lab_Source_Dir := ("src/" & Lab_Number & "_" & Lab_Name & "/common");
+   when "Multiple_Inheritance" =>
+      Lab_Number := "adv_170";
+      Lab_Name := "multiple_inheritance";
+      Lab_Switches_Ada := ("-gnatw_A");
    when "Exceptions" =>
       Lab_Number := "190";
       Lab_Name := "exceptions";
@@ -96,7 +102,7 @@ project Labs_Solar_System is
 
    package Compiler is
       for Default_Switches ("Ada") use Labs_Solar_System_Config.Ada_Compiler_Switches
-         & ("-O0", "-g", "-gnata");
+         & ("-O0", "-g", "-gnata") & Lab_Switches_Ada;
       for Default_Switches ("C") use ("-Wall", "-pedantic", "-Werror");
    end Compiler;
 

src/adv_170_multiple_inheritance/answers/multiple_inheritance_main.adb

@@ -0,0 +1,78 @@
+with Ada.Real_Time;         use Ada.Real_Time;
+with Mage;                  use Mage;
+with Mage.Draw;             use Mage.Draw;
+with Mage.Event;            use Mage.Event;
+with Solar_System;          use Solar_System;
+with Solar_System.Graphics; use Solar_System.Graphics;
+
+procedure Multiple_Inheritance_Main is
+
+   S : constant access Visible_Solar_System_T :=
+     Create_Visible (Create_Solar_System);
+
+   Next : Time;
+
+   Period : constant Time_Span := Milliseconds (40);
+
+   Window : Window_ID;
+   Canvas : Canvas_ID;
+
+   Sun        : access Still_Body_I'Class;
+   Black_Hole : access Orbiting_Body_I'Class;
+
+begin
+
+   --  create the main window
+   Window :=
+     Create_Window (Width => 240, Height => 320, Name => "Solar System");
+   --  retrieve the graphical canvas associated with the main window
+   Canvas := Get_Canvas (Window);
+
+   Sun := Create_Visible (Create_Still (0.0, 0.0), 20.0, Yellow);
+
+   S.Add_Still_Body (Sun);
+
+   S.Add_Moving_Body
+     (Create_Visible
+        (B =>
+           Create_Orbiting
+             (Distance     => 50.0, Speed => 0.02, Angle => 0.0,
+              Turns_Around => Sun),
+
+         Radius => 5.0, Color => Blue));
+
+   Black_Hole :=
+     Create_Orbiting
+       (Distance => 70.0, Speed => 0.01, Angle => 0.0, Turns_Around => Sun);
+   S.Add_Moving_Body (Black_Hole);
+
+   S.Add_Moving_Body
+     (Create_Visible
+        (B      =>
+           Create_Orbiting
+             (Distance     => 8.0, Speed => 0.1, Angle => 0.0,
+              Turns_Around => Black_Hole),
+         Radius => 1.0, Color => Red));
+
+   S.Add_Moving_Body
+     (Create_Visible
+        (B      =>
+           Create_Orbiting
+             (Distance     => 12.0, Speed => -0.1, Angle => 0.0,
+              Turns_Around => Black_Hole),
+         Radius => 1.0, Color => Red));
+
+   Next := Clock + Period;
+
+   while not Is_Killed loop
+
+      S.Move;
+      S.Draw (Canvas);
+
+      Handle_Events (Window);
+
+      delay until Next;
+      Next := Next + Period;
+   end loop;
+
+end Multiple_Inheritance_Main;

src/adv_170_multiple_inheritance/answers/solar_system-graphics.adb

@@ -0,0 +1,92 @@
+package body Solar_System.Graphics is
+
+   overriding function Get_X (Drawable : Visible_Body_Decorator_T)
+      return Float is
+   begin
+      return Drawable.Object_Ptr.Get_X;
+   end Get_X;
+
+   overriding function Get_Y (Drawable : Visible_Body_Decorator_T)
+      return Float is
+   begin
+      return Drawable.Object_Ptr.Get_Y;
+   end Get_Y;
+
+   overriding procedure Move (B : in out Visible_Orbiting_Body_T) is
+   begin
+      if B.Object_Ptr.all in Movable_I'Class then
+         Movable_I'Class (B.Object_Ptr.all).Move;
+      end if;
+   end Move;
+
+   function Create_Visible
+     (B : access Orbiting_Body_T; Radius : Float; Color : RGBA_T)
+      return access Visible_Orbiting_Body_T
+   is
+   begin
+      return
+        new Visible_Orbiting_Body_T'
+          (Graphic => (Radius => Radius, Color => Color), Object_Ptr => B);
+   end Create_Visible;
+
+   function Create_Visible
+     (B : access Still_Body_T; Radius : Float; Color : RGBA_T)
+      return access Visible_Still_Body_T
+   is
+   begin
+      return
+        new Visible_Still_Body_T'
+          (Graphic => (Radius => Radius, Color => Color), Object_Ptr => B);
+   end Create_Visible;
+
+   overriding procedure Draw
+      (Drawable : Visible_Body_Decorator_T; Canvas : Canvas_ID) is
+   begin
+      Draw_Sphere
+        (Canvas   => Canvas,
+         Position => (Drawable.Object_Ptr.X, Drawable.Object_Ptr.Y, 0.0),
+         Radius   => Drawable.Graphic.Radius, Color => Drawable.Graphic.Color);
+   end Draw;
+
+   function Create_Visible
+     (S : access Solar_System_T) return access Visible_Solar_System_T
+   is
+   begin
+      return new Visible_Solar_System_T'(Object_Ptr => S);
+   end Create_Visible;
+
+   overriding procedure Draw
+      (Drawable : Visible_Solar_System_T; Canvas : Canvas_ID) is
+   begin
+      for B of Drawable.Object_Ptr.Still_Objects loop
+         if Still_Body_I'Class (B.all) in Drawable_I'Class then
+            Drawable_I'Class (Still_Body_I'Class (B.all)).Draw (Canvas);
+         end if;
+      end loop;
+      for B of Drawable.Object_Ptr.Moving_Objects loop
+         if Movable_I'Class (B.all) in Drawable_I'Class then
+            Drawable_I'Class (Movable_I'Class (B.all)).Draw (Canvas);
+         end if;
+      end loop;
+   end Draw;
+
+   overriding procedure Move (B : in out Visible_Solar_System_T) is
+   begin
+      B.Object_Ptr.Move;
+   end Move;
+
+   overriding procedure Add_Still_Body
+     (S : in out Visible_Solar_System_T; B : access Still_Body_I'Class)
+   is
+   begin
+      S.Object_Ptr.Add_Still_Body (B);
+   end Add_Still_Body;
+
+   overriding procedure Add_Moving_Body
+     (S : in out Visible_Solar_System_T; B : access Movable_I'Class)
+   is
+   begin
+      S.Object_Ptr.Add_Moving_Body (B);
+   end Add_Moving_Body;
+
+end Solar_System.Graphics;

src/adv_170_multiple_inheritance/answers/solar_system-graphics.ads

@@ -0,0 +1,64 @@
+with Mage.Draw; use Mage.Draw;
+with Mage;      use Mage;
+
+package Solar_System.Graphics is
+
+   type Drawable_I is interface;
+   procedure Draw (Drawable : Drawable_I; Canvas : Canvas_ID) is abstract;
+
+   type Visible_Body_Decorator_T is
+     abstract new Drawable_I and Still_Body_I with private;
+   overriding procedure Draw
+     (Drawable : Visible_Body_Decorator_T; Canvas : Canvas_ID);
+   overriding function Get_X
+     (Drawable : Visible_Body_Decorator_T) return Float;
+   overriding function Get_Y
+     (Drawable : Visible_Body_Decorator_T) return Float;
+
+   type Visible_Orbiting_Body_T is
+     new Visible_Body_Decorator_T and Movable_I with private;
+   overriding procedure Move (B : in out Visible_Orbiting_Body_T);
+   function Create_Visible
+     (B : access Orbiting_Body_T; Radius : Float; Color : RGBA_T)
+      return access Visible_Orbiting_Body_T;
+
+   type Visible_Still_Body_T is new Visible_Body_Decorator_T with private;
+   function Create_Visible
+     (B : access Still_Body_T; Radius : Float; Color : RGBA_T)
+      return access Visible_Still_Body_T;
+
+   type Visible_Solar_System_T is
+     new Drawable_I and Solar_System_I with private;
+   function Create_Visible
+     (S : access Solar_System_T) return access Visible_Solar_System_T;
+   overriding procedure Add_Still_Body
+     (S : in out Visible_Solar_System_T; B : access Still_Body_I'Class);
+   overriding procedure Add_Moving_Body
+     (S : in out Visible_Solar_System_T; B : access Movable_I'Class);
+   overriding procedure Draw
+     (Drawable : Visible_Solar_System_T; Canvas : Canvas_ID);
+   overriding procedure Move (B : in out Visible_Solar_System_T);
+
+private
+
+   type Sphere_Type is record
+      Radius : Float;
+      Color  : RGBA_T;
+   end record;
+
+   type Visible_Body_Decorator_T is
+   abstract new Drawable_I and Still_Body_I with record
+      Graphic    : Sphere_Type;
+      Object_Ptr : access Body_Base_T'Class;
+   end record;
+
+   type Visible_Orbiting_Body_T is
+   new Visible_Body_Decorator_T and Movable_I with null record;
+
+   type Visible_Still_Body_T is new Visible_Body_Decorator_T with null record;
+
+   type Visible_Solar_System_T is new Drawable_I and Solar_System_I with record
+      Object_Ptr : access Solar_System_T;
+   end record;
+
+end Solar_System.Graphics;

src/adv_170_multiple_inheritance/answers/solar_system.adb

@@ -0,0 +1,68 @@
+with Float_Maths; use Float_Maths;
+
+package body Solar_System is
+
+   function Get_X (O : Body_Base_T) return Float is
+   begin
+      return O.X;
+   end Get_X;
+
+   function Get_Y (O : Body_Base_T) return Float is
+   begin
+      return O.Y;
+   end Get_Y;
+
+   function Create_Orbiting
+     (Distance     : Float; Speed : Float; Angle : Float;
+      Turns_Around : access Orbit_Ref_I'Class) return access Orbiting_Body_T
+   is
+   begin
+      return
+        new Orbiting_Body_T'
+          (X     => 0.0, Y => 0.0, Distance => Distance, Speed => Speed,
+           Angle => Angle, Turns_Around => Turns_Around);
+   end Create_Orbiting;
+
+   procedure Move (B : in out Orbiting_Body_T) is
+   begin
+
+      B.X := B.Turns_Around.Get_X + B.Distance * Cos (B.Angle);
+
+      B.Y := B.Turns_Around.Get_Y + B.Distance * Sin (B.Angle);
+
+      B.Angle := B.Angle + B.Speed;
+
+   end Move;
+
+   function Create_Still (X : Float; Y : Float) return access Still_Body_T is
+   begin
+      return new Still_Body_T'(X => X, Y => Y);
+   end Create_Still;
+
+   function Create_Solar_System return access Solar_System_T is
+   begin
+      return new Solar_System_T;
+   end Create_Solar_System;
+
+   procedure Add_Still_Body
+     (S : in out Solar_System_T; B : access Still_Body_I'Class)
+   is
+   begin
+      S.Still_Objects.Append (Still_Body_Access_I (B));
+   end Add_Still_Body;
+
+   procedure Add_Moving_Body
+     (S : in out Solar_System_T; B : access Movable_I'Class)
+   is
+   begin
+      S.Moving_Objects.Append (Moving_Access_I (B));
+   end Add_Moving_Body;
+
+   procedure Move (S : in out Solar_System_T) is
+   begin
+      for B of S.Moving_Objects loop
+         Movable_I'Class (B.all).Move;
+      end loop;
+   end Move;
+
+end Solar_System;