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

Exercise #1

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;

Exercise #2

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;

Exercise #3

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;