# Solutions

## Imperative Language

### Hello World

```

procedure Main is
begin
Put_Line ("Hello World!");
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Greetings

```

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
end if;

Greet (Argument (1));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Positive Or Negative

```

procedure Classify_Number (X : Integer);

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 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
end if;

A := Integer'Value (Argument (1));

Classify_Number (A);
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Numbers

```

procedure Display_Numbers (A, B : Integer);

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 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
end if;

A := Integer'Value (Argument (1));
B := Integer'Value (Argument (2));

Display_Numbers (A, B);
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Subtract Function

```

function Subtract (A, B : Integer) return Integer;

function Subtract (A, B : Integer) return Integer is
begin
return A - B;
end Subtract;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### States

```

procedure Display_State (State : Integer);

procedure Display_State (State : Integer) is
begin
case State is
when 0 =>
Put_Line ("Off");
when 1 =>
Put_Line ("On: Simple Processing");
when 2 =>
when others =>
null;
end case;
end Display_State;

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
end if;

State := Integer'Value (Argument (1));

Display_State (State);
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

State := Integer'Value (Argument (1));

Put_Line (Get_State (State));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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 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
end if;

State := Integer'Value (Argument (1));

Display_On_Off (State);
Put_Line (Boolean'Image (Is_On (State)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

State := Integer'Value (Argument (1));

Set_Next (State);
Put_Line (Integer'Image (State));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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;

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 & " = "
& ",");
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 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) = "
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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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 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
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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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
Item  => C.Red,
Base  => 16);
Item  => C.Green,
Base  => 16);
Item  => C.Blue,
Base  => 16);
return ("(Red => " & SR
& ", Green => " & SG
& ", Blue => "  & SB
&")");
end Image;

end Color_Types;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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 Inventory_Pkg;

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");
pragma Warnings (On, "default initialization");
begin
case TC is
when Inventory_Chk =>
I := Init (Ballpoint_Pen,        185,  0.15);
Display (Assets);

I := Init (Oil_Based_Pen_Marker, 100,  9.0);
Display (Assets);

I := Init (Feather_Quill_Pen,      2, 40.0);
Display (Assets);
end case;
end Check;

begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

package body Color_Types is

function To_RGB (C : HTML_Color) return RGB is
begin
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
Item  => C.Red,
Base  => 16);
Item  => C.Green,
Base  => 16);
Item  => C.Blue,
Base  => 16);
return ("(Red => " & SR
& ", Green => " & SG
& ", Blue => "  & SB
&")");
end Image;

end Color_Types;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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);
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;
end Total;

end Product_Info_Pkg;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
return;
elsif Argument_Count > 1 then
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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);

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 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);
Display (P);
Update (P, "John",     18);
Update (P, "Patricia", 35);
Update (P, "Josh",     53);
Display (P);
when Get_Age_Chk =>
Reset (P);
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
return;
elsif Argument_Count > 1 then
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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;

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 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 =>
Display (T);
end case;
end Check;

begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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;

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 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);
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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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
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 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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;
A      : T_Array);

A      : T_Array) is
begin
for I in A'Range loop
Put_Line (T_Range'Image (I) & ": " & Image (A (I)));
end loop;
end Display_Array;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

Status : out Boolean);

procedure Display;

end Gen_List;

package body Gen_List is

procedure Init is
begin
Last := List_Array'First - 1;
end Init;

Status : out Boolean) is
begin
Status := Last < List_Array'Last;

if Status then
Last := Last + 1;
List_Array (Last) := I;
end if;

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 Gen_List;

procedure Test_Int is

procedure Put (I : Integer) is
begin
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
else
end if;

begin
Int_List.Init;

Int_List.Display;
end Test_Int;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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);

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Display Service

```

package Display_Services is

entry Display (S : String);
entry Display (I : Integer);
end Display_Service;

end Display_Services;

package body Display_Services 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Event Manager

```

package Event_Managers is

entry Start (ID : Natural);
entry Event (T : Time);
end Event_Manager;

end Event_Managers;

package body Event_Managers 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 Event_Managers;   use Event_Managers;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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;

V : Integer := 100;
begin
for I in 1 .. 2 * Max loop
Q_I.Push (V);
V := V + 1;
end loop;
end T_Producer;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

package body Color_Types is

function To_RGB (C : HTML_Color) return RGB is
begin
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
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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Online Store

```

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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## Standard library: Containers

### Simple todo list

```

package Todo_Lists is

type Todo_Item is access String;

(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;

package body Todo_Lists is

procedure Add (Todos : in out Todo_List;
Item  : String) is
begin
Todos.Append (new String'(Item));

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 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 =>
Display (T);
end case;
end Check;

begin
if Argument_Count < 1 then
Put_Line ("ERROR: missing arguments! Exiting...");
return;
elsif Argument_Count > 1 then
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### List of unique integers

```

package Ops is

type Int_Array is array (Positive range <>) of Integer;

(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 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;

Enable tabbed editor view for this editor

Use the dark theme

```

## Standard library: Dates & Times

### Holocene calendar

```

function To_Holocene_Year (T : Time) return Integer is
begin
return Year (T) + 10_000;
end To_Holocene_Year;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### List of events

```

package Events is

type Event_Item is access String;

package Event_Item_Containers is new
(Index_Type   => Positive,
Element_Type => Event_Item);

subtype Event_Items is Event_Item_Containers.Vector;

end Events;

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
(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;

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);

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 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 =>
"Final check");
"Release");
"Brother's birthday");
"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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## Standard library: Strings

### Concatenation

```

package Str_Concat is

type Unbounded_Strings is array (Positive range <>) of Unbounded_String;

function Concat (USA            : Unbounded_Strings;
Trim_Str       : Boolean;

function Concat (USA            : Unbounded_Strings;
Trim_Str       : Boolean;

end Str_Concat;

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);
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
end Concat;

end Str_Concat;

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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### List of events

```

package Events is

subtype Event_Item is Unbounded_String;

package Event_Item_Containers is new
(Index_Type   => Positive,
Element_Type => Event_Item);

subtype Event_Items is Event_Item_Containers.Vector;

end Events;

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
(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;

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);

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 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 =>
"Final check");
"Release");
"Brother's birthday");
"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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

## 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)), Float'Value (Argument (2)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### 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;

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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```

### Rotation

```

package Rotation is

type Complex_Points is array (Positive range <>) of Complex;

function Rotation (N : Positive) return Complex_Points;

end Rotation;

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;

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 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;

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 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
end if;

Check (Test_Case_Index'Value (Argument (1)), Positive'Value (Argument (2)));
end Main;

Enable tabbed editor view for this editor

Use the dark theme

```