Solutions

Imperative Language

Hello World

with Ada.Text_IO; use Ada.Text_IO; procedure Main is begin Put_Line ("Hello World!"); end Main;

Greetings

with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; procedure Main is procedure Greet (Name : String) is begin Put_Line ("Hello " & Name & "!"); end Greet; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Greet (Argument (1)); end Main;

Positive Or Negative

procedure Classify_Number (X : Integer);
with Ada.Text_IO; use Ada.Text_IO; procedure Classify_Number (X : Integer) is begin if X > 0 then Put_Line ("Positive"); elsif X < 0 then Put_Line ("Negative"); else Put_Line ("Zero"); end if; end Classify_Number;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Classify_Number; procedure Main is A : Integer; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; A := Integer'Value (Argument (1)); Classify_Number (A); end Main;

Numbers

procedure Display_Numbers (A, B : Integer);
with Ada.Text_IO; use Ada.Text_IO; procedure Display_Numbers (A, B : Integer) is X, Y : Integer; begin if A <= B then X := A; Y := B; else X := B; Y := A; end if; for I in X .. Y loop Put_Line (Integer'Image (I)); end loop; end Display_Numbers;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Display_Numbers; procedure Main is A, B : Integer; begin if Argument_Count < 2 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 2 then Put_Line ("Ignoring additional arguments..."); end if; A := Integer'Value (Argument (1)); B := Integer'Value (Argument (2)); Display_Numbers (A, B); end Main;

Subprograms

Subtract Procedure

procedure Subtract (A, B : Integer; Result : out Integer);
procedure Subtract (A, B : Integer; Result : out Integer) is begin Result := A - B; end Subtract;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Subtract; procedure Main is type Test_Case_Index is (Sub_10_1_Chk, Sub_10_100_Chk, Sub_0_5_Chk, Sub_0_Minus_5_Chk); procedure Check (TC : Test_Case_Index) is Result : Integer; begin case TC is when Sub_10_1_Chk => Subtract (10, 1, Result); Put_Line ("Result: " & Integer'Image (Result)); when Sub_10_100_Chk => Subtract (10, 100, Result); Put_Line ("Result: " & Integer'Image (Result)); when Sub_0_5_Chk => Subtract (0, 5, Result); Put_Line ("Result: " & Integer'Image (Result)); when Sub_0_Minus_5_Chk => Subtract (0, -5, Result); Put_Line ("Result: " & Integer'Image (Result)); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Subtract Function

function Subtract (A, B : Integer) return Integer;
function Subtract (A, B : Integer) return Integer is begin return A - B; end Subtract;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Subtract; procedure Main is type Test_Case_Index is (Sub_10_1_Chk, Sub_10_100_Chk, Sub_0_5_Chk, Sub_0_Minus_5_Chk); procedure Check (TC : Test_Case_Index) is Result : Integer; begin case TC is when Sub_10_1_Chk => Result := Subtract (10, 1); Put_Line ("Result: " & Integer'Image (Result)); when Sub_10_100_Chk => Result := Subtract (10, 100); Put_Line ("Result: " & Integer'Image (Result)); when Sub_0_5_Chk => Result := Subtract (0, 5); Put_Line ("Result: " & Integer'Image (Result)); when Sub_0_Minus_5_Chk => Result := Subtract (0, -5); Put_Line ("Result: " & Integer'Image (Result)); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Equality function

function Is_Equal (A, B : Integer) return Boolean;
function Is_Equal (A, B : Integer) return Boolean is begin return A = B; end Is_Equal;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Is_Equal; procedure Main is type Test_Case_Index is (Equal_Chk, Inequal_Chk); procedure Check (TC : Test_Case_Index) is procedure Display_Equal (A, B : Integer; Equal : Boolean) is begin Put (Integer'Image (A)); if Equal then Put (" is equal to "); else Put (" isn't equal to "); end if; Put_Line (Integer'Image (B) & "."); end Display_Equal; Result : Boolean; begin case TC is when Equal_Chk => for I in 0 .. 10 loop Result := Is_Equal (I, I); Display_Equal (I, I, Result); end loop; when Inequal_Chk => for I in 0 .. 10 loop Result := Is_Equal (I, I - 1); Display_Equal (I, I - 1, Result); end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Modular Programming

Months

package Months is Jan : constant String := "January"; Feb : constant String := "February"; Mar : constant String := "March"; Apr : constant String := "April"; May : constant String := "May"; Jun : constant String := "June"; Jul : constant String := "July"; Aug : constant String := "August"; Sep : constant String := "September"; Oct : constant String := "October"; Nov : constant String := "November"; Dec : constant String := "December"; procedure Display_Months; end Months;
with Ada.Text_IO; use Ada.Text_IO; package body Months is procedure Display_Months is begin Put_Line ("Months:"); Put_Line ("- " & Jan); Put_Line ("- " & Feb); Put_Line ("- " & Mar); Put_Line ("- " & Apr); Put_Line ("- " & May); Put_Line ("- " & Jun); Put_Line ("- " & Jul); Put_Line ("- " & Aug); Put_Line ("- " & Sep); Put_Line ("- " & Oct); Put_Line ("- " & Nov); Put_Line ("- " & Dec); end Display_Months; end Months;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Months; use Months; procedure Main is type Test_Case_Index is (Months_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Months_Chk => Display_Months; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Operations

package Operations is function Add (A, B : Integer) return Integer; function Subtract (A, B : Integer) return Integer; function Multiply (A, B : Integer) return Integer; function Divide (A, B : Integer) return Integer; end Operations;
package body Operations is function Add (A, B : Integer) return Integer is begin return A + B; end Add; function Subtract (A, B : Integer) return Integer is begin return A - B; end Subtract; function Multiply (A, B : Integer) return Integer is begin return A * B; end Multiply; function Divide (A, B : Integer) return Integer is begin return A / B; end Divide; end Operations;
package Operations_Test is procedure Display_Operations (A, B : Integer); end Operations_Test;
with Ada.Text_IO; use Ada.Text_IO; with Operations; use Operations; package body Operations_Test is procedure Display_Operations (A, B : Integer) is A_Str : constant String := Integer'Image (A); B_Str : constant String := Integer'Image (B); begin Put_Line ("Operations:"); Put_Line (A_Str & " + " & B_Str & " = " & Integer'Image (Add (A, B)) & ","); Put_Line (A_Str & " - " & B_Str & " = " & Integer'Image (Subtract (A, B)) & ","); Put_Line (A_Str & " * " & B_Str & " = " & Integer'Image (Multiply (A, B)) & ","); Put_Line (A_Str & " / " & B_Str & " = " & Integer'Image (Divide (A, B)) & ","); end Display_Operations; end Operations_Test;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Operations; with Operations_Test; use Operations_Test; procedure Main is type Test_Case_Index is (Operations_Chk, Operations_Display_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Operations_Chk => Put_Line ("Add (100, 2) = " & Integer'Image (Operations.Add (100, 2))); Put_Line ("Subtract (100, 2) = " & Integer'Image (Operations.Subtract (100, 2))); Put_Line ("Multiply (100, 2) = " & Integer'Image (Operations.Multiply (100, 2))); Put_Line ("Divide (100, 2) = " & Integer'Image (Operations.Divide (100, 2))); when Operations_Display_Chk => Display_Operations (10, 5); Display_Operations ( 1, 2); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Strongly typed language

Colors

package Color_Types is type HTML_Color is (Salmon, Firebrick, Red, Darkred, Lime, Forestgreen, Green, Darkgreen, Blue, Mediumblue, Darkblue); function To_Integer (C : HTML_Color) return Integer; type Basic_HTML_Color is (Red, Green, Blue); function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color; end Color_Types;
package body Color_Types is function To_Integer (C : HTML_Color) return Integer is begin case C is when Salmon => return 16#FA8072#; when Firebrick => return 16#B22222#; when Red => return 16#FF0000#; when Darkred => return 16#8B0000#; when Lime => return 16#00FF00#; when Forestgreen => return 16#228B22#; when Green => return 16#008000#; when Darkgreen => return 16#006400#; when Blue => return 16#0000FF#; when Mediumblue => return 16#0000CD#; when Darkblue => return 16#00008B#; end case; end To_Integer; function To_HTML_Color (C : Basic_HTML_Color) return HTML_Color is begin case C is when Red => return Red; when Green => return Green; when Blue => return Blue; end case; end To_HTML_Color; end Color_Types;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Ada.Integer_Text_IO; with Color_Types; use Color_Types; procedure Main is type Test_Case_Index is (HTML_Color_Range, HTML_Color_To_Integer, Basic_HTML_Color_To_HTML_Color); procedure Check (TC : Test_Case_Index) is begin case TC is when HTML_Color_Range => for I in HTML_Color'Range loop Put_Line (HTML_Color'Image (I)); end loop; when HTML_Color_To_Integer => for I in HTML_Color'Range loop Ada.Integer_Text_IO.Put (Item => To_Integer (I), Width => 1, Base => 16); New_Line; end loop; when Basic_HTML_Color_To_HTML_Color => for I in Basic_HTML_Color'Range loop Put_Line (HTML_Color'Image (To_HTML_Color (I))); end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Integer Types

package Int_Types is type I_100 is range 0 .. 100; type U_100 is mod 101; function To_I_100 (V : U_100) return I_100; function To_U_100 (V : I_100) return U_100; type D_50 is new I_100 range 10 .. 50; subtype S_50 is I_100 range 10 .. 50; function To_D_50 (V : I_100) return D_50; function To_S_50 (V : I_100) return S_50; function To_I_100 (V : D_50) return I_100; end Int_Types;
package body Int_Types is function To_I_100 (V : U_100) return I_100 is begin return I_100 (V); end To_I_100; function To_U_100 (V : I_100) return U_100 is begin return U_100 (V); end To_U_100; function To_D_50 (V : I_100) return D_50 is Min : constant I_100 := I_100 (D_50'First); Max : constant I_100 := I_100 (D_50'Last); begin if V > Max then return D_50'Last; elsif V < Min then return D_50'First; else return D_50 (V); end if; end To_D_50; function To_S_50 (V : I_100) return S_50 is begin if V > S_50'Last then return S_50'Last; elsif V < S_50'First then return S_50'First; else return V; end if; end To_S_50; function To_I_100 (V : D_50) return I_100 is begin return I_100 (V); end To_I_100; end Int_Types;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Int_Types; use Int_Types; procedure Main is package I_100_IO is new Ada.Text_IO.Integer_IO (I_100); package U_100_IO is new Ada.Text_IO.Modular_IO (U_100); package D_50_IO is new Ada.Text_IO.Integer_IO (D_50); use I_100_IO; use U_100_IO; use D_50_IO; type Test_Case_Index is (I_100_Range, U_100_Range, U_100_Wraparound, U_100_To_I_100, I_100_To_U_100, D_50_Range, S_50_Range, I_100_To_D_50, I_100_To_S_50, D_50_To_I_100, S_50_To_I_100); procedure Check (TC : Test_Case_Index) is begin I_100_IO.Default_Width := 1; U_100_IO.Default_Width := 1; D_50_IO.Default_Width := 1; case TC is when I_100_Range => Put (I_100'First); New_Line; Put (I_100'Last); New_Line; when U_100_Range => Put (U_100'First); New_Line; Put (U_100'Last); New_Line; when U_100_Wraparound => Put (U_100'First - 1); New_Line; Put (U_100'Last + 1); New_Line; when U_100_To_I_100 => for I in U_100'Range loop I_100_IO.Put (To_I_100 (I)); New_Line; end loop; when I_100_To_U_100 => for I in I_100'Range loop Put (To_U_100 (I)); New_Line; end loop; when D_50_Range => Put (D_50'First); New_Line; Put (D_50'Last); New_Line; when S_50_Range => Put (S_50'First); New_Line; Put (S_50'Last); New_Line; when I_100_To_D_50 => for I in I_100'Range loop Put (To_D_50 (I)); New_Line; end loop; when I_100_To_S_50 => for I in I_100'Range loop Put (To_S_50 (I)); New_Line; end loop; when D_50_To_I_100 => for I in D_50'Range loop Put (To_I_100 (I)); New_Line; end loop; when S_50_To_I_100 => for I in S_50'Range loop Put (I); New_Line; end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Temperatures

package Temperature_Types is type Celsius is digits 6 range -273.15 .. 5504.85; type Int_Celsius is range -273 .. 5505; function To_Celsius (T : Int_Celsius) return Celsius; function To_Int_Celsius (T : Celsius) return Int_Celsius; type Kelvin is digits 6 range 0.0 .. 5778.00; function To_Celsius (T : Kelvin) return Celsius; function To_Kelvin (T : Celsius) return Kelvin; end Temperature_Types;
package body Temperature_Types is function To_Celsius (T : Int_Celsius) return Celsius is Min : constant Float := Float (Celsius'First); Max : constant Float := Float (Celsius'Last); F : constant Float := Float (T); begin if F > Max then return Celsius (Max); elsif F < Min then return Celsius (Min); else return Celsius (F); end if; end To_Celsius; function To_Int_Celsius (T : Celsius) return Int_Celsius is begin return Int_Celsius (T); end To_Int_Celsius; function To_Celsius (T : Kelvin) return Celsius is F : constant Float := Float (T); begin return Celsius (F - 273.15); end To_Celsius; function To_Kelvin (T : Celsius) return Kelvin is F : constant Float := Float (T); begin return Kelvin (F + 273.15); end To_Kelvin; end Temperature_Types;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Temperature_Types; use Temperature_Types; procedure Main is package Celsius_IO is new Ada.Text_IO.Float_IO (Celsius); package Kelvin_IO is new Ada.Text_IO.Float_IO (Kelvin); package Int_Celsius_IO is new Ada.Text_IO.Integer_IO (Int_Celsius); use Celsius_IO; use Kelvin_IO; use Int_Celsius_IO; type Test_Case_Index is (Celsius_Range, Celsius_To_Int_Celsius, Int_Celsius_To_Celsius, Kelvin_To_Celsius, Celsius_To_Kelvin); procedure Check (TC : Test_Case_Index) is begin Celsius_IO.Default_Fore := 1; Kelvin_IO.Default_Fore := 1; Int_Celsius_IO.Default_Width := 1; case TC is when Celsius_Range => Put (Celsius'First); New_Line; Put (Celsius'Last); New_Line; when Celsius_To_Int_Celsius => Put (To_Int_Celsius (Celsius'First)); New_Line; Put (To_Int_Celsius (0.0)); New_Line; Put (To_Int_Celsius (Celsius'Last)); New_Line; when Int_Celsius_To_Celsius => Put (To_Celsius (Int_Celsius'First)); New_Line; Put (To_Celsius (0)); New_Line; Put (To_Celsius (Int_Celsius'Last)); New_Line; when Kelvin_To_Celsius => Put (To_Celsius (Kelvin'First)); New_Line; Put (To_Celsius (0)); New_Line; Put (To_Celsius (Kelvin'Last)); New_Line; when Celsius_To_Kelvin => Put (To_Kelvin (Celsius'First)); New_Line; Put (To_Kelvin (Celsius'Last)); New_Line; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Records

Directions

package Directions is type Angle_Mod is mod 360; type Direction is (North, Northwest, West, Southwest, South, Southeast, East); function To_Direction (N: Angle_Mod) return Direction; type Ext_Angle is record Angle_Elem : Angle_Mod; Direction_Elem : Direction; end record; function To_Ext_Angle (N : Angle_Mod) return Ext_Angle; procedure Display (N : Ext_Angle); end Directions;
with Ada.Text_IO; use Ada.Text_IO; package body Directions is procedure Display (N : Ext_Angle) is begin Put_Line ("Angle: " & Angle_Mod'Image (N.Angle_Elem) & " => " & Direction'Image (N.Direction_Elem) & "."); end Display; function To_Direction (N : Angle_Mod) return Direction is begin case N is when 0 => return 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 Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Directions; use Directions; procedure Main is type Test_Case_Index is (Direction_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Direction_Chk => Display (To_Ext_Angle (0)); Display (To_Ext_Angle (30)); Display (To_Ext_Angle (45)); Display (To_Ext_Angle (90)); Display (To_Ext_Angle (91)); Display (To_Ext_Angle (120)); Display (To_Ext_Angle (180)); Display (To_Ext_Angle (250)); Display (To_Ext_Angle (270)); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Colors

package Color_Types is type HTML_Color is (Salmon, Firebrick, Red, Darkred, Lime, Forestgreen, Green, Darkgreen, Blue, Mediumblue, Darkblue); subtype Int_Color is Integer range 0 .. 255; type RGB is record Red : Int_Color; Green : Int_Color; Blue : Int_Color; end record; function To_RGB (C : HTML_Color) return RGB; function Image (C : RGB) return String; end Color_Types;
with Ada.Integer_Text_IO; package body Color_Types is function To_RGB (C : HTML_Color) return RGB is begin case C is when Salmon => return (16#FA#, 16#80#, 16#72#); when Firebrick => return (16#B2#, 16#22#, 16#22#); when Red => return (16#FF#, 16#00#, 16#00#); when Darkred => return (16#8B#, 16#00#, 16#00#); when Lime => return (16#00#, 16#FF#, 16#00#); when Forestgreen => return (16#22#, 16#8B#, 16#22#); when Green => return (16#00#, 16#80#, 16#00#); when Darkgreen => return (16#00#, 16#64#, 16#00#); when Blue => return (16#00#, 16#00#, 16#FF#); when Mediumblue => return (16#00#, 16#00#, 16#CD#); when Darkblue => return (16#00#, 16#00#, 16#8B#); end case; end To_RGB; function Image (C : RGB) return String is subtype Str_Range is Integer range 1 .. 10; SR : String (Str_Range); SG : String (Str_Range); SB : String (Str_Range); begin Ada.Integer_Text_IO.Put (To => SR, Item => C.Red, Base => 16); Ada.Integer_Text_IO.Put (To => SG, Item => C.Green, Base => 16); Ada.Integer_Text_IO.Put (To => SB, Item => C.Blue, Base => 16); return ("(Red => " & SR & ", Green => " & SG & ", Blue => " & SB &")"); end Image; end Color_Types;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Color_Types; use Color_Types; procedure Main is type Test_Case_Index is (HTML_Color_To_RGB); procedure Check (TC : Test_Case_Index) is begin case TC is when HTML_Color_To_RGB => for I in HTML_Color'Range loop Put_Line (HTML_Color'Image (I) & " => " & Image (To_RGB (I)) & "."); end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Inventory

package Inventory_Pkg is type Item is record Quantity : Natural; Price : Float; end record; type Inventory is record Assets : Float := 0.0; end record; function Init (Name : String; Quantity : Natural; Price : Float) return Item; procedure Add (Inv : in out Inventory; I : Item); procedure Display (Inv : Inventory); end Inventory_Pkg;
with Ada.Text_IO; use Ada.Text_IO; package body Inventory_Pkg is function Init (Name : String; Quantity : Natural; Price : Float) return Item is begin Put_Line ("Adding item: " & Name & "."); return (Quantity => Quantity, Price => Price); end Init; procedure Add (Inv : in out Inventory; I : Item) is begin Inv.Assets := Inv.Assets + Float (I.Quantity) * I.Price; end Add; procedure Display (Inv : Inventory) is package F_IO is new Ada.Text_IO.Float_IO (Float); use F_IO; begin Put ("Assets: $"); Put (Inv.Assets, 1, 2, 0); Put ("."); New_Line; end Display; end Inventory_Pkg;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Inventory_Pkg; use Inventory_Pkg; procedure Main is -- Remark: the following line is not relevant. F : array (1 .. 10) of Float := (others => 42.42); type Test_Case_Index is (Inventory_Chk); procedure Check (TC : Test_Case_Index) is I : Item; Inv : Inventory; -- Please ignore the following three lines! pragma Warnings (Off, "default initialization"); for Inv'Address use F'Address; pragma Warnings (On, "default initialization"); begin case TC is when Inventory_Chk => I := Init ("Ballpoint Pen", 185, 0.15); Add (Inv, I); Display (Inv); I := Init ("Oil-based Pen Marker", 100, 9.0); Add (Inv, I); Display (Inv); I := Init ("Feather Quill Pen", 2, 40.0); Add (Inv, I); Display (Inv); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Arrays

Constrained Array

package Constrained_Arrays is type My_Index is range 1 .. 10; type My_Array is array (My_Index) of Integer; function Init return My_Array; procedure Double (A : in out My_Array); function First_Elem (A : My_Array) return Integer; function Last_Elem (A : My_Array) return Integer; function Length (A : My_Array) return Integer; A : My_Array := (1, 2, others => 42); end Constrained_Arrays;
package body Constrained_Arrays is function Init return My_Array is A : My_Array; begin for I in My_Array'Range loop A (I) := Integer (I); end loop; return A; end Init; procedure Double (A : in out My_Array) is begin for I in A'Range loop A (I) := A (I) * 2; end loop; end Double; function First_Elem (A : My_Array) return Integer is begin return A (A'First); end First_Elem; function Last_Elem (A : My_Array) return Integer is begin return A (A'Last); end Last_Elem; function Length (A : My_Array) return Integer is begin return A'Length; end Length; end Constrained_Arrays;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Constrained_Arrays; use Constrained_Arrays; procedure Main is type Test_Case_Index is (Range_Chk, Array_Range_Chk, A_Obj_Chk, Init_Chk, Double_Chk, First_Elem_Chk, Last_Elem_Chk, Length_Chk); procedure Check (TC : Test_Case_Index) is AA : My_Array; procedure Display (A : My_Array) is begin for I in A'Range loop Put_Line (Integer'Image (A (I))); end loop; end Display; procedure Local_Init (A : in out My_Array) is begin A := (100, 90, 80, 10, 20, 30, 40, 60, 50, 70); end Local_Init; begin case TC is when Range_Chk => for I in My_Index loop Put_Line (My_Index'Image (I)); end loop; when Array_Range_Chk => for I in My_Array'Range loop Put_Line (My_Index'Image (I)); end loop; when A_Obj_Chk => Display (A); when Init_Chk => AA := Init; Display (AA); when Double_Chk => Local_Init (AA); Double (AA); Display (AA); when First_Elem_Chk => Local_Init (AA); Put_Line (Integer'Image (First_Elem (AA))); when Last_Elem_Chk => Local_Init (AA); Put_Line (Integer'Image (Last_Elem (AA))); when Length_Chk => Put_Line (Integer'Image (Length (AA))); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Colors: Lookup-Table

package Color_Types is type HTML_Color is (Salmon, Firebrick, Red, Darkred, Lime, Forestgreen, Green, Darkgreen, Blue, Mediumblue, Darkblue); subtype Int_Color is Integer range 0 .. 255; type RGB is record Red : Int_Color; Green : Int_Color; Blue : Int_Color; end record; function To_RGB (C : HTML_Color) return RGB; function Image (C : RGB) return String; type HTML_Color_RGB is array (HTML_Color) of RGB; To_RGB_Loopup_Table : constant HTML_Color_RGB := (Salmon => (16#FA#, 16#80#, 16#72#), Firebrick => (16#B2#, 16#22#, 16#22#), Red => (16#FF#, 16#00#, 16#00#), Darkred => (16#8B#, 16#00#, 16#00#), Lime => (16#00#, 16#FF#, 16#00#), Forestgreen => (16#22#, 16#8B#, 16#22#), Green => (16#00#, 16#80#, 16#00#), Darkgreen => (16#00#, 16#64#, 16#00#), Blue => (16#00#, 16#00#, 16#FF#), Mediumblue => (16#00#, 16#00#, 16#CD#), Darkblue => (16#00#, 16#00#, 16#8B#)); end Color_Types;
with Ada.Integer_Text_IO; package body Color_Types is function To_RGB (C : HTML_Color) return RGB is begin return To_RGB_Loopup_Table (C); end To_RGB; function Image (C : RGB) return String is subtype Str_Range is Integer range 1 .. 10; SR : String (Str_Range); SG : String (Str_Range); SB : String (Str_Range); begin Ada.Integer_Text_IO.Put (To => SR, Item => C.Red, Base => 16); Ada.Integer_Text_IO.Put (To => SG, Item => C.Green, Base => 16); Ada.Integer_Text_IO.Put (To => SB, Item => C.Blue, Base => 16); return ("(Red => " & SR & ", Green => " & SG & ", Blue => " & SB &")"); end Image; end Color_Types;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Color_Types; use Color_Types; procedure Main is type Test_Case_Index is (Color_Table_Chk, HTML_Color_To_Integer_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Color_Table_Chk => Put_Line ("Size of HTML_Color_RGB: " & Integer'Image (HTML_Color_RGB'Length)); Put_Line ("Firebrick: " & Image (To_RGB_Loopup_Table (Firebrick))); when HTML_Color_To_Integer_Chk => for I in HTML_Color'Range loop Put_Line (HTML_Color'Image (I) & " => " & Image (To_RGB (I)) & "."); end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Unconstrained Array

package Unconstrained_Arrays is type My_Array is array (Positive range <>) of Integer; procedure Init (A : in out My_Array); function Init (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 (L : Positive) return My_Array is A : My_Array (1 .. L); 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 (1) := 0; for I in 2 .. A'Last loop A_Out (I) := A (I) - A (I - 1); end loop; return A_Out; end Diff_Prev_Elem; end Unconstrained_Arrays;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Unconstrained_Arrays; use Unconstrained_Arrays; procedure Main is type Test_Case_Index is (Init_Chk, Init_Proc_Chk, Double_Chk, Diff_Prev_Chk, Diff_Prev_Single_Chk); procedure Check (TC : Test_Case_Index) is AA : My_Array (1 .. 5); 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'Last); Display (AA); when Init_Proc_Chk => Init (AA); Display (AA); when Double_Chk => Local_Init (AA); Double (AA); Display (AA); when Diff_Prev_Chk => Local_Init (AA); AA := Diff_Prev_Elem (AA); Display (AA); when Diff_Prev_Single_Chk => declare A1 : My_Array (1 .. 1) := (1 => 42); begin A1 := Diff_Prev_Elem (A1); Display (A1); end; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Quantities And Amounts

package Quantities_Amounts is subtype Quantity is Natural; subtype Amount is Float; type Quantities is array (Positive range <>) of Quantity; type Amounts is array (Positive range <>) of Amount; procedure Total (Q : Quantities; A : Amounts; A_Out : out Amounts); function Total (Q : Quantities; A : Amounts) return Amounts; function Total (Q : Quantities; A : Amounts) return Amount; end Quantities_Amounts;
package body Quantities_Amounts is procedure Total (Q : Quantities; A : Amounts; A_Out : out Amounts) is begin for I in A'Range loop A_Out (I) := Amount (Q (I)) * A (I); end loop; end Total; function Total (Q : Quantities; A : Amounts) return Amounts is A_Out : Amounts (A'Range); begin Total (Q, A, A_Out); return A_Out; end Total; function Total (Q : Quantities; A : Amounts) return Amount is A_Out : Amount := 0.0; begin for I in A'Range loop A_Out := A_Out + Amount (Q (I)) * A (I); end loop; return A_Out; end Total; end Quantities_Amounts;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Quantities_Amounts; use Quantities_Amounts; procedure Main is package Amount_IO is new Ada.Text_IO.Float_IO (Amount); type Test_Case_Index is (Total_Func_Chk, Total_Proc_Chk, Total_Amount_Chk); procedure Check (TC : Test_Case_Index) is subtype Test_Range is Positive range 1 .. 5; A : Amounts (Test_Range); Q : Quantities (Test_Range); A1 : Amount; procedure Display (A : Amounts) is begin for I in A'Range loop Amount_IO.Put (A (I)); New_Line; end loop; end Display; procedure Local_Init (Q : in out Quantities; A : in out Amounts) is begin Q := (1, 2, 5, 10, 10); A := (0.5, 10.0, 40.0, 10.0, 20.0); end Local_Init; begin Amount_IO.Default_Fore := 1; Amount_IO.Default_Aft := 2; Amount_IO.Default_Exp := 0; case TC is when Total_Func_Chk => Local_Init (Q, A); A := Total (Q, A); Display (A); when Total_Proc_Chk => Local_Init (Q, A); Total (Q, A, A); Display (A); when Total_Amount_Chk => Local_Init (Q, A); A1 := Total (Q, A); Amount_IO.Put (A1); New_Line; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

String_10

package Strings_10 is subtype String_10 is String (1 .. 10); -- Using "type String_10 is..." is possible, too. However, it -- requires a custom Put_Line procedure that is called in Main: -- procedure Put_Line (S : String_10); 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'Range loop S_Out (I) := S (I); end loop; return S_Out; end To_String_10; end Strings_10;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Strings_10; use Strings_10; procedure Main is type Test_Case_Index is (String_10_Chk); procedure Check (TC : Test_Case_Index) is S : constant String := "And this is a long string just for testing..."; S_10 : String_10; begin case TC is when String_10_Chk => S_10 := To_String_10 (S); Put_Line (S_10); end case; end Check; begin if Argument_Count < 1 then Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Ada.Text_IO.Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

List of Names

package Names_Ages is Max_People : constant Positive := 10; subtype Name_Type is String (1 .. 50); type Age_Type is new Natural; type Person is record Name : Name_Type; Age : Age_Type; end record; type People_Array is array (Positive range <>) of Person; type People is record People_A : People_Array (1 .. Max_People); Last_Valid : Natural; end record; procedure Reset (P : in out People); procedure Add (P : in out People; Name : String); function Get (P : People; Name : String) return Age_Type; procedure Update (P : in out People; Name : String; Age : Age_Type); procedure Display (P : People); end Names_Ages;
with Ada.Text_IO; use Ada.Text_IO; with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; package body Names_Ages is function To_Name_Type (S : String) return Name_Type is S_Out : Name_Type := (others => ' '); begin for I in 1 .. Integer'Min (S'Last, Name_Type'Last) loop S_Out (I) := S (I); end loop; return S_Out; end To_Name_Type; procedure Init (P : in out Person; Name : String) is begin P.Name := To_Name_Type (Name); P.Age := 0; end Init; function Match (P : Person; Name : String) return Boolean is begin return P.Name = To_Name_Type (Name); end Match; function Get (P : Person) return Age_Type is begin return P.Age; end Get; procedure Update (P : in out Person; Age : Age_Type) is begin P.Age := Age; end Update; procedure Display (P : Person) is begin Put_Line ("NAME: " & Trim (P.Name, Right)); Put_Line ("AGE: " & Age_Type'Image (P.Age)); end Display; procedure Reset (P : in out People) is begin P.Last_Valid := 0; end Reset; procedure Add (P : in out People; Name : String) is begin P.Last_Valid := P.Last_Valid + 1; Init (P.People_A (P.Last_Valid), Name); end Add; function Get (P : People; Name : String) return Age_Type is begin for I in P.People_A'First .. P.Last_Valid loop if Match (P.People_A (I), Name) then return Get (P.People_A (I)); end if; end loop; return 0; end Get; procedure Update (P : in out People; Name : String; Age : Age_Type) is begin for I in P.People_A'First .. P.Last_Valid loop if Match (P.People_A (I), Name) then Update (P.People_A (I), Age); end if; end loop; end Update; procedure Display (P : People) is begin Put_Line ("LIST OF NAMES:"); for I in P.People_A'First .. P.Last_Valid loop Display (P.People_A (I)); end loop; end Display; end Names_Ages;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Names_Ages; use Names_Ages; procedure Main is type Test_Case_Index is (Names_Ages_Chk, Get_Age_Chk); procedure Check (TC : Test_Case_Index) is P : People; begin case TC is when Names_Ages_Chk => Reset (P); Add (P, "John"); Add (P, "Patricia"); Add (P, "Josh"); Display (P); Update (P, "John", 18); Update (P, "Patricia", 35); Update (P, "Josh", 53); Display (P); when Get_Age_Chk => Reset (P); Add (P, "Peter"); Update (P, "Peter", 45); Put_Line ("Peter is " & Age_Type'Image (Get (P, "Peter")) & " years old."); end case; end Check; begin if Argument_Count < 1 then Ada.Text_IO.Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Ada.Text_IO.Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

More About Types

Aggregate Initialization

package Aggregates is type Rec is record W : Integer := 10; X : Integer := 11; Y : Integer := 12; Z : Integer := 13; end record; type Int_Arr is array (1 .. 20) of Integer; procedure Init (R : out Rec); procedure Init_Some (A : out Int_Arr); procedure Init (A : out Int_Arr); end Aggregates;
package body Aggregates is procedure Init (R : out Rec) is begin R := (X => 100, Y => 200, others => <>); end Init; procedure Init_Some (A : out Int_Arr) is begin A := (1 .. 5 => 99, others => 100); end Init_Some; procedure Init (A : out Int_Arr) is begin A := (others => 5); end Init; end Aggregates;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Aggregates; use Aggregates; procedure Main is -- Remark: the following line is not relevant. F : array (1 .. 10) of Float := (others => 42.42) with Unreferenced; type Test_Case_Index is (Default_Rec_Chk, Init_Rec_Chk, Init_Some_Arr_Chk, Init_Arr_Chk); procedure Check (TC : Test_Case_Index) is A : Int_Arr; R : Rec; DR : constant Rec := (others => <>); begin case TC is when Default_Rec_Chk => R := DR; Put_Line ("Record Default:"); Put_Line ("W => " & Integer'Image (R.W)); Put_Line ("X => " & Integer'Image (R.X)); Put_Line ("Y => " & Integer'Image (R.Y)); Put_Line ("Z => " & Integer'Image (R.Z)); when Init_Rec_Chk => Init (R); Put_Line ("Record Init:"); Put_Line ("W => " & Integer'Image (R.W)); Put_Line ("X => " & Integer'Image (R.X)); Put_Line ("Y => " & Integer'Image (R.Y)); Put_Line ("Z => " & Integer'Image (R.Z)); when Init_Some_Arr_Chk => Init_Some (A); Put_Line ("Array Init_Some:"); for I in A'Range loop Put_Line (Integer'Image (I) & " " & Integer'Image (A (I))); end loop; when Init_Arr_Chk => Init (A); Put_Line ("Array Init:"); for I in A'Range loop Put_Line (Integer'Image (I) & " " & Integer'Image (A (I))); end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Versioning

package Versioning is type Version is record Major : Natural; Minor : Natural; Maintenance : Natural; end record; function Convert (V : Version) return String; function Convert (V : Version) return Float; end Versioning;
with Ada.Strings; use Ada.Strings; with Ada.Strings.Fixed; use Ada.Strings.Fixed; package body Versioning is function Image_Trim (N : Natural) return String is S_N : constant String := Trim (Natural'Image (N), Left); begin return S_N; end Image_Trim; function Convert (V : Version) return String is S_Major : constant String := Image_Trim (V.Major); S_Minor : constant String := Image_Trim (V.Minor); S_Maint : constant String := Image_Trim (V.Maintenance); begin return (S_Major & "." & S_Minor & "." & S_Maint); end Convert; function Convert (V : Version) return Float is begin return Float (V.Major) + (Float (V.Minor) / 10.0); end Convert; end Versioning;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Versioning; use Versioning; procedure Main is type Test_Case_Index is (Ver_String_Chk, Ver_Float_Chk); procedure Check (TC : Test_Case_Index) is V : constant Version := (1, 3, 23); begin case TC is when Ver_String_Chk => Put_Line (Convert (V)); when Ver_Float_Chk => Put_Line (Float'Image (Convert (V))); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Simple todo list

package Todo_Lists is type Todo_Item is access String; type Todo_List is array (Positive range <>) of Todo_Item; Last : Natural := 0; procedure Add (Todos : in out Todo_List; Item : String); procedure Display (Todos : Todo_List); end Todo_Lists;
with Ada.Text_IO; use Ada.Text_IO; package body Todo_Lists is procedure Add (Todos : in out Todo_List; Item : String) is begin if Last < Todos'Last then Last := Last + 1; Todos (Last) := new String'(Item); else Put_Line ("ERROR: list is full!"); end if; end Add; procedure Display (Todos : Todo_List) is begin Put_Line ("TO-DO LIST"); for I in Todos'First .. Last loop Put_Line (Todos (I).all); end loop; end Display; end Todo_Lists;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Todo_Lists; use Todo_Lists; procedure Main is type Test_Case_Index is (Todo_List_Chk); procedure Check (TC : Test_Case_Index) is T : Todo_List (1 .. 10); begin case TC is when Todo_List_Chk => Add (T, "Buy milk"); Add (T, "Buy tea"); Add (T, "Buy present"); Add (T, "Buy tickets"); Add (T, "Pay electricity bill"); Add (T, "Schedule dentist appointment"); Add (T, "Call sister"); Add (T, "Revise spreasheet"); Add (T, "Edit entry page"); Add (T, "Select new design"); Add (T, "Create upgrade plan"); Display (T); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Price list

package Price_Lists is type Price_Type is delta 10.0 ** (-2) digits 12; type Price_List_Array is array (Positive range <>) of Price_Type; type Price_List (Max : Positive) is record List : Price_List_Array (1 .. Max); Last : Natural := 0; end record; type Price_Result (Ok : Boolean) is record case Ok is when False => null; when True => Price : Price_Type; end case; end record; procedure Reset (Prices : in out Price_List); procedure Add (Prices : in out Price_List; Item : Price_Type); function Get (Prices : Price_List; Idx : Positive) return Price_Result; procedure Display (Prices : Price_List); end Price_Lists;
with Ada.Text_IO; use Ada.Text_IO; package body Price_Lists is procedure Reset (Prices : in out Price_List) is begin Prices.Last := 0; end Reset; procedure Add (Prices : in out Price_List; Item : Price_Type) is begin if Prices.Last < Prices.List'Last then Prices.Last := Prices.Last + 1; Prices.List (Prices.Last) := Item; else Put_Line ("ERROR: list is full!"); end if; end Add; function Get (Prices : Price_List; Idx : Positive) return Price_Result is begin if (Idx >= Prices.List'First and then Idx <= Prices.Last) then return Price_Result'(Ok => True, Price => Prices.List (Idx)); else return Price_Result'(Ok => False); end if; end Get; procedure Display (Prices : Price_List) is begin Put_Line ("PRICE LIST"); for I in Prices.List'First .. Prices.Last loop Put_Line (Price_Type'Image (Prices.List (I))); end loop; end Display; end Price_Lists;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Price_Lists; use Price_Lists; procedure Main is type Test_Case_Index is (Price_Type_Chk, Price_List_Chk, Price_List_Get_Chk); procedure Check (TC : Test_Case_Index) is L : Price_List (10); procedure Local_Init_List is begin Reset (L); Add (L, 1.45); Add (L, 2.37); Add (L, 3.21); Add (L, 4.14); Add (L, 5.22); Add (L, 6.69); Add (L, 7.77); Add (L, 8.14); Add (L, 9.99); Add (L, 10.01); end Local_Init_List; procedure Get_Display (Idx : Positive) is R : constant Price_Result := Get (L, Idx); begin Put_Line ("Attemp Get # " & Positive'Image (Idx)); if R.Ok then Put_Line ("Element # " & Positive'Image (Idx) & " => " & Price_Type'Image (R.Price)); else declare begin Put_Line ("Element # " & Positive'Image (Idx) & " => " & Price_Type'Image (R.Price)); exception when others => Put_Line ("Element not available (as expected)"); end; end if; end Get_Display; begin case TC is when Price_Type_Chk => Put_Line ("The delta value of Price_Type is " & Price_Type'Image (Price_Type'Delta) & ";"); Put_Line ("The minimum value of Price_Type is " & Price_Type'Image (Price_Type'First) & ";"); Put_Line ("The maximum value of Price_Type is " & Price_Type'Image (Price_Type'Last) & ";"); when Price_List_Chk => Local_Init_List; Display (L); when Price_List_Get_Chk => Local_Init_List; Get_Display (5); Get_Display (40); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Fixed-point square-root

package Fixed_Point_Ops is -- F_Size : constant := 16; -- F_Size : constant := 24; F_Size : constant := 32; -- F_Size : constant := 48; -- F_Size : constant := 64; -- Definition for Q<F_Size / 2 - 1>.<F_Size / 2>, e.g. Q15.16: F_Size_Fract : constant := F_Size / 2; F_Size_Sign : constant := 1; F_Size_Int : constant := F_Size - F_Size_Fract - F_Size_Sign; F_Delta : constant := 2.0 ** (-F_Size_Fract); F_Last : constant := 2.0 ** ( F_Size_Int); -- Definition for Q<F_Size / 2 - 1>.<F_Size / 2>, e.g. Q16.16: -- F_Size_Fract : constant := F_Size / 2; -- F_Size_Sign : constant := 0; -- F_Size_Int : constant := F_Size - F_Size_Fract - F_Size_Sign; -- F_Delta : constant := 2.0 ** (-F_Size_Fract); -- F_Last : constant := 2.0 ** ( F_Size_Int); -- Definition for Q<F_Size * 1/4 - 1>.<F_Size * 3/4>, e.g. Q7.24: -- F_Size_Fract : constant := F_Size * 3 / 4; -- F_Size_Sign : constant := 1; -- F_Size_Int : constant := F_Size - F_Size_Fract - F_Size_Sign; -- F_Delta : constant := 2.0 ** (-F_Size_Fract); -- F_Last : constant := 2.0 ** ( F_Size_Int); -- Definition for Q<F_Size * 1/4>.<F_Size * 3/4>, e.g. Q8.24 -- (unsigned!): -- F_Size_Fract : constant := F_Size * 3 / 4; -- F_Size_Sign : constant := 0; -- F_Size_Int : constant := F_Size - F_Size_Fract - F_Size_Sign; -- F_Delta : constant := 2.0 ** (-F_Size_Fract); -- F_Last : constant := 2.0 ** ( F_Size_Int); type Fixed is delta F_Delta range 0.0 .. F_Last - F_Delta; function Sqrt (V : Fixed) return Fixed; end Fixed_Point_Ops;
package body Fixed_Point_Ops is -- -- Algorithm and code Author: Christophe Meessen 1993. -- Initially published in : -- usenet comp.lang.c, Thu, 28 Jan 1993 08:35:23 GMT. -- -- https://github.com/chmike/fpsqrt/blob/master/fpsqrt.c -- function Sqrt (V : Fixed) return Fixed is T, Q, B, R : Fixed; Shift_Fac : constant := F_Size_Int + F_Size_Sign; B_Init : constant := 2.0 ** (Shift_Fac - 2); -- Equivalent to: -- 2#100_0000_0000_0000.0000_0000_0000_0000#; -- 16#4000.0000#; B_Thres : constant := 2.0 ** (-(F_Size_Fract - 2) + 4); -- Equivalent to: -- 2#000_0000_0000_0000.0000_0000_0000_0100#; -- 16#0000.0040#; begin R := V; B := B_Init; Q := 0.0; while B > B_Thres loop T := Q + B; if R >= T then R := R - T; Q := T + B; end if; R := R * 2; B := B / 2; end loop; Q := Q / 2 ** ((Shift_Fac) / 2); return Q; end Sqrt; end Fixed_Point_Ops;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Ada.Numerics.Elementary_Functions; use Ada.Numerics.Elementary_Functions; with Fixed_Point_Ops; use Fixed_Point_Ops; procedure Main is type Test_Case_Index is (Sqrt_Chk_Last_Div_2, Sqrt_Chk_Last_Div_2_Minus, Sqrt_Chk_Last_Div_4, Sqrt_Chk_Last_Div_8); procedure Display_Sqrt (V : Fixed) is package Float_IO is new Ada.Text_IO.Float_IO (Float); F : constant Float := Float (V); begin Put ("Float-Sqrt of "); Float_IO.Put (F, Fore => 1, Aft => 5, Exp => 0); Put (" = "); Float_IO.Put (Sqrt (F), Fore => 1, Aft => 5, Exp => 0); New_Line; Put_Line ("Fixed-Sqrt of " & Fixed'Image (V) & " = " & Fixed'Image (Sqrt (V))); end Display_Sqrt; procedure Check (TC : Test_Case_Index) is begin case TC is when Sqrt_Chk_Last_Div_2_Minus => Display_Sqrt (Fixed'Last / 2 - Fixed'Delta * Fixed'Size); when Sqrt_Chk_Last_Div_2 => Display_Sqrt (Fixed'Last / 2); when Sqrt_Chk_Last_Div_4 => Display_Sqrt (Fixed'Last / 4); when Sqrt_Chk_Last_Div_8 => Display_Sqrt (Fixed'Last / 8); end case; exception when others => Put_Line ("Exception!"); end Check; begin if Argument_Count < 2 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 2 then Put_Line ("Ignoring additional arguments..."); end if; if Argument (1) = "TESTCASE" then Check (Test_Case_Index'Value (Argument (2))); elsif Argument (1) = "VALUE" then Display_Sqrt (Fixed'Value (Argument (2))); end if; end Main;

Inventory

package Inventory_Pkg is subtype Item_Quantity is Natural; type Amount is delta 10.0 ** (-2) digits 12; type Name_Type is access String; subtype Item_ID is Positive; type Transaction_Type is (Bought, Sold); type Transaction_Quantities is array (Transaction_Type) of Item_Quantity; type Transaction_Amounts is array (Transaction_Type) of Amount; type Add_Status (Success : Boolean := False) is record case Success is when False => null; when True => ID : Item_ID; end case; end record; type Item is record Name : Name_Type; Price : Amount; Stock_Quantity : Item_Quantity; Stock_Amount : Amount; Trans_Quantity : Transaction_Quantities; Trans_Amount : Transaction_Amounts; end record; type Items is array (Item_ID range <>) of Item; type Inventory (Max : Item_ID) is record List_Item : Items (1 .. Max); Last_Item_Id : Natural := 0; end record; function Init (Name : String; Price : Amount) return Item; procedure Init (Inv : in out Inventory); procedure Add (Inv : in out Inventory; I : Item; Status : out Add_Status); function Get (Inv : Inventory; Item_Name : String) return Item_ID; function Last_Id (Inv : Inventory) return Natural; procedure Set (Inv : in out Inventory; Trans : Transaction_Type; ID : Item_ID; Quantity : Positive; Success : out Boolean); function Get (Inv : Inventory; ID : Item_ID) return String; -- Retrieve item name -- -- Item_Name : String := Get (Inv, ID); function Get (Inv : Inventory; ID : Item_ID) return Item_Quantity; -- Retrieve number of units in stock for specified item -- -- Number_Units_In_Stock_For_Item : Item_Quantity := Get (Inv, ID); function Get (Inv : Inventory; ID : Item_ID) return Amount; -- Retrieve total amount in stock for specified item -- -- Potential_Income_For_Units_In_Stock_For_Item : Amount := Get (Inv, ID); function Get (Inv : Inventory; Trans : Transaction_Type; ID : Item_ID) return Item_Quantity; -- Retrieve number of units for specified item and transaction type -- -- Number_Units_Sold_For_Item : Item_Quantity := Get (Inv, Sold, ID); function Get (Inv : Inventory; Trans : Transaction_Type; ID : Item_ID) return Amount; -- Retrieve amount for specified item and transaction type -- -- Income_For_Sold_Units_Of_Item : Amount := Get (Inv, Sold, ID); function Get (Inv : Inventory; Trans : Transaction_Type) return Amount; -- Retrieve amount for transaction type -- -- Income_For_All_Sold_Units : Amount := Get (Inv, Sold); function Get (Inv : Inventory) return Amount; -- Retrieve amount for whole inventory -- -- Income_For_All_Units_In_Stock : Amount := Get (Inv); procedure Display (Inv : Inventory); end Inventory_Pkg;
with Ada.Text_IO; use Ada.Text_IO; package body Inventory_Pkg is function Init (Name : String; Price : Amount) return Item is begin return Item'(Name => new String'(Name), Price => Price, Stock_Quantity => 0, Stock_Amount => 0.0, Trans_Quantity => (others => 0), Trans_Amount => (others => 0.0)); end Init; procedure Init (Inv : in out Inventory) is begin Inv.Last_Item_Id := Item_ID'First; end Init; procedure Add (Inv : in out Inventory; I : Item; Status : out Add_Status) is L : Natural := Inv.Last_Item_Id; begin if L < Inv.Max then L := L + 1; Inv.Last_Item_Id := L; Inv.List_Item (L) := I; Status := (Success => True, ID => L); else Status := (Success => False); end if; end Add; function Get (Inv : Inventory; Item_Name : String) return Item_ID is ID : Item_ID := Item_ID'First; begin for I in Inv.List_Item'First .. Inv.Last_Item_Id loop if Inv.List_Item (I).Name.all = Item_Name then ID := I; exit; end if; end loop; return ID; end Get; function Last_Id (Inv : Inventory) return Natural is (Inv.Last_Item_Id); procedure Set (Inv : in out Inventory; Trans : Transaction_Type; ID : Item_ID; Quantity : Positive; Success : out Boolean) is Q : Integer; begin case Trans is when Bought => Q := Inv.List_Item (ID).Stock_Quantity + Quantity; when Sold => Q := Inv.List_Item (ID).Stock_Quantity - Quantity; end case; if Q >= 0 then Success := True; Inv.List_Item (ID).Stock_Quantity := Q; Inv.List_Item (ID).Stock_Amount := Amount (Q) * Inv.List_Item (ID).Price; Inv.List_Item (ID).Trans_Quantity (Trans) := Inv.List_Item (ID).Trans_Quantity (Trans) + Quantity; Inv.List_Item (ID).Trans_Amount (Trans) := Inv.List_Item (ID).Trans_Amount (Trans) + Amount (Quantity) * Inv.List_Item (ID).Price; else Success := False; end if; end Set; function Get (Inv : Inventory; ID : Item_ID) return String is (Inv.List_Item (ID).Name.all); function Get (Inv : Inventory; ID : Item_ID) return Item_Quantity is (Inv.List_Item (ID).Stock_Quantity); function Get (Inv : Inventory; ID : Item_ID) return Amount is (Inv.List_Item (ID).Stock_Amount); function Get (Inv : Inventory; Trans : Transaction_Type; ID : Item_ID) return Item_Quantity is (Inv.List_Item (ID).Trans_Quantity (Trans)); function Get (Inv : Inventory; Trans : Transaction_Type; ID : Item_ID) return Amount is (Inv.List_Item (ID).Trans_Amount (Trans)); function Get (Inv : Inventory; Trans : Transaction_Type) return Amount is Total : Amount := 0.0; begin for I in Inv.List_Item'First .. Last_Id (Inv) loop Total := Total + Get (Inv, Trans, I); end loop; return Total; end Get; function Get (Inv : Inventory) return Amount is Total : Amount := 0.0; begin for I in Inv.List_Item'First .. Last_Id (Inv) loop Total := + Get (Inv, I); end loop; return Total; end Get; procedure Display (Inv : Inventory) is package F_IO is new Ada.Text_IO.Decimal_IO (Amount); use F_IO; begin for I in Inv.List_Item'First .. Last_Id (Inv) loop Put_Line ("==== ITEM # " & Positive'Image (I) & ": " & Get (Inv, I)); New_Line; Put ("Price: "); Put (Amount'(Get (Inv, I)), 1, 2, 0); New_Line; for Trans in Transaction_Type loop Put_Line ("== " & Transaction_Type'Image (Trans)); Put_Line ("Quantity: " & Item_Quantity'Image (Get (Inv, Trans, I))); Put ("Amount: "); Put (Amount'(Get (Inv, Trans, I)), 1, 2, 0); New_Line; end loop; Put_Line ("== IN STOCK"); Put_Line ("Quantity: " & Item_Quantity'Image (Get (Inv, I))); Put ("Amount: "); Put (Amount'(Get (Inv, I)), 1, 2, 0); New_Line; New_Line; end loop; Put_Line ("==== OVERALL"); Put ("Amount bought: "); Put (Amount'(Get (Inv, Bought)), 1, 2, 0); New_Line; Put ("Amount sold: "); Put (Amount'(Get (Inv, Sold)), 1, 2, 0); New_Line; Put ("Amount in stock: "); Put (Amount'(Get (Inv)), 1, 2, 0); New_Line; end Display; end Inventory_Pkg;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Inventory_Pkg; use Inventory_Pkg; procedure Main is -- Remark: the following line is not relevant. F : array (1 .. 200) of Float := (others => 42.42); type Test_Case_Index is (Inventory_Chk, Inventory_Range_Chk); procedure Check (TC : Test_Case_Index) is Inv : Inventory (3); Success : Boolean; Status : Add_Status; -- Please ignore the following three lines! pragma Warnings (Off, "default initialization"); for Inv'Address use F'Address; pragma Warnings (On, "default initialization"); procedure Init_Check_Data is begin Add (Inv, Init ("Ballpoint Pen", 0.15), Status); if Status.Success then Set (Inv => Inv, Trans => Bought, ID => Status.ID, Quantity => 10, Success => Success); Set (Inv => Inv, Trans => Sold, ID => Status.ID, Quantity => 2, Success => Success); Set (Inv => Inv, Trans => Sold, ID => Status.ID, Quantity => 2, Success => Success); end if; Add (Inv, Init ("Oil-based Pen Marker", 9.0), Status); Add (Inv, Init ("Feather Quill Pen", 15.0), Status); Set (Inv => Inv, Trans => Bought, ID => Get (Inv, "Oil-based Pen Marker"), Quantity => 20, Success => Success); Set (Inv => Inv, Trans => Bought, ID => Get (Inv, "Feather Quill Pen"), Quantity => 50, Success => Success); Set (Inv => Inv, Trans => Sold, ID => Get (Inv, "Feather Quill Pen"), Quantity => 20, Success => Success); end Init_Check_Data; procedure Check_Expected_Failure (Success : Boolean; Proc_Name : String) is begin if Success then Put_Line ("ERROR: Call to '" & Proc_Name & "' should have failed."); else Put_Line ("Info: Call to '" & Proc_Name & "' failed as expected."); end if; end Check_Expected_Failure; begin Init_Check_Data; case TC is when Inventory_Chk => Display (Inv); when Inventory_Range_Chk => -- Inventory is full; try to add another item Add (Inv, Init ("Ballpoint Pen", 0.15), Status); Check_Expected_Failure (Status.Success, "Add"); -- Try to sell more than available in stock Set (Inv => Inv, Trans => Sold, ID => Get (Inv, "Oil-based Pen Marker"), Quantity => 30, Success => Success); Check_Expected_Failure (Success, "Set"); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Privacy

Directions

package Directions is type Angle_Mod is mod 360; type Direction is (North, Northwest, West, Southwest, South, Southeast, East); function To_Direction (N : Angle_Mod) return Direction; type Ext_Angle is private; function To_Ext_Angle (N : Angle_Mod) return Ext_Angle; procedure Display (N : Ext_Angle); private type Ext_Angle is record Angle_Elem : Angle_Mod; Direction_Elem : Direction; end record; end Directions;
with Ada.Text_IO; use Ada.Text_IO; package body Directions is procedure Display (N : Ext_Angle) is begin Put_Line ("Angle: " & Angle_Mod'Image (N.Angle_Elem) & " => " & Direction'Image (N.Direction_Elem) & "."); end Display; function To_Direction (N : Angle_Mod) return Direction is begin case N is when 0 => return East; when 1 .. 89 => return Northwest; when 90 => return North; when 91 .. 179 => return Northwest; when 180 => return West; when 181 .. 269 => return Southwest; when 270 => return South; when 271 .. 359 => return Southeast; end case; end To_Direction; function To_Ext_Angle (N : Angle_Mod) return Ext_Angle is begin return (Angle_Elem => N, Direction_Elem => To_Direction (N)); end To_Ext_Angle; end Directions;
with Directions; use Directions; procedure Test_Directions is type Ext_Angle_Array is array (Positive range <>) of Ext_Angle; All_Directions : constant Ext_Angle_Array (1 .. 6) := (To_Ext_Angle (0), To_Ext_Angle (45), To_Ext_Angle (90), To_Ext_Angle (91), To_Ext_Angle (180), To_Ext_Angle (270)); begin for I in All_Directions'Range loop Display (All_Directions (I)); end loop; end Test_Directions;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Test_Directions; procedure Main is type Test_Case_Index is (Direction_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Direction_Chk => Test_Directions; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Limited Strings

package Limited_Strings is type Lim_String is limited private; function Init (S : String) return Lim_String; function Init (Max : Positive) return Lim_String; procedure Put_Line (LS : Lim_String); procedure Copy (From : Lim_String; To : in out Lim_String); function "=" (Ref, Dut : Lim_String) return Boolean; private type Lim_String is access String; end Limited_Strings;
with Ada.Text_IO; package body Limited_Strings is function Init (S : String) return Lim_String is LS : constant Lim_String := new String'(S); begin return Ls; end Init; function Init (Max : Positive) return Lim_String is LS : constant Lim_String := new String (1 .. Max); begin LS.all := (others => '_'); return LS; end Init; procedure Put_Line (LS : Lim_String) is begin Ada.Text_IO.Put_Line (LS.all); end Put_Line; function Get_Min_Last (A, B : Lim_String) return Positive is begin return Positive'Min (A'Last, B'Last); end Get_Min_Last; procedure Copy (From : Lim_String; To : in out Lim_String) is Min_Last : constant Positive := Get_Min_Last (From, To); begin for I in To'First .. Min_Last loop To (I) := From (I); end loop; for I in Min_Last + 1 .. To'Last loop To (I) := '_'; end loop; end; function "=" (Ref, Dut : Lim_String) return Boolean is Min_Last : constant Positive := Get_Min_Last (Ref, Dut); begin for I in Dut'First .. Min_Last loop if Dut (I) /= Ref (I) then return False; end if; end loop; return True; end; end Limited_Strings;
with Ada.Text_IO; use Ada.Text_IO; with Limited_Strings; use Limited_Strings; procedure Check_Lim_String is S1 : constant Lim_String := Init ("Hello World"); S2 : constant Lim_String := Init (30); S3 : Lim_String := Init (5); S4 : Lim_String := Init (30); begin Put ("S1 => "); Put_Line (S1); Put ("S2 => "); Put_Line (S2); if S1 = S2 then Put_Line ("S1 is equal to S2."); else Put_Line ("S1 isn't equal to S2."); end if; Copy (From => S1, To => S3); Put ("S3 => "); Put_Line (S3); if S1 = S3 then Put_Line ("S1 is equal to S3."); else Put_Line ("S1 isn't equal to S3."); end if; Copy (From => S1, To => S4); Put ("S4 => "); Put_Line (S4); if S1 = S4 then Put_Line ("S1 is equal to S4."); else Put_Line ("S1 isn't equal to S4."); end if; end Check_Lim_String;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Check_Lim_String; procedure Main is type Test_Case_Index is (Lim_String_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Lim_String_Chk => Check_Lim_String; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Generics

Display Array

generic type T_Range is range <>; type T_Element is private; type T_Array is array (T_Range range <>) of T_Element; with function Image (E : T_Element) return String is <>; procedure Display_Array (Header : String; A : T_Array);
with Ada.Text_IO; use Ada.Text_IO; procedure Display_Array (Header : String; A : T_Array) is begin Put_Line (Header); for I in A'Range loop Put_Line (T_Range'Image (I) & ": " & Image (A (I))); end loop; end Display_Array;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Display_Array; procedure Main is type Test_Case_Index is (Int_Array_Chk, Point_Array_Chk); procedure Test_Int_Array is type Int_Array is array (Positive range <>) of Integer; procedure Display_Int_Array is new Display_Array (T_Range => Positive, T_Element => Integer, T_Array => Int_Array, Image => Integer'Image); A : constant Int_Array (1 .. 5) := (1, 2, 5, 7, 10); begin Display_Int_Array ("Integers", A); end Test_Int_Array; procedure Test_Point_Array is type Point is record X : Float; Y : Float; end record; type Point_Array is array (Natural range <>) of Point; function Image (P : Point) return String is begin return "(" & Float'Image (P.X) & ", " & Float'Image (P.Y) & ")"; end Image; procedure Display_Point_Array is new Display_Array (T_Range => Natural, T_Element => Point, T_Array => Point_Array, Image => Image); A : constant Point_Array (0 .. 3) := ((1.0, 0.5), (2.0, -0.5), (5.0, 2.0), (-0.5, 2.0)); begin Display_Point_Array ("Points", A); end Test_Point_Array; procedure Check (TC : Test_Case_Index) is begin case TC is when Int_Array_Chk => Test_Int_Array; when Point_Array_Chk => Test_Point_Array; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Average of Array of Float

generic type T_Range is range <>; type T_Element is digits <>; type T_Array is array (T_Range range <>) of T_Element; function Average (A : T_Array) return T_Element;
function Average (A : T_Array) return T_Element is Acc : T_Element := 0.0; begin for I in A'Range loop Acc := Acc + A (I); end loop; return Acc / T_Element (A'Length); end Average;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Average; procedure Main is type Test_Case_Index is (Float_Array_Chk, Digits_12_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_12_Float_Array is type Custom_Float is digits 12; 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) := (-1.0, 3.0, 5.0, 7.5, 12.5); begin Put_Line ("Average: " & Custom_Float'Image (Average_Float (A))); end Test_Digits_12_Float_Array; procedure Check (TC : Test_Case_Index) is begin case TC is when Float_Array_Chk => Test_Float_Array; when Digits_12_Float_Array_Chk => Test_Digits_12_Float_Array; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Average of Array of Decimal

generic type T_Range is range <>; type T_Element is delta <> 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 : T_Element := 0.0; begin for I in A'Range loop Acc := Acc + A (I); end loop; return Acc / T_Element (A'Length); end Average;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Average; procedure Main is type Test_Case_Index is (Decimal_Array_Chk, Delta_EM4_Digits_16_Float_Array_Chk); procedure Test_Decimal_Array is type Decimal is delta 10.0 ** (-2) digits 12; type Decimal_Array is array (Integer range <>) of Decimal; function Average_Decimal is new Average (T_Range => Integer, T_Element => Decimal, T_Array => Decimal_Array); A : constant Decimal_Array (-2 .. 2) := (-1.0, 3.0, 5.0, 7.5, 12.5); begin Put_Line ("Average: " & Decimal'Image (Average_Decimal (A))); end Test_Decimal_Array; procedure Test_Delta_EM4_Digits_16_Float_Array is type Decimal is delta 10.0 ** (-4) digits 16; type Decimal_Array is array (Positive range <>) of Decimal; function Average_Decimal is new Average (T_Range => Positive, T_Element => Decimal, T_Array => Decimal_Array); A : constant Decimal_Array (2 .. 6) := (2.0, 5.0, 2.0, 8.5, -11.5); begin Put_Line ("Average: " & Decimal'Image (Average_Decimal (A))); end Test_Delta_EM4_Digits_16_Float_Array; procedure Check (TC : Test_Case_Index) is begin case TC is when Decimal_Array_Chk => Test_Decimal_Array; when Delta_EM4_Digits_16_Float_Array_Chk => Test_Delta_EM4_Digits_16_Float_Array; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Average of Array of Any Type

generic type T_Range is range <>; type T_Element is private; type T_Array is array (T_Range range <>) of T_Element; with function To_Float (E : T_Element) return Float is <>; function Average (A : T_Array) return Float;
function Average (A : T_Array) return Float is Acc : Float := 0.0; begin for I in A'Range loop Acc := Acc + To_Float (A (I)); end loop; return Acc / Float (A'Length); end Average;
procedure Test_Decimal_Array;
with Ada.Text_IO; use Ada.Text_IO; with Average; procedure Test_Decimal_Array is package F_IO is new Ada.Text_IO.Float_IO (Float); type Decimal is delta 10.0 ** (-2) digits 12; type Decimal_Array is array (Integer range <>) of Decimal; function To_Float (V : Decimal) return Float is (Float (V)); function Average_Decimal is new Average (T_Range => Integer, T_Element => Decimal, T_Array => Decimal_Array); A : constant Decimal_Array (-2 .. 2) := (-1.0, 3.0, 5.0, 7.5, 12.5); begin Put ("Average: "); F_IO.Put (Average_Decimal (A), 1, 2, 0); New_Line; end Test_Decimal_Array;
procedure Test_Item_Array;
with Ada.Text_IO; use Ada.Text_IO; with Average; procedure Test_Item_Array 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_Array;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Test_Decimal_Array; with Test_Item_Array; procedure Main is type Test_Case_Index is (Decimal_Array_Chk, Item_Array_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Decimal_Array_Chk => Test_Decimal_Array; when Item_Array_Chk => Test_Item_Array; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Generic list

generic type Item is private; type Items is array (Positive range <>) of Item; Name : String; List_Array : in out Items; Last : in out Natural; with procedure Put (I : Item) is <>; package Gen_List is procedure Init; procedure Add (I : Item; Status : out Boolean); procedure Display; end Gen_List;
with Ada.Text_IO; use Ada.Text_IO; package body Gen_List is procedure Init is begin Last := List_Array'First - 1; end Init; procedure Add (I : Item; Status : out Boolean) is begin Status := Last < List_Array'Last; if Status then Last := Last + 1; List_Array (Last) := I; end if; end Add; procedure Display is begin Put_Line (Name); for I in List_Array'First .. Last loop Put (List_Array (I)); New_Line; end loop; end Display; end Gen_List;
procedure Test_Int_List;
with Ada.Text_IO; use Ada.Text_IO; with Gen_List; procedure Test_Int_List is procedure Put (I : Integer) is begin Ada.Text_IO.Put (Integer'Image (I)); end Put; type Integer_Array is array (Positive range <>) of Integer; A : Integer_Array (1 .. 3); L : Natural; package Int_List is new Gen_List (Item => Integer, Items => Integer_Array, Name => "List of integers", List_Array => A, Last => L); Success : Boolean; procedure Display_Add_Success (Success : Boolean) is begin if Success then Put_Line ("Added item successfully!"); else Put_Line ("Couldn't add item!"); end if; end Display_Add_Success; begin Int_List.Init; Int_List.Add (2, Success); Display_Add_Success (Success); Int_List.Add (5, Success); Display_Add_Success (Success); Int_List.Add (7, Success); Display_Add_Success (Success); Int_List.Add (8, Success); Display_Add_Success (Success); Int_List.Display; end Test_Int_List;
procedure Test_String_List;
with Ada.Text_IO; use Ada.Text_IO; with Gen_List; procedure Test_String_List is type String_Access is access String; procedure Put (S : String_Access) is begin Ada.Text_IO.Put (S.all); end Put; type String_Array is array (Positive range <>) of String_Access; A : String_Array (1 .. 3); L : Natural; package String_List is new Gen_List (Item => String_Access, Items => String_Array, Name => "List of strings", List_Array => A, Last => L); Success : Boolean; procedure Display_Add_Success (Success : Boolean) is begin if Success then Put_Line ("Added item successfully!"); else Put_Line ("Couldn't add item!"); end if; end Display_Add_Success; begin String_List.Init; String_List.Add (new String'("Hello"), Success); Display_Add_Success (Success); String_List.Add (new String'("World"), Success); Display_Add_Success (Success); String_List.Add (new String'("Bye"), Success); Display_Add_Success (Success); String_List.Add (new String'("Wait"), Success); Display_Add_Success (Success); String_List.Display; end Test_String_List;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Test_Int_List; with Test_String_List; procedure Main is type Test_Case_Index is (Int_List_Chk, String_List_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Int_List_Chk => Test_Int_List; when String_List_Chk => Test_String_List; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Exceptions

Uninitialized Value

package Options is type Option is (Unitialized, Option_1, Option_2, Option_3); Unitialized_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 Unitialized => raise Unitialized_Value with "Uninitialized value detected!"; when others => return Option'Image (O); end case; end Image; end Options;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Ada.Exceptions; use Ada.Exceptions; with Options; use Options; procedure Main is type Test_Case_Index is (Options_Chk); procedure Check (TC : Test_Case_Index) is procedure Check (O : Option) is begin Put_Line (Image (O)); exception when E : Unitialized_Value => Put_Line (Exception_Message (E)); end Check; begin case TC is when Options_Chk => for O in Option loop Check (O); end loop; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Numerical Exception

package Tests is type Test_ID is (Test_1, Test_2); Custom_Exception : exception; procedure Num_Exception_Test (ID : Test_ID); end Tests;
package body Tests is pragma Warnings (Off, "variable ""C"" is assigned but never read"); procedure Num_Exception_Test (ID : Test_ID) is A, B, C : Integer; begin case ID is when Test_1 => A := Integer'Last; B := Integer'Last; C := A + B; when Test_2 => raise Custom_Exception with "Custom_Exception raised!"; end case; end Num_Exception_Test; pragma Warnings (On, "variable ""C"" is assigned but never read"); end Tests;
with Tests; use Tests; procedure Check_Exception (ID : Test_ID);
with Ada.Text_IO; use Ada.Text_IO; with Ada.Exceptions; use Ada.Exceptions; procedure Check_Exception (ID : Test_ID) is begin Num_Exception_Test (ID); exception when Constraint_Error => Put_Line ("Constraint_Error detected!"); when E : others => Put_Line (Exception_Message (E)); end Check_Exception;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Ada.Exceptions; use Ada.Exceptions; with Tests; use Tests; with Check_Exception; procedure Main is type Test_Case_Index is (Exception_1_Chk, Exception_2_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Handle_Exception (ID : Test_ID) is begin Check_Exception (ID); exception when Constraint_Error => Put_Line ("Constraint_Error" & " (raised by Check_Exception) detected!"); when E : others => Put_Line (Exception_Name (E) & " (raised by Check_Exception) detected!"); end Check_Handle_Exception; begin case TC is when Exception_1_Chk => Check_Handle_Exception (Test_1); when Exception_2_Chk => Check_Handle_Exception (Test_2); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Re-raising Exceptions

package Tests is type Test_ID is (Test_1, Test_2); Custom_Exception : exception; procedure Num_Exception_Test (ID : Test_ID); end Tests;
package body Tests is pragma Warnings (Off, "variable ""C"" is assigned but never read"); procedure Num_Exception_Test (ID : Test_ID) is A, B, C : Integer; begin case ID is when Test_1 => A := Integer'Last; B := Integer'Last; C := A + B; when Test_2 => raise Custom_Exception with "Custom_Exception raised!"; end case; end Num_Exception_Test; pragma Warnings (On, "variable ""C"" is assigned but never read"); end Tests;
with Tests; use Tests; procedure Check_Exception (ID : Test_ID);
with Ada.Text_IO; use Ada.Text_IO; with Ada.Exceptions; use Ada.Exceptions; procedure Check_Exception (ID : Test_ID) is begin Num_Exception_Test (ID); exception when Constraint_Error => Put_Line ("Constraint_Error detected!"); raise; when E : others => Put_Line (Exception_Message (E)); raise; end Check_Exception;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Ada.Exceptions; use Ada.Exceptions; with Tests; use Tests; with Check_Exception; procedure Main is type Test_Case_Index is (Exception_1_Chk, Exception_2_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Handle_Exception (ID : Test_ID) is begin Check_Exception (ID); exception when Constraint_Error => Put_Line ("Constraint_Error" & " (raised by Check_Exception) detected!"); when E : others => Put_Line (Exception_Name (E) & " (raised by Check_Exception) detected!"); end Check_Handle_Exception; begin case TC is when Exception_1_Chk => Check_Handle_Exception (Test_1); when Exception_2_Chk => Check_Handle_Exception (Test_2); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Tasking

Display Service

package Display_Services is task type Display_Service is entry Display (S : String); entry Display (I : Integer); end Display_Service; end Display_Services;
with Ada.Text_IO; use Ada.Text_IO; package body Display_Services is task body Display_Service is begin loop select accept Display (S : String) do Put_Line (S); end Display; or accept Display (I : Integer) do Put_Line (Integer'Image (I)); end Display; or terminate; end select; end loop; end Display_Service; end Display_Services;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Display_Services; use Display_Services; procedure Main is type Test_Case_Index is (Display_Service_Chk); procedure Check (TC : Test_Case_Index) is Display : Display_Service; begin case TC is when Display_Service_Chk => Display.Display ("Hello"); delay 0.5; Display.Display ("Hello again"); delay 0.5; Display.Display (55); delay 0.5; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Event Manager

with Ada.Real_Time; use Ada.Real_Time; package Event_Managers is task type Event_Manager is entry Start (ID : Natural); entry Event (T : Time); end Event_Manager; end Event_Managers;
with Ada.Text_IO; use Ada.Text_IO; package body Event_Managers is task body Event_Manager is Event_ID : Natural := 0; Event_Delay : Time; begin accept Start (ID : Natural) do Event_ID := ID; end Start; accept Event (T : Time) do Event_Delay := T; end Event; delay until Event_Delay; Put_Line ("Event #" & Natural'Image (Event_ID)); end Event_Manager; end Event_Managers;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Event_Managers; use Event_Managers; with Ada.Real_Time; use Ada.Real_Time; procedure Main is type Test_Case_Index is (Event_Manager_Chk); procedure Check (TC : Test_Case_Index) is Ev_Mng : array (1 .. 5) of Event_Manager; begin case TC is when Event_Manager_Chk => for I in Ev_Mng'Range loop Ev_Mng (I).Start (I); end loop; Ev_Mng (1).Event (Clock + Seconds (5)); Ev_Mng (2).Event (Clock + Seconds (3)); Ev_Mng (3).Event (Clock + Seconds (1)); Ev_Mng (4).Event (Clock + Seconds (2)); Ev_Mng (5).Event (Clock + Seconds (4)); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Generic Protected Queue

generic type Queue_Index is mod <>; type T is private; package Gen_Queues is type Queue_Array is array (Queue_Index) of T; protected type Queue is function Empty return Boolean; function Full return Boolean; entry Push (V : T); entry Pop (V : out T); private N : Natural := 0; Idx : Queue_Index := Queue_Array'First; A : Queue_Array; end Queue; end Gen_Queues;
package body Gen_Queues is protected body Queue is function Empty return Boolean is (N = 0); function Full return Boolean is (N = A'Length); entry Push (V : T) when not Full is begin A (Idx) := V; Idx := Idx + 1; N := N + 1; end Push; entry Pop (V : out T) when not Empty is begin N := N - 1; V := A (Idx - Queue_Index (N) - 1); end Pop; end Queue; end Gen_Queues;
package Queue_Tests is procedure Simple_Test; procedure Concurrent_Test; end Queue_Tests;
with Ada.Text_IO; use Ada.Text_IO; with Gen_Queues; package body Queue_Tests is Max : constant := 10; type Queue_Mod is mod Max; procedure Simple_Test is package Queues_Float is new Gen_Queues (Queue_Mod, Float); Q_F : Queues_Float.Queue; V : Float; begin V := 10.0; while not Q_F.Full loop Q_F.Push (V); V := V + 1.5; end loop; while not Q_F.Empty loop Q_F.Pop (V); Put_Line ("Value from queue: " & Float'Image (V)); end loop; end Simple_Test; procedure Concurrent_Test is package Queues_Integer is new Gen_Queues (Queue_Mod, Integer); Q_I : Queues_Integer.Queue; task T_Producer; task T_Consumer; task body T_Producer is V : Integer := 100; begin for I in 1 .. 2 * Max loop Q_I.Push (V); V := V + 1; end loop; end T_Producer; task body T_Consumer is V : Integer; begin delay 1.5; while not Q_I.Empty loop Q_I.Pop (V); Put_Line ("Value from queue: " & Integer'Image (V)); delay 0.2; end loop; end T_Consumer; begin null; end Concurrent_Test; end Queue_Tests;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Queue_Tests; use Queue_Tests; procedure Main is type Test_Case_Index is (Simple_Queue_Chk, Concurrent_Queue_Chk); procedure Check (TC : Test_Case_Index) is begin case TC is when Simple_Queue_Chk => Simple_Test; when Concurrent_Queue_Chk => Concurrent_Test; end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Contracts

Price Range

package Prices is pragma Assertion_Policy (Static_Predicate => Check, Dynamic_Predicate => Check); type Amount is delta 10.0 ** (-2) digits 12; -- subtype Price is Amount range 0.0 .. Amount'Last; subtype Price is Amount with Static_Predicate => Price >= 0.0; end Prices;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with System.Assertions; use System.Assertions; with Prices; use Prices; procedure Main is type Test_Case_Index is (Price_Range_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Range (A : Amount) is P : Price; begin P := A; Put_Line ("Price: " & Price'Image (P)); exception when Constraint_Error => Put_Line ("Constraint_Error detected (NOT as expected)."); when Assert_Failure => Put_Line ("Assert_Failure detected (as expected)."); end Check_Range; begin case TC is when Price_Range_Chk => Check_Range (-2.0); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Pythagorean Theorem: Predicate

package Triangles is pragma Assertion_Policy (Static_Predicate => Check, Dynamic_Predicate => Check); subtype Length is Integer; type Right_Triangle is record H : Length := 0; -- Hypotenuse C1, C2 : Length := 0; -- Catheti / legs end record with Dynamic_Predicate => H * H = C1 * C1 + C2 * C2; function Init (H, C1, C2 : Length) return Right_Triangle is ((H, C1, C2)); end Triangles;
package Triangles.IO is function Image (T : Right_Triangle) return String; end Triangles.IO;
package body Triangles.IO is function Image (T : Right_Triangle) return String is ("(" & Length'Image (T.H) & ", " & Length'Image (T.C1) & ", " & Length'Image (T.C2) & ")"); end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with System.Assertions; use System.Assertions; with Triangles; use Triangles; with Triangles.IO; use Triangles.IO; procedure Main is type Test_Case_Index is (Triangle_8_6_Pass_Chk, Triangle_8_6_Fail_Chk, Triangle_10_24_Pass_Chk, Triangle_10_24_Fail_Chk, Triangle_18_24_Pass_Chk, Triangle_18_24_Fail_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Triangle (H, C1, C2 : Length) is T : Right_Triangle; begin T := Init (H, C1, C2); Put_Line (Image (T)); exception when Constraint_Error => Put_Line ("Constraint_Error detected (NOT as expected)."); when Assert_Failure => Put_Line ("Assert_Failure detected (as expected)."); end Check_Triangle; begin case TC is when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6); when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6); when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24); when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24); when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24); when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Pythagorean Theorem: Precondition

package Triangles is pragma Assertion_Policy (Pre => Check); subtype Length is Integer; type Right_Triangle is record H : Length := 0; -- Hypotenuse C1, C2 : Length := 0; -- Catheti / legs end record; function Init (H, C1, C2 : Length) return Right_Triangle is ((H, C1, C2)) with Pre => H * H = C1 * C1 + C2 * C2; end Triangles;
package Triangles.IO is function Image (T : Right_Triangle) return String; end Triangles.IO;
package body Triangles.IO is function Image (T : Right_Triangle) return String is ("(" & Length'Image (T.H) & ", " & Length'Image (T.C1) & ", " & Length'Image (T.C2) & ")"); end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with System.Assertions; use System.Assertions; with Triangles; use Triangles; with Triangles.IO; use Triangles.IO; procedure Main is type Test_Case_Index is (Triangle_8_6_Pass_Chk, Triangle_8_6_Fail_Chk, Triangle_10_24_Pass_Chk, Triangle_10_24_Fail_Chk, Triangle_18_24_Pass_Chk, Triangle_18_24_Fail_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Triangle (H, C1, C2 : Length) is T : Right_Triangle; begin T := Init (H, C1, C2); Put_Line (Image (T)); exception when Constraint_Error => Put_Line ("Constraint_Error detected (NOT as expected)."); when Assert_Failure => Put_Line ("Assert_Failure detected (as expected)."); end Check_Triangle; begin case TC is when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6); when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6); when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24); when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24); when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24); when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Pythagorean Theorem: Postcondition

package Triangles is pragma Assertion_Policy (Post => Check); subtype Length is Integer; type Right_Triangle is record H : Length := 0; -- Hypotenuse C1, C2 : Length := 0; -- Catheti / legs end record; function Init (H, C1, C2 : Length) return Right_Triangle is ((H, C1, C2)) with Post => (Init'Result.H * Init'Result.H = Init'Result.C1 * Init'Result.C1 + Init'Result.C2 * Init'Result.C2); end Triangles;
package Triangles.IO is function Image (T : Right_Triangle) return String; end Triangles.IO;
package body Triangles.IO is function Image (T : Right_Triangle) return String is ("(" & Length'Image (T.H) & ", " & Length'Image (T.C1) & ", " & Length'Image (T.C2) & ")"); end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with System.Assertions; use System.Assertions; with Triangles; use Triangles; with Triangles.IO; use Triangles.IO; procedure Main is type Test_Case_Index is (Triangle_8_6_Pass_Chk, Triangle_8_6_Fail_Chk, Triangle_10_24_Pass_Chk, Triangle_10_24_Fail_Chk, Triangle_18_24_Pass_Chk, Triangle_18_24_Fail_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Triangle (H, C1, C2 : Length) is T : Right_Triangle; begin T := Init (H, C1, C2); Put_Line (Image (T)); exception when Constraint_Error => Put_Line ("Constraint_Error detected (NOT as expected)."); when Assert_Failure => Put_Line ("Assert_Failure detected (as expected)."); end Check_Triangle; begin case TC is when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6); when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6); when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24); when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24); when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24); when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Pythagorean Theorem: Type Invariant

package Triangles is pragma Assertion_Policy (Type_Invariant => Check); subtype Length is Integer; type Right_Triangle is private with Type_Invariant => Check (Right_Triangle); function Check (T : Right_Triangle) return Boolean; function Init (H, C1, C2 : Length) return Right_Triangle; private type Right_Triangle is record H : Length := 0; -- Hypotenuse C1, C2 : Length := 0; -- Catheti / legs end record; function Init (H, C1, C2 : Length) return Right_Triangle is ((H, C1, C2)); function Check (T : Right_Triangle) return Boolean is (T.H * T.H = T.C1 * T.C1 + T.C2 * T.C2); end Triangles;
package Triangles.IO is function Image (T : Right_Triangle) return String; end Triangles.IO;
package body Triangles.IO is function Image (T : Right_Triangle) return String is ("(" & Length'Image (T.H) & ", " & Length'Image (T.C1) & ", " & Length'Image (T.C2) & ")"); end Triangles.IO;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with System.Assertions; use System.Assertions; with Triangles; use Triangles; with Triangles.IO; use Triangles.IO; procedure Main is type Test_Case_Index is (Triangle_8_6_Pass_Chk, Triangle_8_6_Fail_Chk, Triangle_10_24_Pass_Chk, Triangle_10_24_Fail_Chk, Triangle_18_24_Pass_Chk, Triangle_18_24_Fail_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_Triangle (H, C1, C2 : Length) is T : Right_Triangle; begin T := Init (H, C1, C2); Put_Line (Image (T)); exception when Constraint_Error => Put_Line ("Constraint_Error detected (NOT as expected)."); when Assert_Failure => Put_Line ("Assert_Failure detected (as expected)."); end Check_Triangle; begin case TC is when Triangle_8_6_Pass_Chk => Check_Triangle (10, 8, 6); when Triangle_8_6_Fail_Chk => Check_Triangle (12, 8, 6); when Triangle_10_24_Pass_Chk => Check_Triangle (26, 10, 24); when Triangle_10_24_Fail_Chk => Check_Triangle (12, 10, 24); when Triangle_18_24_Pass_Chk => Check_Triangle (30, 18, 24); when Triangle_18_24_Fail_Chk => Check_Triangle (32, 18, 24); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;

Primary Colors

package Color_Types is type HTML_Color is (Salmon, Firebrick, Red, Darkred, Lime, Forestgreen, Green, Darkgreen, Blue, Mediumblue, Darkblue); subtype Int_Color is Integer range 0 .. 255; function Image (I : Int_Color) return String; type RGB is record Red : Int_Color; Green : Int_Color; Blue : Int_Color; end record; function To_RGB (C : HTML_Color) return RGB; function Image (C : RGB) return String; type HTML_Color_RGB_Array is array (HTML_Color) of RGB; To_RGB_Loopup_Table : constant HTML_Color_RGB_Array := (Salmon => (16#FA#, 16#80#, 16#72#), Firebrick => (16#B2#, 16#22#, 16#22#), Red => (16#FF#, 16#00#, 16#00#), Darkred => (16#8B#, 16#00#, 16#00#), Lime => (16#00#, 16#FF#, 16#00#), Forestgreen => (16#22#, 16#8B#, 16#22#), Green => (16#00#, 16#80#, 16#00#), Darkgreen => (16#00#, 16#64#, 16#00#), Blue => (16#00#, 16#00#, 16#FF#), Mediumblue => (16#00#, 16#00#, 16#CD#), Darkblue => (16#00#, 16#00#, 16#8B#)); subtype HTML_RGB_Color is HTML_Color with Static_Predicate => HTML_RGB_Color in Red | Green | Blue; function To_Int_Color (C : HTML_Color; S : HTML_RGB_Color) return Int_Color; -- Convert to hexadecimal value for the selected RGB component S end Color_Types;
with Ada.Integer_Text_IO; package body Color_Types is function To_RGB (C : HTML_Color) return RGB is begin return To_RGB_Loopup_Table (C); end To_RGB; function To_Int_Color (C : HTML_Color; S : HTML_RGB_Color) return Int_Color is C_RGB : constant RGB := To_RGB (C); begin case S is when Red => return C_RGB.Red; when Green => return C_RGB.Green; when Blue => return C_RGB.Blue; end case; end To_Int_Color; function Image (I : Int_Color) return String is subtype Str_Range is Integer range 1 .. 10; S : String (Str_Range); begin Ada.Integer_Text_IO.Put (To => S, Item => I, Base => 16); return S; end Image; function Image (C : RGB) return String is begin return ("(Red => " & Image (C.Red) & ", Green => " & Image (C.Green) & ", Blue => " & Image (C.Blue) &")"); end Image; end Color_Types;
with Ada.Command_Line; use Ada.Command_Line; with Ada.Text_IO; use Ada.Text_IO; with Color_Types; use Color_Types; procedure Main is type Test_Case_Index is (HTML_Color_Red_Chk, HTML_Color_Green_Chk, HTML_Color_Blue_Chk); procedure Check (TC : Test_Case_Index) is procedure Check_HTML_Colors (S : HTML_RGB_Color) is begin Put_Line ("Selected: " & HTML_RGB_Color'Image (S)); for I in HTML_Color'Range loop Put_Line (HTML_Color'Image (I) & " => " & Image (To_Int_Color (I, S)) & "."); end loop; end Check_HTML_Colors; begin case TC is when HTML_Color_Red_Chk => Check_HTML_Colors (Red); when HTML_Color_Green_Chk => Check_HTML_Colors (Green); when HTML_Color_Blue_Chk => Check_HTML_Colors (Blue); end case; end Check; begin if Argument_Count < 1 then Put_Line ("ERROR: missing arguments! Exiting..."); return; elsif Argument_Count > 1 then Put_Line ("Ignoring additional arguments..."); end if; Check (Test_Case_Index'Value (Argument (1))); end Main;