Solutions
Imperative Language
Hello World
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
begin
Put_Line ("Hello World!");
end Main;
Greetings
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
procedure Main is
procedure Greet (Name : String) is
begin
Put_Line ("Hello " & Name & "!");
end Greet;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Greet (Argument (1));
end Main;
Positive Or Negative
procedure Classify_Number (X : Integer);
with Ada.Text_IO; use Ada.Text_IO;
procedure Classify_Number (X : Integer) is
begin
if X > 0 then
Put_Line ("Positive");
elsif X < 0 then
Put_Line ("Negative");
else
Put_Line ("Zero");
end if;
end Classify_Number;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Classify_Number;
procedure Main is
A : Integer;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
A := Integer'Value (Argument (1));
Classify_Number (A);
end Main;
Numbers
procedure Display_Numbers (A, B : Integer);
with Ada.Text_IO; use Ada.Text_IO;
procedure Display_Numbers (A, B : Integer) is
X, Y : Integer;
begin
if A <= B then
X := A;
Y := B;
else
X := B;
Y := A;
end if;
for I in X .. Y loop
Put_Line (Integer'Image (I));
end loop;
end Display_Numbers;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Display_Numbers;
procedure Main is
A, B : Integer;
begin
if Argument_Count < 2 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 2 then
Put_Line ("Ignoring additional arguments...");
end if;
A := Integer'Value (Argument (1));
B := Integer'Value (Argument (2));
Display_Numbers (A, B);
end Main;
Subprograms
Subtract Procedure
procedure Subtract (A, B : Integer;
Result : out Integer);
procedure Subtract (A, B : Integer;
Result : out Integer) is
begin
Result := A - B;
end Subtract;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Subtract;
procedure Main is
type Test_Case_Index is
(Sub_10_1_Chk,
Sub_10_100_Chk,
Sub_0_5_Chk,
Sub_0_Minus_5_Chk);
procedure Check (TC : Test_Case_Index) is
Result : Integer;
begin
case TC is
when Sub_10_1_Chk =>
Subtract (10, 1, Result);
Put_Line ("Result: " & Integer'Image (Result));
when Sub_10_100_Chk =>
Subtract (10, 100, Result);
Put_Line ("Result: " & Integer'Image (Result));
when Sub_0_5_Chk =>
Subtract (0, 5, Result);
Put_Line ("Result: " & Integer'Image (Result));
when Sub_0_Minus_5_Chk =>
Subtract (0, -5, Result);
Put_Line ("Result: " & Integer'Image (Result));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Subtract Function
function Subtract (A, B : Integer) return Integer;
function Subtract (A, B : Integer) return Integer is
begin
return A - B;
end Subtract;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Subtract;
procedure Main is
type Test_Case_Index is
(Sub_10_1_Chk,
Sub_10_100_Chk,
Sub_0_5_Chk,
Sub_0_Minus_5_Chk);
procedure Check (TC : Test_Case_Index) is
Result : Integer;
begin
case TC is
when Sub_10_1_Chk =>
Result := Subtract (10, 1);
Put_Line ("Result: " & Integer'Image (Result));
when Sub_10_100_Chk =>
Result := Subtract (10, 100);
Put_Line ("Result: " & Integer'Image (Result));
when Sub_0_5_Chk =>
Result := Subtract (0, 5);
Put_Line ("Result: " & Integer'Image (Result));
when Sub_0_Minus_5_Chk =>
Result := Subtract (0, -5);
Put_Line ("Result: " & Integer'Image (Result));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Equality function
function Is_Equal (A, B : Integer) return Boolean;
function Is_Equal (A, B : Integer) return Boolean is
begin
return A = B;
end Is_Equal;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Is_Equal;
procedure Main is
type Test_Case_Index is
(Equal_Chk,
Inequal_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Display_Equal (A, B : Integer;
Equal : Boolean) is
begin
Put (Integer'Image (A));
if Equal then
Put (" is equal to ");
else
Put (" isn't equal to ");
end if;
Put_Line (Integer'Image (B) & ".");
end Display_Equal;
Result : Boolean;
begin
case TC is
when Equal_Chk =>
for I in 0 .. 10 loop
Result := Is_Equal (I, I);
Display_Equal (I, I, Result);
end loop;
when Inequal_Chk =>
for I in 0 .. 10 loop
Result := Is_Equal (I, I - 1);
Display_Equal (I, I - 1, Result);
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
States
procedure Display_State (State : Integer);
with Ada.Text_IO; use Ada.Text_IO;
procedure Display_State (State : Integer) is
begin
case State is
when 0 =>
Put_Line ("Off");
when 1 =>
Put_Line ("On: Simple Processing");
when 2 =>
Put_Line ("On: Advanced Processing");
when others =>
null;
end case;
end Display_State;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Display_State;
procedure Main is
State : Integer;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
State := Integer'Value (Argument (1));
Display_State (State);
end Main;
States #2
function Get_State (State : Integer) return String;
function Get_State (State : Integer) return String is
begin
return (case State is
when 0 => "Off",
when 1 => "On: Simple Processing",
when 2 => "On: Advanced Processing",
when others => "");
end Get_State;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Get_State;
procedure Main is
State : Integer;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
State := Integer'Value (Argument (1));
Put_Line (Get_State (State));
end Main;
States #3
function Is_On (State : Integer) return Boolean;
function Is_On (State : Integer) return Boolean is
begin
return not (State = 0);
end Is_On;
procedure Display_On_Off (State : Integer);
with Ada.Text_IO; use Ada.Text_IO;
with Is_On;
procedure Display_On_Off (State : Integer) is
begin
Put_Line (if Is_On (State) then "On" else "Off");
end Display_On_Off;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Display_On_Off;
with Is_On;
procedure Main is
State : Integer;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
State := Integer'Value (Argument (1));
Display_On_Off (State);
Put_Line (Boolean'Image (Is_On (State)));
end Main;
States #4
procedure Set_Next (State : in out Integer);
procedure Set_Next (State : in out Integer) is
begin
State := (if State < 2 then State + 1 else 0);
end Set_Next;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Set_Next;
procedure Main is
State : Integer;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
State := Integer'Value (Argument (1));
Set_Next (State);
Put_Line (Integer'Image (State));
end Main;
Modular Programming
Months
package Months is
Jan : constant String := "January";
Feb : constant String := "February";
Mar : constant String := "March";
Apr : constant String := "April";
May : constant String := "May";
Jun : constant String := "June";
Jul : constant String := "July";
Aug : constant String := "August";
Sep : constant String := "September";
Oct : constant String := "October";
Nov : constant String := "November";
Dec : constant String := "December";
procedure Display_Months;
end Months;
with Ada.Text_IO; use Ada.Text_IO;
package body Months is
procedure Display_Months is
begin
Put_Line ("Months:");
Put_Line ("- " & Jan);
Put_Line ("- " & Feb);
Put_Line ("- " & Mar);
Put_Line ("- " & Apr);
Put_Line ("- " & May);
Put_Line ("- " & Jun);
Put_Line ("- " & Jul);
Put_Line ("- " & Aug);
Put_Line ("- " & Sep);
Put_Line ("- " & Oct);
Put_Line ("- " & Nov);
Put_Line ("- " & Dec);
end Display_Months;
end Months;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Months; use Months;
procedure Main is
type Test_Case_Index is
(Months_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Months_Chk =>
Display_Months;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Operations
package Operations is
function Add (A, B : Integer) return Integer;
function Subtract (A, B : Integer) return Integer;
function Multiply (A, B : Integer) return Integer;
function Divide (A, B : Integer) return Integer;
end Operations;
package body Operations is
function Add (A, B : Integer) return Integer is
begin
return A + B;
end Add;
function Subtract (A, B : Integer) return Integer is
begin
return A - B;
end Subtract;
function Multiply (A, B : Integer) return Integer is
begin
return A * B;
end Multiply;
function Divide (A, B : Integer) return Integer is
begin
return A / B;
end Divide;
end Operations;
package Operations.Test is
procedure Display (A, B : Integer);
end Operations.Test;
with Ada.Text_IO; use Ada.Text_IO;
package body Operations.Test is
procedure Display (A, B : Integer) is
A_Str : constant String := Integer'Image (A);
B_Str : constant String := Integer'Image (B);
begin
Put_Line ("Operations:");
Put_Line (A_Str & " + " & B_Str & " = "
& Integer'Image (Add (A, B))
& ",");
Put_Line (A_Str & " - " & B_Str & " = "
& Integer'Image (Subtract (A, B))
& ",");
Put_Line (A_Str & " * " & B_Str & " = "
& Integer'Image (Multiply (A, B))
& ",");
Put_Line (A_Str & " / " & B_Str & " = "
& Integer'Image (Divide (A, B))
& ",");
end Display;
end Operations.Test;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Operations;
with Operations.Test; use Operations.Test;
procedure Main is
type Test_Case_Index is
(Operations_Chk,
Operations_Display_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Operations_Chk =>
Put_Line ("Add (100, 2) = "
& Integer'Image (Operations.Add (100, 2)));
Put_Line ("Subtract (100, 2) = "
& Integer'Image (Operations.Subtract (100, 2)));
Put_Line ("Multiply (100, 2) = "
& Integer'Image (Operations.Multiply (100, 2)));
Put_Line ("Divide (100, 2) = "
& Integer'Image (Operations.Divide (100, 2)));
when Operations_Display_Chk =>
Display (10, 5);
Display ( 1, 2);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Strongly typed language
Colors
package Color_Types is
type HTML_Color is
(Salmon,
Firebrick,
Red,
Darkred,
Lime,
Forestgreen,
Green,
Darkgreen,
Blue,
Mediumblue,
Darkblue);
function To_Integer (C : HTML_Color) return Integer;
type Basic_HTML_Color is
(Red,
Green,
Blue);
function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color;
end Color_Types;
package body Color_Types is
function To_Integer (C : HTML_Color) return Integer is
begin
case C is
when Salmon => return 16#FA8072#;
when Firebrick => return 16#B22222#;
when Red => return 16#FF0000#;
when Darkred => return 16#8B0000#;
when Lime => return 16#00FF00#;
when Forestgreen => return 16#228B22#;
when Green => return 16#008000#;
when Darkgreen => return 16#006400#;
when Blue => return 16#0000FF#;
when Mediumblue => return 16#0000CD#;
when Darkblue => return 16#00008B#;
end case;
end To_Integer;
function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color is
begin
case C is
when Red => return Red;
when Green => return Green;
when Blue => return Blue;
end case;
end To_HTML_Color;
end Color_Types;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Integer_Text_IO;
with Color_Types; use Color_Types;
procedure Main is
type Test_Case_Index is
(HTML_Color_Range,
HTML_Color_To_Integer,
Basic_HTML_Color_To_HTML_Color);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when HTML_Color_Range =>
for I in HTML_Color'Range loop
Put_Line (HTML_Color'Image (I));
end loop;
when HTML_Color_To_Integer =>
for I in HTML_Color'Range loop
Ada.Integer_Text_IO.Put (Item => To_Integer (I),
Width => 1,
Base => 16);
New_Line;
end loop;
when Basic_HTML_Color_To_HTML_Color =>
for I in Basic_HTML_Color'Range loop
Put_Line (HTML_Color'Image (To_HTML_Color (I)));
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Integers
package Int_Types is
type I_100 is range 0 .. 100;
type U_100 is mod 101;
function To_I_100 (V : U_100) return I_100;
function To_U_100 (V : I_100) return U_100;
type D_50 is new I_100 range 10 .. 50;
subtype S_50 is I_100 range 10 .. 50;
function To_D_50 (V : I_100) return D_50;
function To_S_50 (V : I_100) return S_50;
function To_I_100 (V : D_50) return I_100;
end Int_Types;
package body Int_Types is
function To_I_100 (V : U_100) return I_100 is
begin
return I_100 (V);
end To_I_100;
function To_U_100 (V : I_100) return U_100 is
begin
return U_100 (V);
end To_U_100;
function To_D_50 (V : I_100) return D_50 is
Min : constant I_100 := I_100 (D_50'First);
Max : constant I_100 := I_100 (D_50'Last);
begin
if V > Max then
return D_50'Last;
elsif V < Min then
return D_50'First;
else
return D_50 (V);
end if;
end To_D_50;
function To_S_50 (V : I_100) return S_50 is
begin
if V > S_50'Last then
return S_50'Last;
elsif V < S_50'First then
return S_50'First;
else
return V;
end if;
end To_S_50;
function To_I_100 (V : D_50) return I_100 is
begin
return I_100 (V);
end To_I_100;
end Int_Types;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Int_Types; use Int_Types;
procedure Main is
package I_100_IO is new Ada.Text_IO.Integer_IO (I_100);
package U_100_IO is new Ada.Text_IO.Modular_IO (U_100);
package D_50_IO is new Ada.Text_IO.Integer_IO (D_50);
use I_100_IO;
use U_100_IO;
use D_50_IO;
type Test_Case_Index is
(I_100_Range,
U_100_Range,
U_100_Wraparound,
U_100_To_I_100,
I_100_To_U_100,
D_50_Range,
S_50_Range,
I_100_To_D_50,
I_100_To_S_50,
D_50_To_I_100,
S_50_To_I_100);
procedure Check (TC : Test_Case_Index) is
begin
I_100_IO.Default_Width := 1;
U_100_IO.Default_Width := 1;
D_50_IO.Default_Width := 1;
case TC is
when I_100_Range =>
Put (I_100'First);
New_Line;
Put (I_100'Last);
New_Line;
when U_100_Range =>
Put (U_100'First);
New_Line;
Put (U_100'Last);
New_Line;
when U_100_Wraparound =>
Put (U_100'First - 1);
New_Line;
Put (U_100'Last + 1);
New_Line;
when U_100_To_I_100 =>
for I in U_100'Range loop
I_100_IO.Put (To_I_100 (I));
New_Line;
end loop;
when I_100_To_U_100 =>
for I in I_100'Range loop
Put (To_U_100 (I));
New_Line;
end loop;
when D_50_Range =>
Put (D_50'First);
New_Line;
Put (D_50'Last);
New_Line;
when S_50_Range =>
Put (S_50'First);
New_Line;
Put (S_50'Last);
New_Line;
when I_100_To_D_50 =>
for I in I_100'Range loop
Put (To_D_50 (I));
New_Line;
end loop;
when I_100_To_S_50 =>
for I in I_100'Range loop
Put (To_S_50 (I));
New_Line;
end loop;
when D_50_To_I_100 =>
for I in D_50'Range loop
Put (To_I_100 (I));
New_Line;
end loop;
when S_50_To_I_100 =>
for I in S_50'Range loop
Put (I);
New_Line;
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Temperatures
package Temperature_Types is
type Celsius is digits 6 range -273.15 .. 5504.85;
type Int_Celsius is range -273 .. 5505;
function To_Celsius (T : Int_Celsius) return Celsius;
function To_Int_Celsius (T : Celsius) return Int_Celsius;
type Kelvin is digits 6 range 0.0 .. 5778.00;
function To_Celsius (T : Kelvin) return Celsius;
function To_Kelvin (T : Celsius) return Kelvin;
end Temperature_Types;
package body Temperature_Types is
function To_Celsius (T : Int_Celsius) return Celsius is
Min : constant Float := Float (Celsius'First);
Max : constant Float := Float (Celsius'Last);
F : constant Float := Float (T);
begin
if F > Max then
return Celsius (Max);
elsif F < Min then
return Celsius (Min);
else
return Celsius (F);
end if;
end To_Celsius;
function To_Int_Celsius (T : Celsius) return Int_Celsius is
begin
return Int_Celsius (T);
end To_Int_Celsius;
function To_Celsius (T : Kelvin) return Celsius is
F : constant Float := Float (T);
begin
return Celsius (F - 273.15);
end To_Celsius;
function To_Kelvin (T : Celsius) return Kelvin is
F : constant Float := Float (T);
begin
return Kelvin (F + 273.15);
end To_Kelvin;
end Temperature_Types;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Temperature_Types; use Temperature_Types;
procedure Main is
package Celsius_IO is new Ada.Text_IO.Float_IO (Celsius);
package Kelvin_IO is new Ada.Text_IO.Float_IO (Kelvin);
package Int_Celsius_IO is new Ada.Text_IO.Integer_IO (Int_Celsius);
use Celsius_IO;
use Kelvin_IO;
use Int_Celsius_IO;
type Test_Case_Index is
(Celsius_Range,
Celsius_To_Int_Celsius,
Int_Celsius_To_Celsius,
Kelvin_To_Celsius,
Celsius_To_Kelvin);
procedure Check (TC : Test_Case_Index) is
begin
Celsius_IO.Default_Fore := 1;
Kelvin_IO.Default_Fore := 1;
Int_Celsius_IO.Default_Width := 1;
case TC is
when Celsius_Range =>
Put (Celsius'First);
New_Line;
Put (Celsius'Last);
New_Line;
when Celsius_To_Int_Celsius =>
Put (To_Int_Celsius (Celsius'First));
New_Line;
Put (To_Int_Celsius (0.0));
New_Line;
Put (To_Int_Celsius (Celsius'Last));
New_Line;
when Int_Celsius_To_Celsius =>
Put (To_Celsius (Int_Celsius'First));
New_Line;
Put (To_Celsius (0));
New_Line;
Put (To_Celsius (Int_Celsius'Last));
New_Line;
when Kelvin_To_Celsius =>
Put (To_Celsius (Kelvin'First));
New_Line;
Put (To_Celsius (0));
New_Line;
Put (To_Celsius (Kelvin'Last));
New_Line;
when Celsius_To_Kelvin =>
Put (To_Kelvin (Celsius'First));
New_Line;
Put (To_Kelvin (Celsius'Last));
New_Line;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Records
Directions
package Directions is
type Angle_Mod is mod 360;
type Direction is
(North,
Northeast,
East,
Southeast,
South,
Southwest,
West,
Northwest);
function To_Direction (N: Angle_Mod) return Direction;
type Ext_Angle is record
Angle_Elem : Angle_Mod;
Direction_Elem : Direction;
end record;
function To_Ext_Angle (N : Angle_Mod) return Ext_Angle;
procedure Display (N : Ext_Angle);
end Directions;
with Ada.Text_IO; use Ada.Text_IO;
package body Directions is
procedure Display (N : Ext_Angle) is
begin
Put_Line ("Angle: "
& Angle_Mod'Image (N.Angle_Elem)
& " => "
& Direction'Image (N.Direction_Elem)
& ".");
end Display;
function To_Direction (N : Angle_Mod) return Direction is
begin
case N is
when 0 => return North;
when 1 .. 89 => return Northeast;
when 90 => return East;
when 91 .. 179 => return Southeast;
when 180 => return South;
when 181 .. 269 => return Southwest;
when 270 => return West;
when 271 .. 359 => return Northwest;
end case;
end To_Direction;
function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is
begin
return (Angle_Elem => N,
Direction_Elem => To_Direction (N));
end To_Ext_Angle;
end Directions;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Directions; use Directions;
procedure Main is
type Test_Case_Index is
(Direction_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Direction_Chk =>
Display (To_Ext_Angle (0));
Display (To_Ext_Angle (30));
Display (To_Ext_Angle (45));
Display (To_Ext_Angle (90));
Display (To_Ext_Angle (91));
Display (To_Ext_Angle (120));
Display (To_Ext_Angle (180));
Display (To_Ext_Angle (250));
Display (To_Ext_Angle (270));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Colors
package Color_Types is
type HTML_Color is
(Salmon,
Firebrick,
Red,
Darkred,
Lime,
Forestgreen,
Green,
Darkgreen,
Blue,
Mediumblue,
Darkblue);
function To_Integer (C : HTML_Color) return Integer;
type Basic_HTML_Color is
(Red,
Green,
Blue);
function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color;
subtype Int_Color is Integer range 0 .. 255;
type RGB is record
Red : Int_Color;
Green : Int_Color;
Blue : Int_Color;
end record;
function To_RGB (C : HTML_Color) return RGB;
function Image (C : RGB) return String;
end Color_Types;
with Ada.Integer_Text_IO;
package body Color_Types is
function To_Integer (C : HTML_Color) return Integer is
begin
case C is
when Salmon => return 16#FA8072#;
when Firebrick => return 16#B22222#;
when Red => return 16#FF0000#;
when Darkred => return 16#8B0000#;
when Lime => return 16#00FF00#;
when Forestgreen => return 16#228B22#;
when Green => return 16#008000#;
when Darkgreen => return 16#006400#;
when Blue => return 16#0000FF#;
when Mediumblue => return 16#0000CD#;
when Darkblue => return 16#00008B#;
end case;
end To_Integer;
function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color is
begin
case C is
when Red => return Red;
when Green => return Green;
when Blue => return Blue;
end case;
end To_HTML_Color;
function To_RGB (C : HTML_Color) return RGB is
begin
case C is
when Salmon => return (16#FA#, 16#80#, 16#72#);
when Firebrick => return (16#B2#, 16#22#, 16#22#);
when Red => return (16#FF#, 16#00#, 16#00#);
when Darkred => return (16#8B#, 16#00#, 16#00#);
when Lime => return (16#00#, 16#FF#, 16#00#);
when Forestgreen => return (16#22#, 16#8B#, 16#22#);
when Green => return (16#00#, 16#80#, 16#00#);
when Darkgreen => return (16#00#, 16#64#, 16#00#);
when Blue => return (16#00#, 16#00#, 16#FF#);
when Mediumblue => return (16#00#, 16#00#, 16#CD#);
when Darkblue => return (16#00#, 16#00#, 16#8B#);
end case;
end To_RGB;
function Image (C : RGB) return String is
subtype Str_Range is Integer range 1 .. 10;
SR : String (Str_Range);
SG : String (Str_Range);
SB : String (Str_Range);
begin
Ada.Integer_Text_IO.Put (To => SR,
Item => C.Red,
Base => 16);
Ada.Integer_Text_IO.Put (To => SG,
Item => C.Green,
Base => 16);
Ada.Integer_Text_IO.Put (To => SB,
Item => C.Blue,
Base => 16);
return ("(Red => " & SR
& ", Green => " & SG
& ", Blue => " & SB
&")");
end Image;
end Color_Types;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Color_Types; use Color_Types;
procedure Main is
type Test_Case_Index is
(HTML_Color_To_RGB);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when HTML_Color_To_RGB =>
for I in HTML_Color'Range loop
Put_Line (HTML_Color'Image (I) & " => "
& Image (To_RGB (I)) & ".");
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Inventory
package Inventory_Pkg is
type Item_Name is
(Ballpoint_Pen, Oil_Based_Pen_Marker, Feather_Quill_Pen);
function To_String (I : Item_Name) return String;
type Item is record
Name : Item_Name;
Quantity : Natural;
Price : Float;
end record;
function Init (Name : Item_Name;
Quantity : Natural;
Price : Float) return Item;
procedure Add (Assets : in out Float;
I : Item);
end Inventory_Pkg;
with Ada.Text_IO; use Ada.Text_IO;
package body Inventory_Pkg is
function To_String (I : Item_Name) return String is
begin
case I is
when Ballpoint_Pen => return "Ballpoint Pen";
when Oil_Based_Pen_Marker => return "Oil-based Pen Marker";
when Feather_Quill_Pen => return "Feather Quill Pen";
end case;
end To_String;
function Init (Name : Item_Name;
Quantity : Natural;
Price : Float) return Item is
begin
Put_Line ("Item: " & To_String (Name) & ".");
return (Name => Name,
Quantity => Quantity,
Price => Price);
end Init;
procedure Add (Assets : in out Float;
I : Item) is
begin
Assets := Assets + Float (I.Quantity) * I.Price;
end Add;
end Inventory_Pkg;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Inventory_Pkg; use Inventory_Pkg;
procedure Main is
-- Remark: the following line is not relevant.
F : array (1 .. 10) of Float := (others => 42.42);
type Test_Case_Index is
(Inventory_Chk);
procedure Display (Assets : Float) is
package F_IO is new Ada.Text_IO.Float_IO (Float);
use F_IO;
begin
Put ("Assets: $");
Put (Assets, 1, 2, 0);
Put (".");
New_Line;
end Display;
procedure Check (TC : Test_Case_Index) is
I : Item;
Assets : Float := 0.0;
-- Please ignore the following three lines!
pragma Warnings (Off, "default initialization");
for Assets'Address use F'Address;
pragma Warnings (On, "default initialization");
begin
case TC is
when Inventory_Chk =>
I := Init (Ballpoint_Pen, 185, 0.15);
Add (Assets, I);
Display (Assets);
I := Init (Oil_Based_Pen_Marker, 100, 9.0);
Add (Assets, I);
Display (Assets);
I := Init (Feather_Quill_Pen, 2, 40.0);
Add (Assets, I);
Display (Assets);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Arrays
Constrained Array
package Constrained_Arrays is
type My_Index is range 1 .. 10;
type My_Array is array (My_Index) of Integer;
function Init return My_Array;
procedure Double (A : in out My_Array);
function First_Elem (A : My_Array) return Integer;
function Last_Elem (A : My_Array) return Integer;
function Length (A : My_Array) return Integer;
A : My_Array := (1, 2, others => 42);
end Constrained_Arrays;
package body Constrained_Arrays is
function Init return My_Array is
A : My_Array;
begin
for I in My_Array'Range loop
A (I) := Integer (I);
end loop;
return A;
end Init;
procedure Double (A : in out My_Array) is
begin
for I in A'Range loop
A (I) := A (I) * 2;
end loop;
end Double;
function First_Elem (A : My_Array) return Integer is
begin
return A (A'First);
end First_Elem;
function Last_Elem (A : My_Array) return Integer is
begin
return A (A'Last);
end Last_Elem;
function Length (A : My_Array) return Integer is
begin
return A'Length;
end Length;
end Constrained_Arrays;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Constrained_Arrays; use Constrained_Arrays;
procedure Main is
type Test_Case_Index is
(Range_Chk,
Array_Range_Chk,
A_Obj_Chk,
Init_Chk,
Double_Chk,
First_Elem_Chk,
Last_Elem_Chk,
Length_Chk);
procedure Check (TC : Test_Case_Index) is
AA : My_Array;
procedure Display (A : My_Array) is
begin
for I in A'Range loop
Put_Line (Integer'Image (A (I)));
end loop;
end Display;
procedure Local_Init (A : in out My_Array) is
begin
A := (100, 90, 80, 10, 20, 30, 40, 60, 50, 70);
end Local_Init;
begin
case TC is
when Range_Chk =>
for I in My_Index loop
Put_Line (My_Index'Image (I));
end loop;
when Array_Range_Chk =>
for I in My_Array'Range loop
Put_Line (My_Index'Image (I));
end loop;
when A_Obj_Chk =>
Display (A);
when Init_Chk =>
AA := Init;
Display (AA);
when Double_Chk =>
Local_Init (AA);
Double (AA);
Display (AA);
when First_Elem_Chk =>
Local_Init (AA);
Put_Line (Integer'Image (First_Elem (AA)));
when Last_Elem_Chk =>
Local_Init (AA);
Put_Line (Integer'Image (Last_Elem (AA)));
when Length_Chk =>
Put_Line (Integer'Image (Length (AA)));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Colors: Lookup-Table
package Color_Types is
type HTML_Color is
(Salmon,
Firebrick,
Red,
Darkred,
Lime,
Forestgreen,
Green,
Darkgreen,
Blue,
Mediumblue,
Darkblue);
subtype Int_Color is Integer range 0 .. 255;
type RGB is record
Red : Int_Color;
Green : Int_Color;
Blue : Int_Color;
end record;
function To_RGB (C : HTML_Color) return RGB;
function Image (C : RGB) return String;
type HTML_Color_RGB is array (HTML_Color) of RGB;
To_RGB_Lookup_Table : constant HTML_Color_RGB
:= (Salmon => (16#FA#, 16#80#, 16#72#),
Firebrick => (16#B2#, 16#22#, 16#22#),
Red => (16#FF#, 16#00#, 16#00#),
Darkred => (16#8B#, 16#00#, 16#00#),
Lime => (16#00#, 16#FF#, 16#00#),
Forestgreen => (16#22#, 16#8B#, 16#22#),
Green => (16#00#, 16#80#, 16#00#),
Darkgreen => (16#00#, 16#64#, 16#00#),
Blue => (16#00#, 16#00#, 16#FF#),
Mediumblue => (16#00#, 16#00#, 16#CD#),
Darkblue => (16#00#, 16#00#, 16#8B#));
end Color_Types;
with Ada.Integer_Text_IO;
package body Color_Types is
function To_RGB (C : HTML_Color) return RGB is
begin
return To_RGB_Lookup_Table (C);
end To_RGB;
function Image (C : RGB) return String is
subtype Str_Range is Integer range 1 .. 10;
SR : String (Str_Range);
SG : String (Str_Range);
SB : String (Str_Range);
begin
Ada.Integer_Text_IO.Put (To => SR,
Item => C.Red,
Base => 16);
Ada.Integer_Text_IO.Put (To => SG,
Item => C.Green,
Base => 16);
Ada.Integer_Text_IO.Put (To => SB,
Item => C.Blue,
Base => 16);
return ("(Red => " & SR
& ", Green => " & SG
& ", Blue => " & SB
&")");
end Image;
end Color_Types;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Color_Types; use Color_Types;
procedure Main is
type Test_Case_Index is
(Color_Table_Chk,
HTML_Color_To_Integer_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Color_Table_Chk =>
Put_Line ("Size of HTML_Color_RGB: "
& Integer'Image (HTML_Color_RGB'Length));
Put_Line ("Firebrick: "
& Image (To_RGB_Lookup_Table (Firebrick)));
when HTML_Color_To_Integer_Chk =>
for I in HTML_Color'Range loop
Put_Line (HTML_Color'Image (I) & " => "
& Image (To_RGB (I)) & ".");
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Unconstrained Array
package Unconstrained_Arrays is
type My_Array is array (Positive range <>) of Integer;
procedure Init (A : in out My_Array);
function Init (I, L : Positive) return My_Array;
procedure Double (A : in out My_Array);
function Diff_Prev_Elem (A : My_Array) return My_Array;
end Unconstrained_Arrays;
package body Unconstrained_Arrays is
procedure Init (A : in out My_Array) is
Y : Natural := A'Last;
begin
for I in A'Range loop
A (I) := Y;
Y := Y - 1;
end loop;
end Init;
function Init (I, L : Positive) return My_Array is
A : My_Array (I .. I + L - 1);
begin
Init (A);
return A;
end Init;
procedure Double (A : in out My_Array) is
begin
for I in A'Range loop
A (I) := A (I) * 2;
end loop;
end Double;
function Diff_Prev_Elem (A : My_Array) return My_Array is
A_Out : My_Array (A'Range);
begin
A_Out (A'First) := 0;
for I in A'First + 1 .. A'Last loop
A_Out (I) := A (I) - A (I - 1);
end loop;
return A_Out;
end Diff_Prev_Elem;
end Unconstrained_Arrays;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Unconstrained_Arrays; use Unconstrained_Arrays;
procedure Main is
type Test_Case_Index is
(Init_Chk,
Init_Proc_Chk,
Double_Chk,
Diff_Prev_Chk,
Diff_Prev_Single_Chk);
procedure Check (TC : Test_Case_Index) is
AA : My_Array (1 .. 5);
AB : My_Array (5 .. 9);
procedure Display (A : My_Array) is
begin
for I in A'Range loop
Put_Line (Integer'Image (A (I)));
end loop;
end Display;
procedure Local_Init (A : in out My_Array) is
begin
A := (1, 2, 5, 10, -10);
end Local_Init;
begin
case TC is
when Init_Chk =>
AA := Init (AA'First, AA'Length);
AB := Init (AB'First, AB'Length);
Display (AA);
Display (AB);
when Init_Proc_Chk =>
Init (AA);
Init (AB);
Display (AA);
Display (AB);
when Double_Chk =>
Local_Init (AB);
Double (AB);
Display (AB);
when Diff_Prev_Chk =>
Local_Init (AB);
AB := Diff_Prev_Elem (AB);
Display (AB);
when Diff_Prev_Single_Chk =>
declare
A1 : My_Array (1 .. 1) := (1 => 42);
begin
A1 := Diff_Prev_Elem (A1);
Display (A1);
end;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Product info
package Product_Info_Pkg is
subtype Quantity is Natural;
subtype Currency is Float;
type Product_Info is record
Units : Quantity;
Price : Currency;
end record;
type Product_Infos is array (Positive range <>) of Product_Info;
type Currency_Array is array (Positive range <>) of Currency;
procedure Total (P : Product_Infos;
Tot : out Currency_Array);
function Total (P : Product_Infos) return Currency_Array;
function Total (P : Product_Infos) return Currency;
end Product_Info_Pkg;
package body Product_Info_Pkg is
-- Get total for single product
function Total (P : Product_Info) return Currency is
(Currency (P.Units) * P.Price);
procedure Total (P : Product_Infos;
Tot : out Currency_Array) is
begin
for I in P'Range loop
Tot (I) := Total (P (I));
end loop;
end Total;
function Total (P : Product_Infos) return Currency_Array
is
Tot : Currency_Array (P'Range);
begin
Total (P, Tot);
return Tot;
end Total;
function Total (P : Product_Infos) return Currency
is
Tot : Currency := 0.0;
begin
for I in P'Range loop
Tot := Tot + Total (P (I));
end loop;
return Tot;
end Total;
end Product_Info_Pkg;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Product_Info_Pkg; use Product_Info_Pkg;
procedure Main is
package Currency_IO is new Ada.Text_IO.Float_IO (Currency);
type Test_Case_Index is
(Total_Func_Chk,
Total_Proc_Chk,
Total_Value_Chk);
procedure Check (TC : Test_Case_Index) is
subtype Test_Range is Positive range 1 .. 5;
P : Product_Infos (Test_Range);
Tots : Currency_Array (Test_Range);
Tot : Currency;
procedure Display (Tots : Currency_Array) is
begin
for I in Tots'Range loop
Currency_IO.Put (Tots (I));
New_Line;
end loop;
end Display;
procedure Local_Init (P : in out Product_Infos) is
begin
P := ((1, 0.5),
(2, 10.0),
(5, 40.0),
(10, 10.0),
(10, 20.0));
end Local_Init;
begin
Currency_IO.Default_Fore := 1;
Currency_IO.Default_Aft := 2;
Currency_IO.Default_Exp := 0;
case TC is
when Total_Func_Chk =>
Local_Init (P);
Tots := Total (P);
Display (Tots);
when Total_Proc_Chk =>
Local_Init (P);
Total (P, Tots);
Display (Tots);
when Total_Value_Chk =>
Local_Init (P);
Tot := Total (P);
Currency_IO.Put (Tot);
New_Line;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
String_10
package Strings_10 is
subtype String_10 is String (1 .. 10);
-- Using "type String_10 is..." is possible, too.
function To_String_10 (S : String) return String_10;
end Strings_10;
package body Strings_10 is
function To_String_10 (S : String) return String_10 is
S_Out : String_10;
begin
for I in String_10'First .. Integer'Min (String_10'Last, S'Last) loop
S_Out (I) := S (I);
end loop;
for I in Integer'Min (String_10'Last + 1, S'Last + 1) .. String_10'Last loop
S_Out (I) := ' ';
end loop;
return S_Out;
end To_String_10;
end Strings_10;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Strings_10; use Strings_10;
procedure Main is
type Test_Case_Index is
(String_10_Long_Chk,
String_10_Short_Chk);
procedure Check (TC : Test_Case_Index) is
SL : constant String := "And this is a long string just for testing...";
SS : constant String := "Hey!";
S_10 : String_10;
begin
case TC is
when String_10_Long_Chk =>
S_10 := To_String_10 (SL);
Put_Line (String (S_10));
when String_10_Short_Chk =>
S_10 := (others => ' ');
S_10 := To_String_10 (SS);
Put_Line (String (S_10));
end case;
end Check;
begin
if Argument_Count < 1 then
Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Ada.Text_IO.Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
List of Names
package Names_Ages is
Max_People : constant Positive := 10;
subtype Name_Type is String (1 .. 50);
type Age_Type is new Natural;
type Person is record
Name : Name_Type;
Age : Age_Type;
end record;
type People_Array is array (Positive range <>) of Person;
type People is record
People_A : People_Array (1 .. Max_People);
Last_Valid : Natural;
end record;
procedure Reset (P : in out People);
procedure Add (P : in out People;
Name : String);
function Get (P : People;
Name : String) return Age_Type;
procedure Update (P : in out People;
Name : String;
Age : Age_Type);
procedure Display (P : People);
end Names_Ages;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
package body Names_Ages is
function To_Name_Type (S : String) return Name_Type is
S_Out : Name_Type := (others => ' ');
begin
for I in 1 .. Integer'Min (S'Last, Name_Type'Last) loop
S_Out (I) := S (I);
end loop;
return S_Out;
end To_Name_Type;
procedure Init (P : in out Person;
Name : String) is
begin
P.Name := To_Name_Type (Name);
P.Age := 0;
end Init;
function Match (P : Person;
Name : String) return Boolean is
begin
return P.Name = To_Name_Type (Name);
end Match;
function Get (P : Person) return Age_Type is
begin
return P.Age;
end Get;
procedure Update (P : in out Person;
Age : Age_Type) is
begin
P.Age := Age;
end Update;
procedure Display (P : Person) is
begin
Put_Line ("NAME: " & Trim (P.Name, Right));
Put_Line ("AGE: " & Age_Type'Image (P.Age));
end Display;
procedure Reset (P : in out People) is
begin
P.Last_Valid := 0;
end Reset;
procedure Add (P : in out People;
Name : String) is
begin
P.Last_Valid := P.Last_Valid + 1;
Init (P.People_A (P.Last_Valid), Name);
end Add;
function Get (P : People;
Name : String) return Age_Type is
begin
for I in P.People_A'First .. P.Last_Valid loop
if Match (P.People_A (I), Name) then
return Get (P.People_A (I));
end if;
end loop;
return 0;
end Get;
procedure Update (P : in out People;
Name : String;
Age : Age_Type) is
begin
for I in P.People_A'First .. P.Last_Valid loop
if Match (P.People_A (I), Name) then
Update (P.People_A (I), Age);
end if;
end loop;
end Update;
procedure Display (P : People) is
begin
Put_Line ("LIST OF NAMES:");
for I in P.People_A'First .. P.Last_Valid loop
Display (P.People_A (I));
end loop;
end Display;
end Names_Ages;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Names_Ages; use Names_Ages;
procedure Main is
type Test_Case_Index is
(Names_Ages_Chk,
Get_Age_Chk);
procedure Check (TC : Test_Case_Index) is
P : People;
begin
case TC is
when Names_Ages_Chk =>
Reset (P);
Add (P, "John");
Add (P, "Patricia");
Add (P, "Josh");
Display (P);
Update (P, "John", 18);
Update (P, "Patricia", 35);
Update (P, "Josh", 53);
Display (P);
when Get_Age_Chk =>
Reset (P);
Add (P, "Peter");
Update (P, "Peter", 45);
Put_Line ("Peter is "
& Age_Type'Image (Get (P, "Peter"))
& " years old.");
end case;
end Check;
begin
if Argument_Count < 1 then
Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Ada.Text_IO.Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
More About Types
Aggregate Initialization
package Aggregates is
type Rec is record
W : Integer := 10;
X : Integer := 11;
Y : Integer := 12;
Z : Integer := 13;
end record;
type Int_Arr is array (1 .. 20) of Integer;
procedure Init (R : out Rec);
procedure Init_Some (A : out Int_Arr);
procedure Init (A : out Int_Arr);
end Aggregates;
package body Aggregates is
procedure Init (R : out Rec) is
begin
R := (X => 100,
Y => 200,
others => <>);
end Init;
procedure Init_Some (A : out Int_Arr) is
begin
A := (1 .. 5 => 99,
others => 100);
end Init_Some;
procedure Init (A : out Int_Arr) is
begin
A := (others => 5);
end Init;
end Aggregates;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Aggregates; use Aggregates;
procedure Main is
-- Remark: the following line is not relevant.
F : array (1 .. 10) of Float := (others => 42.42)
with Unreferenced;
type Test_Case_Index is
(Default_Rec_Chk,
Init_Rec_Chk,
Init_Some_Arr_Chk,
Init_Arr_Chk);
procedure Check (TC : Test_Case_Index) is
A : Int_Arr;
R : Rec;
DR : constant Rec := (others => <>);
begin
case TC is
when Default_Rec_Chk =>
R := DR;
Put_Line ("Record Default:");
Put_Line ("W => " & Integer'Image (R.W));
Put_Line ("X => " & Integer'Image (R.X));
Put_Line ("Y => " & Integer'Image (R.Y));
Put_Line ("Z => " & Integer'Image (R.Z));
when Init_Rec_Chk =>
Init (R);
Put_Line ("Record Init:");
Put_Line ("W => " & Integer'Image (R.W));
Put_Line ("X => " & Integer'Image (R.X));
Put_Line ("Y => " & Integer'Image (R.Y));
Put_Line ("Z => " & Integer'Image (R.Z));
when Init_Some_Arr_Chk =>
Init_Some (A);
Put_Line ("Array Init_Some:");
for I in A'Range loop
Put_Line (Integer'Image (I) & " "
& Integer'Image (A (I)));
end loop;
when Init_Arr_Chk =>
Init (A);
Put_Line ("Array Init:");
for I in A'Range loop
Put_Line (Integer'Image (I) & " "
& Integer'Image (A (I)));
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Versioning
package Versioning is
type Version is record
Major : Natural;
Minor : Natural;
Maintenance : Natural;
end record;
function Convert (V : Version) return String;
function Convert (V : Version) return Float;
end Versioning;
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
package body Versioning is
function Image_Trim (N : Natural) return String is
S_N : constant String := Trim (Natural'Image (N), Left);
begin
return S_N;
end Image_Trim;
function Convert (V : Version) return String is
S_Major : constant String := Image_Trim (V.Major);
S_Minor : constant String := Image_Trim (V.Minor);
S_Maint : constant String := Image_Trim (V.Maintenance);
begin
return (S_Major & "." & S_Minor & "." & S_Maint);
end Convert;
function Convert (V : Version) return Float is
begin
return Float (V.Major) + (Float (V.Minor) / 10.0);
end Convert;
end Versioning;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Versioning; use Versioning;
procedure Main is
type Test_Case_Index is
(Ver_String_Chk,
Ver_Float_Chk);
procedure Check (TC : Test_Case_Index) is
V : constant Version := (1, 3, 23);
begin
case TC is
when Ver_String_Chk =>
Put_Line (Convert (V));
when Ver_Float_Chk =>
Put_Line (Float'Image (Convert (V)));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Simple todo list
package Todo_Lists is
type Todo_Item is access String;
type Todo_Items is array (Positive range <>) of Todo_Item;
type Todo_List (Max_Len : Natural) is record
Items : Todo_Items (1 .. Max_Len);
Last : Natural := 0;
end record;
procedure Add (Todos : in out Todo_List;
Item : String);
procedure Display (Todos : Todo_List);
end Todo_Lists;
with Ada.Text_IO; use Ada.Text_IO;
package body Todo_Lists is
procedure Add (Todos : in out Todo_List;
Item : String) is
begin
if Todos.Last < Todos.Items'Last then
Todos.Last := Todos.Last + 1;
Todos.Items (Todos.Last) := new String'(Item);
else
Put_Line ("ERROR: list is full!");
end if;
end Add;
procedure Display (Todos : Todo_List) is
begin
Put_Line ("TO-DO LIST");
for I in Todos.Items'First .. Todos.Last loop
Put_Line (Todos.Items (I).all);
end loop;
end Display;
end Todo_Lists;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Todo_Lists; use Todo_Lists;
procedure Main is
type Test_Case_Index is
(Todo_List_Chk);
procedure Check (TC : Test_Case_Index) is
T : Todo_List (10);
begin
case TC is
when Todo_List_Chk =>
Add (T, "Buy milk");
Add (T, "Buy tea");
Add (T, "Buy present");
Add (T, "Buy tickets");
Add (T, "Pay electricity bill");
Add (T, "Schedule dentist appointment");
Add (T, "Call sister");
Add (T, "Revise spreasheet");
Add (T, "Edit entry page");
Add (T, "Select new design");
Add (T, "Create upgrade plan");
Display (T);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Price list
package Price_Lists is
type Price_Type is delta 0.01 digits 12;
type Price_List_Array is array (Positive range <>) of Price_Type;
type Price_List (Max : Positive) is record
List : Price_List_Array (1 .. Max);
Last : Natural := 0;
end record;
type Price_Result (Ok : Boolean) is record
case Ok is
when False =>
null;
when True =>
Price : Price_Type;
end case;
end record;
procedure Reset (Prices : in out Price_List);
procedure Add (Prices : in out Price_List;
Item : Price_Type);
function Get (Prices : Price_List;
Idx : Positive) return Price_Result;
procedure Display (Prices : Price_List);
end Price_Lists;
with Ada.Text_IO; use Ada.Text_IO;
package body Price_Lists is
procedure Reset (Prices : in out Price_List) is
begin
Prices.Last := 0;
end Reset;
procedure Add (Prices : in out Price_List;
Item : Price_Type) is
begin
if Prices.Last < Prices.List'Last then
Prices.Last := Prices.Last + 1;
Prices.List (Prices.Last) := Item;
else
Put_Line ("ERROR: list is full!");
end if;
end Add;
function Get (Prices : Price_List;
Idx : Positive) return Price_Result is
begin
if (Idx >= Prices.List'First and then
Idx <= Prices.Last) then
return Price_Result'(Ok => True,
Price => Prices.List (Idx));
else
return Price_Result'(Ok => False);
end if;
end Get;
procedure Display (Prices : Price_List) is
begin
Put_Line ("PRICE LIST");
for I in Prices.List'First .. Prices.Last loop
Put_Line (Price_Type'Image (Prices.List (I)));
end loop;
end Display;
end Price_Lists;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Price_Lists; use Price_Lists;
procedure Main is
type Test_Case_Index is
(Price_Type_Chk,
Price_List_Chk,
Price_List_Get_Chk);
procedure Check (TC : Test_Case_Index) is
L : Price_List (10);
procedure Local_Init_List is
begin
Reset (L);
Add (L, 1.45);
Add (L, 2.37);
Add (L, 3.21);
Add (L, 4.14);
Add (L, 5.22);
Add (L, 6.69);
Add (L, 7.77);
Add (L, 8.14);
Add (L, 9.99);
Add (L, 10.01);
end Local_Init_List;
procedure Get_Display (Idx : Positive) is
R : constant Price_Result := Get (L, Idx);
begin
Put_Line ("Attempt Get # " & Positive'Image (Idx));
if R.Ok then
Put_Line ("Element # " & Positive'Image (Idx)
& " => " & Price_Type'Image (R.Price));
else
declare
begin
Put_Line ("Element # " & Positive'Image (Idx)
& " => " & Price_Type'Image (R.Price));
exception
when others =>
Put_Line ("Element not available (as expected)");
end;
end if;
end Get_Display;
begin
case TC is
when Price_Type_Chk =>
Put_Line ("The delta value of Price_Type is "
& Price_Type'Image (Price_Type'Delta) & ";");
Put_Line ("The minimum value of Price_Type is "
& Price_Type'Image (Price_Type'First) & ";");
Put_Line ("The maximum value of Price_Type is "
& Price_Type'Image (Price_Type'Last) & ";");
when Price_List_Chk =>
Local_Init_List;
Display (L);
when Price_List_Get_Chk =>
Local_Init_List;
Get_Display (5);
Get_Display (40);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Privacy
Directions
package Directions is
type Angle_Mod is mod 360;
type Direction is
(North,
Northwest,
West,
Southwest,
South,
Southeast,
East);
function To_Direction (N : Angle_Mod) return Direction;
type Ext_Angle is private;
function To_Ext_Angle (N : Angle_Mod) return Ext_Angle;
procedure Display (N : Ext_Angle);
private
type Ext_Angle is record
Angle_Elem : Angle_Mod;
Direction_Elem : Direction;
end record;
end Directions;
with Ada.Text_IO; use Ada.Text_IO;
package body Directions is
procedure Display (N : Ext_Angle) is
begin
Put_Line ("Angle: "
& Angle_Mod'Image (N.Angle_Elem)
& " => "
& Direction'Image (N.Direction_Elem)
& ".");
end Display;
function To_Direction (N : Angle_Mod) return Direction is
begin
case N is
when 0 => return East;
when 1 .. 89 => return Northwest;
when 90 => return North;
when 91 .. 179 => return Northwest;
when 180 => return West;
when 181 .. 269 => return Southwest;
when 270 => return South;
when 271 .. 359 => return Southeast;
end case;
end To_Direction;
function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is
begin
return (Angle_Elem => N,
Direction_Elem => To_Direction (N));
end To_Ext_Angle;
end Directions;
with Directions; use Directions;
procedure Test_Directions is
type Ext_Angle_Array is array (Positive range <>) of Ext_Angle;
All_Directions : constant Ext_Angle_Array (1 .. 6)
:= (To_Ext_Angle (0),
To_Ext_Angle (45),
To_Ext_Angle (90),
To_Ext_Angle (91),
To_Ext_Angle (180),
To_Ext_Angle (270));
begin
for I in All_Directions'Range loop
Display (All_Directions (I));
end loop;
end Test_Directions;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Test_Directions;
procedure Main is
type Test_Case_Index is
(Direction_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Direction_Chk =>
Test_Directions;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Limited Strings
package Limited_Strings is
type Lim_String is limited private;
function Init (S : String) return Lim_String;
function Init (Max : Positive) return Lim_String;
procedure Put_Line (LS : Lim_String);
procedure Copy (From : Lim_String;
To : in out Lim_String);
function "=" (Ref, Dut : Lim_String) return Boolean;
private
type Lim_String is access String;
end Limited_Strings;
with Ada.Text_IO;
package body Limited_Strings
is
function Init (S : String) return Lim_String is
LS : constant Lim_String := new String'(S);
begin
return Ls;
end Init;
function Init (Max : Positive) return Lim_String is
LS : constant Lim_String := new String (1 .. Max);
begin
LS.all := (others => '_');
return LS;
end Init;
procedure Put_Line (LS : Lim_String) is
begin
Ada.Text_IO.Put_Line (LS.all);
end Put_Line;
function Get_Min_Last (A, B : Lim_String) return Positive is
begin
return Positive'Min (A'Last, B'Last);
end Get_Min_Last;
procedure Copy (From : Lim_String;
To : in out Lim_String) is
Min_Last : constant Positive := Get_Min_Last (From, To);
begin
To (To'First .. Min_Last) := From (To'First .. Min_Last);
To (Min_Last + 1 .. To'Last) := (others => '_');
end;
function "=" (Ref, Dut : Lim_String) return Boolean is
Min_Last : constant Positive := Get_Min_Last (Ref, Dut);
begin
for I in Dut'First .. Min_Last loop
if Dut (I) /= Ref (I) then
return False;
end if;
end loop;
return True;
end;
end Limited_Strings;
with Ada.Text_IO; use Ada.Text_IO;
with Limited_Strings; use Limited_Strings;
procedure Check_Lim_String is
S : constant String := "----------";
S1 : constant Lim_String := Init ("Hello World");
S2 : constant Lim_String := Init (30);
S3 : Lim_String := Init (5);
S4 : Lim_String := Init (S & S & S);
begin
Put ("S1 => ");
Put_Line (S1);
Put ("S2 => ");
Put_Line (S2);
if S1 = S2 then
Put_Line ("S1 is equal to S2.");
else
Put_Line ("S1 isn't equal to S2.");
end if;
Copy (From => S1, To => S3);
Put ("S3 => ");
Put_Line (S3);
if S1 = S3 then
Put_Line ("S1 is equal to S3.");
else
Put_Line ("S1 isn't equal to S3.");
end if;
Copy (From => S1, To => S4);
Put ("S4 => ");
Put_Line (S4);
if S1 = S4 then
Put_Line ("S1 is equal to S4.");
else
Put_Line ("S1 isn't equal to S4.");
end if;
end Check_Lim_String;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Check_Lim_String;
procedure Main is
type Test_Case_Index is
(Lim_String_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Lim_String_Chk =>
Check_Lim_String;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Generics
Display Array
generic
type T_Range is range <>;
type T_Element is private;
type T_Array is array (T_Range range <>) of T_Element;
with function Image (E : T_Element) return String;
procedure Display_Array (Header : String;
A : T_Array);
with Ada.Text_IO; use Ada.Text_IO;
procedure Display_Array (Header : String;
A : T_Array) is
begin
Put_Line (Header);
for I in A'Range loop
Put_Line (T_Range'Image (I) & ": " & Image (A (I)));
end loop;
end Display_Array;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Display_Array;
procedure Main is
type Test_Case_Index is (Int_Array_Chk,
Point_Array_Chk);
procedure Test_Int_Array is
type Int_Array is array (Positive range <>) of Integer;
procedure Display_Int_Array is new
Display_Array (T_Range => Positive,
T_Element => Integer,
T_Array => Int_Array,
Image => Integer'Image);
A : constant Int_Array (1 .. 5) := (1, 2, 5, 7, 10);
begin
Display_Int_Array ("Integers", A);
end Test_Int_Array;
procedure Test_Point_Array is
type Point is record
X : Float;
Y : Float;
end record;
type Point_Array is array (Natural range <>) of Point;
function Image (P : Point) return String is
begin
return "(" & Float'Image (P.X)
& ", " & Float'Image (P.Y) & ")";
end Image;
procedure Display_Point_Array is new
Display_Array (T_Range => Natural,
T_Element => Point,
T_Array => Point_Array,
Image => Image);
A : constant Point_Array (0 .. 3) := ((1.0, 0.5), (2.0, -0.5),
(5.0, 2.0), (-0.5, 2.0));
begin
Display_Point_Array ("Points", A);
end Test_Point_Array;
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Int_Array_Chk =>
Test_Int_Array;
when Point_Array_Chk =>
Test_Point_Array;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Average of Array of Float
generic
type T_Range is range <>;
type T_Element is digits <>;
type T_Array is array (T_Range range <>) of T_Element;
function Average (A : T_Array) return T_Element;
function Average (A : T_Array) return T_Element is
Acc : Float := 0.0;
begin
for I in A'Range loop
Acc := Acc + Float (A (I));
end loop;
return T_Element (Acc / Float (A'Length));
end Average;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Average;
procedure Main is
type Test_Case_Index is (Float_Array_Chk,
Digits_7_Float_Array_Chk);
procedure Test_Float_Array is
type Float_Array is array (Positive range <>) of Float;
function Average_Float is new
Average (T_Range => Positive,
T_Element => Float,
T_Array => Float_Array);
A : constant Float_Array (1 .. 5) := (1.0, 3.0, 5.0, 7.5, -12.5);
begin
Put_Line ("Average: " & Float'Image (Average_Float (A)));
end Test_Float_Array;
procedure Test_Digits_7_Float_Array is
type Custom_Float is digits 7 range 0.0 .. 1.0;
type Float_Array is
array (Integer range <>) of Custom_Float;
function Average_Float is new
Average (T_Range => Integer,
T_Element => Custom_Float,
T_Array => Float_Array);
A : constant Float_Array (-1 .. 3) := (0.5, 0.0, 1.0, 0.6, 0.5);
begin
Put_Line ("Average: "
& Custom_Float'Image (Average_Float (A)));
end Test_Digits_7_Float_Array;
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Float_Array_Chk =>
Test_Float_Array;
when Digits_7_Float_Array_Chk =>
Test_Digits_7_Float_Array;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Average of Array of Any Type
generic
type T_Range is range <>;
type T_Element is private;
type T_Array is array (T_Range range <>) of T_Element;
with function To_Float (E : T_Element) return Float is <>;
function Average (A : T_Array) return Float;
function Average (A : T_Array) return Float is
Acc : Float := 0.0;
begin
for I in A'Range loop
Acc := Acc + To_Float (A (I));
end loop;
return Acc / Float (A'Length);
end Average;
procedure Test_Item;
with Ada.Text_IO; use Ada.Text_IO;
with Average;
procedure Test_Item is
package F_IO is new Ada.Text_IO.Float_IO (Float);
type Amount is delta 0.01 digits 12;
type Item is record
Quantity : Natural;
Price : Amount;
end record;
type Item_Array is
array (Positive range <>) of Item;
function Get_Total (I : Item) return Float is
(Float (I.Quantity) * Float (I.Price));
function Get_Price (I : Item) return Float is
(Float (I.Price));
function Average_Total is new
Average (T_Range => Positive,
T_Element => Item,
T_Array => Item_Array,
To_Float => Get_Total);
function Average_Price is new
Average (T_Range => Positive,
T_Element => Item,
T_Array => Item_Array,
To_Float => Get_Price);
A : constant Item_Array (1 .. 4)
:= ((Quantity => 5, Price => 10.00),
(Quantity => 80, Price => 2.50),
(Quantity => 40, Price => 5.00),
(Quantity => 20, Price => 12.50));
begin
Put ("Average per item & quantity: ");
F_IO.Put (Average_Total (A), 3, 2, 0);
New_Line;
Put ("Average price: ");
F_IO.Put (Average_Price (A), 3, 2, 0);
New_Line;
end Test_Item;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Test_Item;
procedure Main is
type Test_Case_Index is (Item_Array_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Item_Array_Chk =>
Test_Item;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Generic list
generic
type Item is private;
type Items is array (Positive range <>) of Item;
Name : String;
List_Array : in out Items;
Last : in out Natural;
with procedure Put (I : Item) is <>;
package Gen_List is
procedure Init;
procedure Add (I : Item;
Status : out Boolean);
procedure Display;
end Gen_List;
with Ada.Text_IO; use Ada.Text_IO;
package body Gen_List is
procedure Init is
begin
Last := List_Array'First - 1;
end Init;
procedure Add (I : Item;
Status : out Boolean) is
begin
Status := Last < List_Array'Last;
if Status then
Last := Last + 1;
List_Array (Last) := I;
end if;
end Add;
procedure Display is
begin
Put_Line (Name);
for I in List_Array'First .. Last loop
Put (List_Array (I));
New_Line;
end loop;
end Display;
end Gen_List;
procedure Test_Int;
with Ada.Text_IO; use Ada.Text_IO;
with Gen_List;
procedure Test_Int is
procedure Put (I : Integer) is
begin
Ada.Text_IO.Put (Integer'Image (I));
end Put;
type Integer_Array is array (Positive range <>) of Integer;
A : Integer_Array (1 .. 3);
L : Natural;
package Int_List is new
Gen_List (Item => Integer,
Items => Integer_Array,
Name => "List of integers",
List_Array => A,
Last => L);
Success : Boolean;
procedure Display_Add_Success (Success : Boolean) is
begin
if Success then
Put_Line ("Added item successfully!");
else
Put_Line ("Couldn't add item!");
end if;
end Display_Add_Success;
begin
Int_List.Init;
Int_List.Add (2, Success);
Display_Add_Success (Success);
Int_List.Add (5, Success);
Display_Add_Success (Success);
Int_List.Add (7, Success);
Display_Add_Success (Success);
Int_List.Add (8, Success);
Display_Add_Success (Success);
Int_List.Display;
end Test_Int;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Test_Int;
procedure Main is
type Test_Case_Index is (Int_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Int_Chk =>
Test_Int;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Exceptions
Uninitialized Value
package Options is
type Option is (Uninitialized,
Option_1,
Option_2,
Option_3);
Uninitialized_Value : exception;
function Image (O : Option) return String;
end Options;
package body Options is
function Image (O : Option) return String is
begin
case O is
when Uninitialized =>
raise Uninitialized_Value with "Uninitialized value detected!";
when others =>
return Option'Image (O);
end case;
end Image;
end Options;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Exceptions; use Ada.Exceptions;
with Options; use Options;
procedure Main is
type Test_Case_Index is
(Options_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check (O : Option) is
begin
Put_Line (Image (O));
exception
when E : Uninitialized_Value =>
Put_Line (Exception_Message (E));
end Check;
begin
case TC is
when Options_Chk =>
for O in Option loop
Check (O);
end loop;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Numerical Exception
package Tests is
type Test_ID is (Test_1, Test_2);
Custom_Exception : exception;
procedure Num_Exception_Test (ID : Test_ID);
end Tests;
package body Tests is
pragma Warnings (Off, "variable ""C"" is assigned but never read");
procedure Num_Exception_Test (ID : Test_ID) is
A, B, C : Integer;
begin
case ID is
when Test_1 =>
A := Integer'Last;
B := Integer'Last;
C := A + B;
when Test_2 =>
raise Custom_Exception with "Custom_Exception raised!";
end case;
end Num_Exception_Test;
pragma Warnings (On, "variable ""C"" is assigned but never read");
end Tests;
with Tests; use Tests;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Exceptions; use Ada.Exceptions;
procedure Check_Exception (ID : Test_ID) is
begin
Num_Exception_Test (ID);
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected!");
when E : others =>
Put_Line (Exception_Message (E));
end Check_Exception;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Exceptions; use Ada.Exceptions;
with Tests; use Tests;
with Check_Exception;
procedure Main is
type Test_Case_Index is
(Exception_1_Chk,
Exception_2_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Handle_Exception (ID : Test_ID) is
begin
Check_Exception (ID);
exception
when Constraint_Error =>
Put_Line ("Constraint_Error"
& " (raised by Check_Exception) detected!");
when E : others =>
Put_Line (Exception_Name (E)
& " (raised by Check_Exception) detected!");
end Check_Handle_Exception;
begin
case TC is
when Exception_1_Chk =>
Check_Handle_Exception (Test_1);
when Exception_2_Chk =>
Check_Handle_Exception (Test_2);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Re-raising Exceptions
package Tests is
type Test_ID is (Test_1, Test_2);
Custom_Exception, Another_Exception : exception;
procedure Num_Exception_Test (ID : Test_ID);
end Tests;
package body Tests is
pragma Warnings (Off, "variable ""C"" is assigned but never read");
procedure Num_Exception_Test (ID : Test_ID) is
A, B, C : Integer;
begin
case ID is
when Test_1 =>
A := Integer'Last;
B := Integer'Last;
C := A + B;
when Test_2 =>
raise Custom_Exception with "Custom_Exception raised!";
end case;
end Num_Exception_Test;
pragma Warnings (On, "variable ""C"" is assigned but never read");
end Tests;
with Tests; use Tests;
procedure Check_Exception (ID : Test_ID);
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Exceptions; use Ada.Exceptions;
procedure Check_Exception (ID : Test_ID) is
begin
Num_Exception_Test (ID);
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected!");
raise;
when E : others =>
Put_Line (Exception_Message (E));
raise Another_Exception;
end Check_Exception;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Exceptions; use Ada.Exceptions;
with Tests; use Tests;
with Check_Exception;
procedure Main is
type Test_Case_Index is
(Exception_1_Chk,
Exception_2_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Handle_Exception (ID : Test_ID) is
begin
Check_Exception (ID);
exception
when Constraint_Error =>
Put_Line ("Constraint_Error"
& " (raised by Check_Exception) detected!");
when E : others =>
Put_Line (Exception_Name (E)
& " (raised by Check_Exception) detected!");
end Check_Handle_Exception;
begin
case TC is
when Exception_1_Chk =>
Check_Handle_Exception (Test_1);
when Exception_2_Chk =>
Check_Handle_Exception (Test_2);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Tasking
Display Service
package Display_Services is
task type Display_Service is
entry Display (S : String);
entry Display (I : Integer);
end Display_Service;
end Display_Services;
with Ada.Text_IO; use Ada.Text_IO;
package body Display_Services is
task body Display_Service is
begin
loop
select
accept Display (S : String) do
Put_Line (S);
end Display;
or
accept Display (I : Integer) do
Put_Line (Integer'Image (I));
end Display;
or
terminate;
end select;
end loop;
end Display_Service;
end Display_Services;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Display_Services; use Display_Services;
procedure Main is
type Test_Case_Index is (Display_Service_Chk);
procedure Check (TC : Test_Case_Index) is
Display : Display_Service;
begin
case TC is
when Display_Service_Chk =>
Display.Display ("Hello");
delay 0.5;
Display.Display ("Hello again");
delay 0.5;
Display.Display (55);
delay 0.5;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Event Manager
with Ada.Real_Time; use Ada.Real_Time;
package Event_Managers is
task type Event_Manager is
entry Start (ID : Natural);
entry Event (T : Time);
end Event_Manager;
end Event_Managers;
with Ada.Text_IO; use Ada.Text_IO;
package body Event_Managers is
task body Event_Manager is
Event_ID : Natural := 0;
Event_Delay : Time;
begin
accept Start (ID : Natural) do
Event_ID := ID;
end Start;
accept Event (T : Time) do
Event_Delay := T;
end Event;
delay until Event_Delay;
Put_Line ("Event #" & Natural'Image (Event_ID));
end Event_Manager;
end Event_Managers;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Event_Managers; use Event_Managers;
with Ada.Real_Time; use Ada.Real_Time;
procedure Main is
type Test_Case_Index is (Event_Manager_Chk);
procedure Check (TC : Test_Case_Index) is
Ev_Mng : array (1 .. 5) of Event_Manager;
begin
case TC is
when Event_Manager_Chk =>
for I in Ev_Mng'Range loop
Ev_Mng (I).Start (I);
end loop;
Ev_Mng (1).Event (Clock + Seconds (5));
Ev_Mng (2).Event (Clock + Seconds (3));
Ev_Mng (3).Event (Clock + Seconds (1));
Ev_Mng (4).Event (Clock + Seconds (2));
Ev_Mng (5).Event (Clock + Seconds (4));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Generic Protected Queue
generic
type Queue_Index is mod <>;
type T is private;
package Gen_Queues is
type Queue_Array is array (Queue_Index) of T;
protected type Queue is
function Empty return Boolean;
function Full return Boolean;
entry Push (V : T);
entry Pop (V : out T);
private
N : Natural := 0;
Idx : Queue_Index := Queue_Array'First;
A : Queue_Array;
end Queue;
end Gen_Queues;
package body Gen_Queues is
protected body Queue is
function Empty return Boolean is
(N = 0);
function Full return Boolean is
(N = A'Length);
entry Push (V : T) when not Full is
begin
A (Idx) := V;
Idx := Idx + 1;
N := N + 1;
end Push;
entry Pop (V : out T) when not Empty is
begin
N := N - 1;
V := A (Idx - Queue_Index (N) - 1);
end Pop;
end Queue;
end Gen_Queues;
package Queue_Tests is
procedure Simple_Test;
procedure Concurrent_Test;
end Queue_Tests;
with Ada.Text_IO; use Ada.Text_IO;
with Gen_Queues;
package body Queue_Tests is
Max : constant := 10;
type Queue_Mod is mod Max;
procedure Simple_Test is
package Queues_Float is new Gen_Queues (Queue_Mod, Float);
Q_F : Queues_Float.Queue;
V : Float;
begin
V := 10.0;
while not Q_F.Full loop
Q_F.Push (V);
V := V + 1.5;
end loop;
while not Q_F.Empty loop
Q_F.Pop (V);
Put_Line ("Value from queue: " & Float'Image (V));
end loop;
end Simple_Test;
procedure Concurrent_Test is
package Queues_Integer is new Gen_Queues (Queue_Mod, Integer);
Q_I : Queues_Integer.Queue;
task T_Producer;
task T_Consumer;
task body T_Producer is
V : Integer := 100;
begin
for I in 1 .. 2 * Max loop
Q_I.Push (V);
V := V + 1;
end loop;
end T_Producer;
task body T_Consumer is
V : Integer;
begin
delay 1.5;
while not Q_I.Empty loop
Q_I.Pop (V);
Put_Line ("Value from queue: " & Integer'Image (V));
delay 0.2;
end loop;
end T_Consumer;
begin
null;
end Concurrent_Test;
end Queue_Tests;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Queue_Tests; use Queue_Tests;
procedure Main is
type Test_Case_Index is (Simple_Queue_Chk,
Concurrent_Queue_Chk);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Simple_Queue_Chk =>
Simple_Test;
when Concurrent_Queue_Chk =>
Concurrent_Test;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Design by contracts
Price Range
package Prices is
type Amount is delta 10.0 ** (-2) digits 12;
-- subtype Price is Amount range 0.0 .. Amount'Last;
subtype Price is Amount
with Static_Predicate => Price >= 0.0;
end Prices;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with System.Assertions; use System.Assertions;
with Prices; use Prices;
procedure Main is
type Test_Case_Index is
(Price_Range_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Range (A : Amount) is
P : constant Price := A;
begin
Put_Line ("Price: " & Price'Image (P));
end Check_Range;
begin
case TC is
when Price_Range_Chk =>
Check_Range (-2.0);
end case;
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected (NOT as expected).");
when Assert_Failure =>
Put_Line ("Assert_Failure detected (as expected).");
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Pythagorean Theorem: Predicate
package Triangles is
subtype Length is Integer;
type Right_Triangle is record
H : Length := 0;
-- Hypotenuse
C1, C2 : Length := 0;
-- Catheti / legs
end record
with Dynamic_Predicate => H * H = C1 * C1 + C2 * C2;
function Init (H, C1, C2 : Length) return Right_Triangle is
((H, C1, C2));
end Triangles;
package Triangles.IO is
function Image (T : Right_Triangle) return String;
end Triangles.IO;
package body Triangles.IO is
function Image (T : Right_Triangle) return String is
("(" & Length'Image (T.H)
& ", " & Length'Image (T.C1)
& ", " & Length'Image (T.C2)
& ")");
end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with System.Assertions; use System.Assertions;
with Triangles; use Triangles;
with Triangles.IO; use Triangles.IO;
procedure Main is
type Test_Case_Index is
(Triangle_8_6_Pass_Chk,
Triangle_8_6_Fail_Chk,
Triangle_10_24_Pass_Chk,
Triangle_10_24_Fail_Chk,
Triangle_18_24_Pass_Chk,
Triangle_18_24_Fail_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Triangle (H, C1, C2 : Length) is
T : Right_Triangle;
begin
T := Init (H, C1, C2);
Put_Line (Image (T));
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected (NOT as expected).");
when Assert_Failure =>
Put_Line ("Assert_Failure detected (as expected).");
end Check_Triangle;
begin
case TC is
when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6);
when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6);
when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);
when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);
when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);
when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Pythagorean Theorem: Precondition
package Triangles is
subtype Length is Integer;
type Right_Triangle is record
H : Length := 0;
-- Hypotenuse
C1, C2 : Length := 0;
-- Catheti / legs
end record;
function Init (H, C1, C2 : Length) return Right_Triangle is
((H, C1, C2))
with Pre => H * H = C1 * C1 + C2 * C2;
end Triangles;
package Triangles.IO is
function Image (T : Right_Triangle) return String;
end Triangles.IO;
package body Triangles.IO is
function Image (T : Right_Triangle) return String is
("(" & Length'Image (T.H)
& ", " & Length'Image (T.C1)
& ", " & Length'Image (T.C2)
& ")");
end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with System.Assertions; use System.Assertions;
with Triangles; use Triangles;
with Triangles.IO; use Triangles.IO;
procedure Main is
type Test_Case_Index is
(Triangle_8_6_Pass_Chk,
Triangle_8_6_Fail_Chk,
Triangle_10_24_Pass_Chk,
Triangle_10_24_Fail_Chk,
Triangle_18_24_Pass_Chk,
Triangle_18_24_Fail_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Triangle (H, C1, C2 : Length) is
T : Right_Triangle;
begin
T := Init (H, C1, C2);
Put_Line (Image (T));
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected (NOT as expected).");
when Assert_Failure =>
Put_Line ("Assert_Failure detected (as expected).");
end Check_Triangle;
begin
case TC is
when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6);
when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6);
when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);
when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);
when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);
when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Pythagorean Theorem: Postcondition
package Triangles is
subtype Length is Integer;
type Right_Triangle is record
H : Length := 0;
-- Hypotenuse
C1, C2 : Length := 0;
-- Catheti / legs
end record;
function Init (H, C1, C2 : Length) return Right_Triangle is
((H, C1, C2))
with Post => (Init'Result.H * Init'Result.H
= Init'Result.C1 * Init'Result.C1
+ Init'Result.C2 * Init'Result.C2);
end Triangles;
package Triangles.IO is
function Image (T : Right_Triangle) return String;
end Triangles.IO;
package body Triangles.IO is
function Image (T : Right_Triangle) return String is
("(" & Length'Image (T.H)
& ", " & Length'Image (T.C1)
& ", " & Length'Image (T.C2)
& ")");
end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with System.Assertions; use System.Assertions;
with Triangles; use Triangles;
with Triangles.IO; use Triangles.IO;
procedure Main is
type Test_Case_Index is
(Triangle_8_6_Pass_Chk,
Triangle_8_6_Fail_Chk,
Triangle_10_24_Pass_Chk,
Triangle_10_24_Fail_Chk,
Triangle_18_24_Pass_Chk,
Triangle_18_24_Fail_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Triangle (H, C1, C2 : Length) is
T : Right_Triangle;
begin
T := Init (H, C1, C2);
Put_Line (Image (T));
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected (NOT as expected).");
when Assert_Failure =>
Put_Line ("Assert_Failure detected (as expected).");
end Check_Triangle;
begin
case TC is
when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6);
when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6);
when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);
when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);
when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);
when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Pythagorean Theorem: Type Invariant
package Triangles is
subtype Length is Integer;
type Right_Triangle is private
with Type_Invariant => Check (Right_Triangle);
function Check (T : Right_Triangle) return Boolean;
function Init (H, C1, C2 : Length) return Right_Triangle;
private
type Right_Triangle is record
H : Length := 0;
-- Hypotenuse
C1, C2 : Length := 0;
-- Catheti / legs
end record;
function Init (H, C1, C2 : Length) return Right_Triangle is
((H, C1, C2));
function Check (T : Right_Triangle) return Boolean is
(T.H * T.H = T.C1 * T.C1 + T.C2 * T.C2);
end Triangles;
package Triangles.IO is
function Image (T : Right_Triangle) return String;
end Triangles.IO;
package body Triangles.IO is
function Image (T : Right_Triangle) return String is
("(" & Length'Image (T.H)
& ", " & Length'Image (T.C1)
& ", " & Length'Image (T.C2)
& ")");
end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with System.Assertions; use System.Assertions;
with Triangles; use Triangles;
with Triangles.IO; use Triangles.IO;
procedure Main is
type Test_Case_Index is
(Triangle_8_6_Pass_Chk,
Triangle_8_6_Fail_Chk,
Triangle_10_24_Pass_Chk,
Triangle_10_24_Fail_Chk,
Triangle_18_24_Pass_Chk,
Triangle_18_24_Fail_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_Triangle (H, C1, C2 : Length) is
T : Right_Triangle;
begin
T := Init (H, C1, C2);
Put_Line (Image (T));
exception
when Constraint_Error =>
Put_Line ("Constraint_Error detected (NOT as expected).");
when Assert_Failure =>
Put_Line ("Assert_Failure detected (as expected).");
end Check_Triangle;
begin
case TC is
when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6);
when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6);
when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24);
when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24);
when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24);
when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Primary Colors
package Color_Types is
type HTML_Color is
(Salmon,
Firebrick,
Red,
Darkred,
Lime,
Forestgreen,
Green,
Darkgreen,
Blue,
Mediumblue,
Darkblue);
subtype Int_Color is Integer range 0 .. 255;
function Image (I : Int_Color) return String;
type RGB is record
Red : Int_Color;
Green : Int_Color;
Blue : Int_Color;
end record;
function To_RGB (C : HTML_Color) return RGB;
function Image (C : RGB) return String;
type HTML_Color_RGB_Array is array (HTML_Color) of RGB;
To_RGB_Lookup_Table : constant HTML_Color_RGB_Array
:= (Salmon => (16#FA#, 16#80#, 16#72#),
Firebrick => (16#B2#, 16#22#, 16#22#),
Red => (16#FF#, 16#00#, 16#00#),
Darkred => (16#8B#, 16#00#, 16#00#),
Lime => (16#00#, 16#FF#, 16#00#),
Forestgreen => (16#22#, 16#8B#, 16#22#),
Green => (16#00#, 16#80#, 16#00#),
Darkgreen => (16#00#, 16#64#, 16#00#),
Blue => (16#00#, 16#00#, 16#FF#),
Mediumblue => (16#00#, 16#00#, 16#CD#),
Darkblue => (16#00#, 16#00#, 16#8B#));
subtype HTML_RGB_Color is HTML_Color
with Static_Predicate => HTML_RGB_Color in Red | Green | Blue;
function To_Int_Color (C : HTML_Color;
S : HTML_RGB_Color) return Int_Color;
-- Convert to hexadecimal value for the selected RGB component S
end Color_Types;
with Ada.Integer_Text_IO;
package body Color_Types is
function To_RGB (C : HTML_Color) return RGB is
begin
return To_RGB_Lookup_Table (C);
end To_RGB;
function To_Int_Color (C : HTML_Color;
S : HTML_RGB_Color) return Int_Color is
C_RGB : constant RGB := To_RGB (C);
begin
case S is
when Red => return C_RGB.Red;
when Green => return C_RGB.Green;
when Blue => return C_RGB.Blue;
end case;
end To_Int_Color;
function Image (I : Int_Color) return String is
subtype Str_Range is Integer range 1 .. 10;
S : String (Str_Range);
begin
Ada.Integer_Text_IO.Put (To => S,
Item => I,
Base => 16);
return S;
end Image;
function Image (C : RGB) return String is
begin
return ("(Red => " & Image (C.Red)
& ", Green => " & Image (C.Green)
& ", Blue => " & Image (C.Blue)
&")");
end Image;
end Color_Types;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Color_Types; use Color_Types;
procedure Main is
type Test_Case_Index is
(HTML_Color_Red_Chk,
HTML_Color_Green_Chk,
HTML_Color_Blue_Chk);
procedure Check (TC : Test_Case_Index) is
procedure Check_HTML_Colors (S : HTML_RGB_Color) is
begin
Put_Line ("Selected: " & HTML_RGB_Color'Image (S));
for I in HTML_Color'Range loop
Put_Line (HTML_Color'Image (I) & " => "
& Image (To_Int_Color (I, S)) & ".");
end loop;
end Check_HTML_Colors;
begin
case TC is
when HTML_Color_Red_Chk =>
Check_HTML_Colors (Red);
when HTML_Color_Green_Chk =>
Check_HTML_Colors (Green);
when HTML_Color_Blue_Chk =>
Check_HTML_Colors (Blue);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Object-oriented programming
Simple type extension
package Type_Extensions is
type T_Float is tagged record
F : Float;
end record;
function Init (F : Float) return T_Float;
function Init (I : Integer) return T_Float;
function Image (T : T_Float) return String;
type T_Mixed is new T_Float with record
I : Integer;
end record;
function Init (F : Float) return T_Mixed;
function Init (I : Integer) return T_Mixed;
function Image (T : T_Mixed) return String;
end Type_Extensions;
package body Type_Extensions is
function Init (F : Float) return T_Float is
begin
return ((F => F));
end Init;
function Init (I : Integer) return T_Float is
begin
return ((F => Float (I)));
end Init;
function Init (F : Float) return T_Mixed is
begin
return ((F => F,
I => Integer (F)));
end Init;
function Init (I : Integer) return T_Mixed is
begin
return ((F => Float (I),
I => I));
end Init;
function Image (T : T_Float) return String is
begin
return "{ F => " & Float'Image (T.F) & " }";
end Image;
function Image (T : T_Mixed) return String is
begin
return "{ F => " & Float'Image (T.F)
& ", I => " & Integer'Image (T.I) & " }";
end Image;
end Type_Extensions;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Type_Extensions; use Type_Extensions;
procedure Main is
type Test_Case_Index is
(Type_Extension_Chk);
procedure Check (TC : Test_Case_Index) is
F1, F2 : T_Float;
M1, M2 : T_Mixed;
begin
case TC is
when Type_Extension_Chk =>
F1 := Init (2.0);
F2 := Init (3);
M1 := Init (4.0);
M2 := Init (5);
if M2 in T_Float'Class then
Put_Line ("T_Mixed is in T_Float'Class as expected");
end if;
Put_Line ("F1: " & Image (F1));
Put_Line ("F2: " & Image (F2));
Put_Line ("M1: " & Image (M1));
Put_Line ("M2: " & Image (M2));
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Online Store
with Ada.Calendar; use Ada.Calendar;
package Online_Store is
type Amount is delta 10.0**(-2) digits 10;
subtype Percentage is Amount range 0.0 .. 1.0;
type Member is tagged record
Start : Year_Number;
end record;
type Member_Access is access Member'Class;
function Get_Status (M : Member) return String;
function Get_Price (M : Member;
P : Amount) return Amount;
type Full_Member is new Member with record
Discount : Percentage;
end record;
function Get_Status (M : Full_Member) return String;
function Get_Price (M : Full_Member;
P : Amount) return Amount;
end Online_Store;
package body Online_Store is
function Get_Status (M : Member) return String is
("Associate Member");
function Get_Status (M : Full_Member) return String is
("Full Member");
function Get_Price (M : Member;
P : Amount) return Amount is (P);
function Get_Price (M : Full_Member;
P : Amount) return Amount is
(P * (1.0 - M.Discount));
end Online_Store;
package Online_Store.Tests is
procedure Simple_Test;
end Online_Store.Tests;
with Ada.Text_IO; use Ada.Text_IO;
package body Online_Store.Tests is
procedure Simple_Test is
type Member_Due_Amount is record
Member : Member_Access;
Due_Amount : Amount;
end record;
function Get_Price (MA : Member_Due_Amount) return Amount is
begin
return MA.Member.Get_Price (MA.Due_Amount);
end Get_Price;
type Member_Due_Amounts is array (Positive range <>) of Member_Due_Amount;
DB : constant Member_Due_Amounts (1 .. 4)
:= ((Member => new Member'(Start => 2010),
Due_Amount => 250.0),
(Member => new Full_Member'(Start => 1998,
Discount => 0.1),
Due_Amount => 160.0),
(Member => new Full_Member'(Start => 1987,
Discount => 0.2),
Due_Amount => 400.0),
(Member => new Member'(Start => 2013),
Due_Amount => 110.0));
begin
for I in DB'Range loop
Put_Line ("Member #" & Positive'Image (I));
Put_Line ("Status: " & DB (I).Member.Get_Status);
Put_Line ("Since: " & Year_Number'Image (DB (I).Member.Start));
Put_Line ("Due Amount: " & Amount'Image (Get_Price (DB (I))));
Put_Line ("--------");
end loop;
end Simple_Test;
end Online_Store.Tests;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Online_Store; use Online_Store;
with Online_Store.Tests; use Online_Store.Tests;
procedure Main is
type Test_Case_Index is
(Type_Chk,
Unit_Test_Chk);
procedure Check (TC : Test_Case_Index) is
function Result_Image (Result : Boolean) return String is
(if Result then "OK" else "not OK");
begin
case TC is
when Type_Chk =>
declare
AM : constant Member := (Start => 2002);
FM : constant Full_Member := (Start => 1990,
Discount => 0.2);
begin
Put_Line ("Testing Status of Associate Member Type => "
& Result_Image (AM.Get_Status = "Associate Member"));
Put_Line ("Testing Status of Full Member Type => "
& Result_Image (FM.Get_Status = "Full Member"));
Put_Line ("Testing Discount of Associate Member Type => "
& Result_Image (AM.Get_Price (100.0) = 100.0));
Put_Line ("Testing Discount of Full Member Type => "
& Result_Image (FM.Get_Price (100.0) = 80.0));
end;
when Unit_Test_Chk =>
Simple_Test;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Standard library: Containers
Simple todo list
with Ada.Containers.Vectors;
package Todo_Lists is
type Todo_Item is access String;
package Todo_List_Pkg is new Ada.Containers.Vectors
(Index_Type => Natural,
Element_Type => Todo_Item);
subtype Todo_List is Todo_List_Pkg.Vector;
procedure Add (Todos : in out Todo_List;
Item : String);
procedure Display (Todos : Todo_List);
end Todo_Lists;
with Ada.Text_IO; use Ada.Text_IO;
package body Todo_Lists is
procedure Add (Todos : in out Todo_List;
Item : String) is
begin
Todos.Append (new String'(Item));
end Add;
procedure Display (Todos : Todo_List) is
begin
Put_Line ("TO-DO LIST");
for T of Todos loop
Put_Line (T.all);
end loop;
end Display;
end Todo_Lists;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Todo_Lists; use Todo_Lists;
procedure Main is
type Test_Case_Index is
(Todo_List_Chk);
procedure Check (TC : Test_Case_Index) is
T : Todo_List;
begin
case TC is
when Todo_List_Chk =>
Add (T, "Buy milk");
Add (T, "Buy tea");
Add (T, "Buy present");
Add (T, "Buy tickets");
Add (T, "Pay electricity bill");
Add (T, "Schedule dentist appointment");
Add (T, "Call sister");
Add (T, "Revise spreasheet");
Add (T, "Edit entry page");
Add (T, "Select new design");
Add (T, "Create upgrade plan");
Display (T);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
List of unique integers
with Ada.Containers.Ordered_Sets;
package Ops is
type Int_Array is array (Positive range <>) of Integer;
package Integer_Sets is new Ada.Containers.Ordered_Sets
(Element_Type => Integer);
subtype Int_Set is Integer_Sets.Set;
function Get_Unique (A : Int_Array) return Int_Set;
function Get_Unique (A : Int_Array) return Int_Array;
end Ops;
package body Ops is
function Get_Unique (A : Int_Array) return Int_Set is
S : Int_Set;
begin
for E of A loop
S.Include (E);
end loop;
return S;
end Get_Unique;
function Get_Unique (A : Int_Array) return Int_Array is
S : constant Int_Set := Get_Unique (A);
AR : Int_Array (1 .. Positive (S.Length));
I : Positive := 1;
begin
for E of S loop
AR (I) := E;
I := I + 1;
end loop;
return AR;
end Get_Unique;
end Ops;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ops; use Ops;
procedure Main is
type Test_Case_Index is
(Get_Unique_Set_Chk,
Get_Unique_Array_Chk);
procedure Check (TC : Test_Case_Index;
A : Int_Array) is
procedure Display_Unique_Set (A : Int_Array) is
S : constant Int_Set := Get_Unique (A);
begin
for E of S loop
Put_Line (Integer'Image (E));
end loop;
end Display_Unique_Set;
procedure Display_Unique_Array (A : Int_Array) is
AU : constant Int_Array := Get_Unique (A);
begin
for E of AU loop
Put_Line (Integer'Image (E));
end loop;
end Display_Unique_Array;
begin
case TC is
when Get_Unique_Set_Chk => Display_Unique_Set (A);
when Get_Unique_Array_Chk => Display_Unique_Array (A);
end case;
end Check;
begin
if Argument_Count < 3 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
else
declare
A : Int_Array (1 .. Argument_Count - 1);
begin
for I in A'Range loop
A (I) := Integer'Value (Argument (1 + I));
end loop;
Check (Test_Case_Index'Value (Argument (1)), A);
end;
end if;
end Main;
Standard library: Dates & Times
Holocene calendar
with Ada.Calendar; use Ada.Calendar;
function To_Holocene_Year (T : Time) return Integer is
begin
return Year (T) + 10_000;
end To_Holocene_Year;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar; use Ada.Calendar;
with To_Holocene_Year;
procedure Main is
type Test_Case_Index is
(Holocene_Chk);
procedure Display_Holocene_Year (Y : Year_Number) is
HY : Integer;
begin
HY := To_Holocene_Year (Time_Of (Y, 1, 1));
Put_Line ("Year (Gregorian): " & Year_Number'Image (Y));
Put_Line ("Year (Holocene): " & Integer'Image (HY));
end Display_Holocene_Year;
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Holocene_Chk =>
Display_Holocene_Year (2012);
Display_Holocene_Year (2020);
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
List of events
with Ada.Containers.Vectors;
package Events is
type Event_Item is access String;
package Event_Item_Containers is new
Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Event_Item);
subtype Event_Items is Event_Item_Containers.Vector;
end Events;
with Ada.Calendar; use Ada.Calendar;
with Ada.Containers.Ordered_Maps;
package Events.Lists is
type Event_List is tagged private;
procedure Add (Events : in out Event_List;
Event_Time : Time;
Event : String);
procedure Display (Events : Event_List);
private
package Event_Time_Item_Containers is new
Ada.Containers.Ordered_Maps
(Key_Type => Time,
Element_Type => Event_Items,
"=" => Event_Item_Containers."=");
type Event_List is new Event_Time_Item_Containers.Map with null record;
end Events.Lists;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
package body Events.Lists is
procedure Add (Events : in out Event_List;
Event_Time : Time;
Event : String) is
use Event_Item_Containers;
E : constant Event_Item := new String'(Event);
begin
if not Events.Contains (Event_Time) then
Events.Include (Event_Time, Empty_Vector);
end if;
Events (Event_Time).Append (E);
end Add;
function Date_Image (T : Time) return String is
Date_Img : constant String := Image (T);
begin
return Date_Img (1 .. 10);
end;
procedure Display (Events : Event_List) is
use Event_Time_Item_Containers;
T : Time;
begin
Put_Line ("EVENTS LIST");
for C in Events.Iterate loop
T := Key (C);
Put_Line ("- " & Date_Image (T));
for I of Events (C) loop
Put_Line (" - " & I.all);
end loop;
end loop;
end Display;
end Events.Lists;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
with Events.Lists; use Events.Lists;
procedure Main is
type Test_Case_Index is
(Event_List_Chk);
procedure Check (TC : Test_Case_Index) is
EL : Event_List;
begin
case TC is
when Event_List_Chk =>
EL.Add (Time_Of (2018, 2, 16),
"Final check");
EL.Add (Time_Of (2018, 2, 16),
"Release");
EL.Add (Time_Of (2018, 12, 3),
"Brother's birthday");
EL.Add (Time_Of (2018, 1, 1),
"New Year's Day");
EL.Display;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Standard library: Strings
Concatenation
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package Str_Concat is
type Unbounded_Strings is array (Positive range <>) of Unbounded_String;
function Concat (USA : Unbounded_Strings;
Trim_Str : Boolean;
Add_Whitespace : Boolean) return Unbounded_String;
function Concat (USA : Unbounded_Strings;
Trim_Str : Boolean;
Add_Whitespace : Boolean) return String;
end Str_Concat;
with Ada.Strings; use Ada.Strings;
package body Str_Concat is
function Concat (USA : Unbounded_Strings;
Trim_Str : Boolean;
Add_Whitespace : Boolean) return Unbounded_String is
function Retrieve (USA : Unbounded_Strings;
Trim_Str : Boolean;
Index : Positive) return Unbounded_String is
US_Internal : Unbounded_String := USA (Index);
begin
if Trim_Str then
US_Internal := Trim (US_Internal, Both);
end if;
return US_Internal;
end Retrieve;
US : Unbounded_String := To_Unbounded_String ("");
begin
for I in USA'First .. USA'Last - 1 loop
US := US & Retrieve (USA, Trim_Str, I);
if Add_Whitespace then
US := US & " ";
end if;
end loop;
US := US & Retrieve (USA, Trim_Str, USA'Last);
return US;
end Concat;
function Concat (USA : Unbounded_Strings;
Trim_Str : Boolean;
Add_Whitespace : Boolean) return String is
begin
return To_String (Concat (USA, Trim_Str, Add_Whitespace));
end Concat;
end Str_Concat;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Str_Concat; use Str_Concat;
procedure Main is
type Test_Case_Index is
(Unbounded_Concat_No_Trim_No_WS_Chk,
Unbounded_Concat_Trim_No_WS_Chk,
String_Concat_Trim_WS_Chk,
Concat_Single_Element);
procedure Check (TC : Test_Case_Index) is
begin
case TC is
when Unbounded_Concat_No_Trim_No_WS_Chk =>
declare
S : constant Unbounded_Strings := (
To_Unbounded_String ("Hello"),
To_Unbounded_String (" World"),
To_Unbounded_String ("!"));
begin
Put_Line (To_String (Concat (S, False, False)));
end;
when Unbounded_Concat_Trim_No_WS_Chk =>
declare
S : constant Unbounded_Strings := (
To_Unbounded_String (" This "),
To_Unbounded_String (" _is_ "),
To_Unbounded_String (" a "),
To_Unbounded_String (" _check "));
begin
Put_Line (To_String (Concat (S, True, False)));
end;
when String_Concat_Trim_WS_Chk =>
declare
S : constant Unbounded_Strings := (
To_Unbounded_String (" This "),
To_Unbounded_String (" is a "),
To_Unbounded_String (" test. "));
begin
Put_Line (Concat (S, True, True));
end;
when Concat_Single_Element =>
declare
S : constant Unbounded_Strings := (
1 => To_Unbounded_String (" Hi "));
begin
Put_Line (Concat (S, True, True));
end;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
List of events
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Containers.Vectors;
package Events is
subtype Event_Item is Unbounded_String;
package Event_Item_Containers is new
Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Event_Item);
subtype Event_Items is Event_Item_Containers.Vector;
end Events;
with Ada.Calendar; use Ada.Calendar;
with Ada.Containers.Ordered_Maps;
package Events.Lists is
type Event_List is tagged private;
procedure Add (Events : in out Event_List;
Event_Time : Time;
Event : String);
procedure Display (Events : Event_List);
private
package Event_Time_Item_Containers is new
Ada.Containers.Ordered_Maps
(Key_Type => Time,
Element_Type => Event_Items,
"=" => Event_Item_Containers."=");
type Event_List is new Event_Time_Item_Containers.Map with null record;
end Events.Lists;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
package body Events.Lists is
procedure Add (Events : in out Event_List;
Event_Time : Time;
Event : String) is
use Event_Item_Containers;
E : constant Event_Item := To_Unbounded_String (Event);
begin
if not Events.Contains (Event_Time) then
Events.Include (Event_Time, Empty_Vector);
end if;
Events (Event_Time).Append (E);
end Add;
function Date_Image (T : Time) return String is
Date_Img : constant String := Image (T);
begin
return Date_Img (1 .. 10);
end;
procedure Display (Events : Event_List) is
use Event_Time_Item_Containers;
T : Time;
begin
Put_Line ("EVENTS LIST");
for C in Events.Iterate loop
T := Key (C);
Put_Line ("- " & Date_Image (T));
for I of Events (C) loop
Put_Line (" - " & To_String (I));
end loop;
end loop;
end Display;
end Events.Lists;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Calendar;
with Ada.Calendar.Formatting; use Ada.Calendar.Formatting;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Events;
with Events.Lists; use Events.Lists;
procedure Main is
type Test_Case_Index is
(Unbounded_String_Chk,
Event_List_Chk);
procedure Check (TC : Test_Case_Index) is
EL : Event_List;
begin
case TC is
when Unbounded_String_Chk =>
declare
S : constant Events.Event_Item := To_Unbounded_String ("Checked");
begin
Put_Line (To_String (S));
end;
when Event_List_Chk =>
EL.Add (Time_Of (2018, 2, 16),
"Final check");
EL.Add (Time_Of (2018, 2, 16),
"Release");
EL.Add (Time_Of (2018, 12, 3),
"Brother's birthday");
EL.Add (Time_Of (2018, 1, 1),
"New Year's Day");
EL.Display;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Standard library: Numerics
Decibel Factor
package Decibels is
subtype Decibel is Float;
subtype Factor is Float;
function To_Decibel (F : Factor) return Decibel;
function To_Factor (D : Decibel) return Factor;
end Decibels;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
package body Decibels is
function To_Decibel (F : Factor) return Decibel is
begin
return 20.0 * Log (F, 10.0);
end To_Decibel;
function To_Factor (D : Decibel) return Factor is
begin
return 10.0 ** (D / 20.0);
end To_Factor;
end Decibels;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Decibels; use Decibels;
procedure Main is
type Test_Case_Index is
(Db_Chk,
Factor_Chk);
procedure Check (TC : Test_Case_Index; V : Float) is
package F_IO is new Ada.Text_IO.Float_IO (Factor);
package D_IO is new Ada.Text_IO.Float_IO (Decibel);
procedure Put_Decibel_Cnvt (D : Decibel) is
F : constant Factor := To_Factor (D);
begin
D_IO.Put (D, 0, 2, 0);
Put (" dB => Factor of ");
F_IO.Put (F, 0, 2, 0);
New_Line;
end;
procedure Put_Factor_Cnvt (F : Factor) is
D : constant Decibel := To_Decibel (F);
begin
Put ("Factor of ");
F_IO.Put (F, 0, 2, 0);
Put (" => ");
D_IO.Put (D, 0, 2, 0);
Put_Line (" dB");
end;
begin
case TC is
when Db_Chk =>
Put_Decibel_Cnvt (Decibel (V));
when Factor_Chk =>
Put_Factor_Cnvt (Factor (V));
end case;
end Check;
begin
if Argument_Count < 2 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 2 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)), Float'Value (Argument (2)));
end Main;
Root-Mean-Square
package Signals is
subtype Sig_Value is Float;
type Signal is array (Natural range <>) of Sig_Value;
function Rms (S : Signal) return Sig_Value;
end Signals;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
package body Signals is
function Rms (S : Signal) return Sig_Value is
Acc : Float := 0.0;
begin
for V of S loop
Acc := Acc + V * V;
end loop;
return Sqrt (Acc / Float (S'Length));
end;
end Signals;
package Signals.Std is
Sample_Rate : Float := 8000.0;
function Generate_Sine (N : Positive; Freq : Float) return Signal;
function Generate_Square (N : Positive) return Signal;
function Generate_Triangular (N : Positive) return Signal;
end Signals.Std;
with Ada.Numerics; use Ada.Numerics;
with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions;
package body Signals.Std is
function Generate_Sine (N : Positive; Freq : Float) return Signal is
S : Signal (0 .. N - 1);
begin
for I in S'First .. S'Last loop
S (I) := 1.0 * Sin (2.0 * Pi * (Freq * Float (I) / Sample_Rate));
end loop;
return S;
end;
function Generate_Square (N : Positive) return Signal is
S : constant Signal (0 .. N - 1) := (others => 1.0);
begin
return S;
end;
function Generate_Triangular (N : Positive) return Signal is
S : Signal (0 .. N - 1);
S_Half : constant Natural := S'Last / 2;
begin
for I in S'First .. S_Half loop
S (I) := 1.0 * (Float (I) / Float (S_Half));
end loop;
for I in S_Half .. S'Last loop
S (I) := 1.0 - (1.0 * (Float (I - S_Half) / Float (S_Half)));
end loop;
return S;
end;
end Signals.Std;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Signals; use Signals;
with Signals.Std; use Signals.Std;
procedure Main is
type Test_Case_Index is
(Sine_Signal_Chk,
Square_Signal_Chk,
Triangular_Signal_Chk);
procedure Check (TC : Test_Case_Index) is
package Sig_IO is new Ada.Text_IO.Float_IO (Sig_Value);
N : constant Positive := 1024;
S_Si : constant Signal := Generate_Sine (N, 440.0);
S_Sq : constant Signal := Generate_Square (N);
S_Tr : constant Signal := Generate_Triangular (N + 1);
begin
case TC is
when Sine_Signal_Chk =>
Put ("RMS of Sine Signal: ");
Sig_IO.Put (Rms (S_Si), 0, 2, 0);
New_Line;
when Square_Signal_Chk =>
Put ("RMS of Square Signal: ");
Sig_IO.Put (Rms (S_Sq), 0, 2, 0);
New_Line;
when Triangular_Signal_Chk =>
Put ("RMS of Triangular Signal: ");
Sig_IO.Put (Rms (S_Tr), 0, 2, 0);
New_Line;
end case;
end Check;
begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)));
end Main;
Rotation
with Ada.Numerics.Complex_Types;
use Ada.Numerics.Complex_Types;
package Rotation is
type Complex_Points is array (Positive range <>) of Complex;
function Rotation (N : Positive) return Complex_Points;
end Rotation;
with Ada.Numerics; use Ada.Numerics;
package body Rotation is
function Rotation (N : Positive) return Complex_Points is
C_Angle : constant Complex :=
Compose_From_Polar (1.0, 2.0 * Pi / Float (N));
begin
return C : Complex_Points (1 .. N + 1) do
C (1) := Compose_From_Cartesian (1.0, 0.0);
for I in C'First + 1 .. C'Last loop
C (I) := C (I - 1) * C_Angle;
end loop;
end return;
end;
end Rotation;
with Rotation; use Rotation;
package Angles is
subtype Angle is Float;
type Angles is array (Positive range <>) of Angle;
function To_Angles (C : Complex_Points) return Angles;
end Angles;
with Ada.Numerics; use Ada.Numerics;
with Ada.Numerics.Complex_Types; use Ada.Numerics.Complex_Types;
package body Angles is
function To_Angles (C : Complex_Points) return Angles is
begin
return A : Angles (C'Range) do
for I in A'Range loop
A (I) := Argument (C (I)) / Pi * 180.0;
end loop;
end return;
end To_Angles;
end Angles;
package Rotation.Tests is
procedure Test_Rotation (N : Positive);
procedure Test_Angles (N : Positive);
end Rotation.Tests;
with Ada.Text_IO; use Ada.Text_IO;
with Ada.Text_IO.Complex_IO;
with Ada.Numerics; use Ada.Numerics;
with Angles; use Angles;
package body Rotation.Tests is
package C_IO is new Ada.Text_IO.Complex_IO (Complex_Types);
package F_IO is new Ada.Text_IO.Float_IO (Float);
--
-- Adapt value due to floating-point inaccuracies
--
function Adapt (C : Complex) return Complex is
function Check_Zero (F : Float) return Float is
(if F <= 0.0 and F >= -0.01 then 0.0 else F);
begin
return C_Out : Complex := C do
C_Out.Re := Check_Zero (C_Out.Re);
C_Out.Im := Check_Zero (C_Out.Im);
end return;
end Adapt;
function Adapt (A : Angle) return Angle is
(if A <= -179.99 and A >= -180.01 then 180.0 else A);
procedure Test_Rotation (N : Positive) is
C : constant Complex_Points := Rotation (N);
begin
Put_Line ("---- Points for " & Positive'Image (N) & " slices ----");
for V of C loop
Put ("Point: ");
C_IO.Put (Adapt (V), 0, 1, 0);
New_Line;
end loop;
end Test_Rotation;
procedure Test_Angles (N : Positive) is
C : constant Complex_Points := Rotation (N);
A : constant Angles.Angles := To_Angles (C);
begin
Put_Line ("---- Angles for " & Positive'Image (N) & " slices ----");
for V of A loop
Put ("Angle: ");
F_IO.Put (Adapt (V), 0, 2, 0);
Put_Line (" degrees");
end loop;
end Test_Angles;
end Rotation.Tests;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Text_IO; use Ada.Text_IO;
with Rotation.Tests; use Rotation.Tests;
procedure Main is
type Test_Case_Index is
(Rotation_Chk,
Angles_Chk);
procedure Check (TC : Test_Case_Index; N : Positive) is
begin
case TC is
when Rotation_Chk =>
Test_Rotation (N);
when Angles_Chk =>
Test_Angles (N);
end case;
end Check;
begin
if Argument_Count < 2 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 2 then
Put_Line ("Ignoring additional arguments...");
end if;
Check (Test_Case_Index'Value (Argument (1)), Positive'Value (Argument (2)));
end Main;