-- -*- Ada -*-
-- @@PLEAC@@_NAME
-- @@SKIP@@ Ada
-- @@PLEAC@@_WEB
-- @@SKIP@@ http://www.adapower.com/
-- @@PLEAC@@_INTRO
-- @@SKIP@@ Ada requires data items to be declared in a declarative region at
-- @@SKIP@@ the beginning of a code block, before the "begin" reserved word.
-- @@SKIP@@ Many of the PLEAC subsections are implemented in their own unnamed
-- @@SKIP@@ code block to define local variables, functions, and procedures
-- @@SKIP@@ close to their usage, as would be done in Perl.
-- @@PLEAC@@_APPENDIX
with Ada.Text_Io;
with Ada.Integer_Text_IO;
with Ada.Float_Text_Io;
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Ada.Numerics.Discrete_Random;
with Ada.Numerics.Float_Random;
with Ada.Numerics.Elementary_Functions;
with Ada.Numerics.Generic_Complex_Types;
with Ada.Text_IO.Editing;
with Ada.Strings.Bounded;
with Ada.Strings.Unbounded;
with Gnat.Regpat;
-- @@PLEAC@@_1.0
----------------------------------------------------------------------------
---- Charater are enumeration values and use single quotes for delimiters
-- except for non-printing characters, which have their own labels
c : character := LF;
-- a newline (line feed) character
----------------------------------------------------------------------------
---- Strings are fixed length arrays of characters with no NULL terminator
s1 : string(1..1) := (1 => LF); -- A string containing only a line feed
s2 : string := "Jon " & '"' &
"Maddog" & '"' & "Orwant"; -- a string containing double quotes
Put_Line("Jon 'Maddog' Orwant"); -- a string containing single quotes
------------------------------------------------------------------------------
s : string := "This is a multiline string declaration "
& "using the concatenation operator "
& "to append separate parts.";
------------------------------------------------------------------------------
-- @@PLEAC@@_1.1
------------------------------------------------------------------------------
-- accessing substrings
s1 : string := data(start..ending);
-- "end" is a reserved word in Ada
s2 : string := data(start..data'Last); -- substrings accessed through array slices
-----------------------------------------------------------------------------
-- different string types
-- Bounded strings have a fixed maximum length and may vary in size up to the
-- maximum length.
package Bounded is new Ada.Strings.Bounded.Generic_Bounded_Length(80);
s : Bounded.Bounded_String := Bounded.To_Bounded_String("Hello World!");
-- Unbounded strings have no maximum size and may vary in size and content
use Ada.Strings.Unbounded;
s : Unbounded_String := To_Unbounded_String("Hello World!");
------------------------------------------------------------------------------
-- No pack/unpack equivalents exist in standard Ada libraries.
-- Examples here use a custom implementation to split an original string into
-- chunks of specified length.
-- TO BE DONE
------------------------------------------------------------------------------
-- Aggregates repeating a basic pattern s :
string := 5 * "Wow! ";
-- result: "Wow! Wow! Wow! Wow! Wow! "
------------------------------------------------------------------------------
data : string := "This is what you have";
-- forward 123456789012345678901
-- Any data element can be accessed directly through its index.
-- Substrings can be accessed directly through array slices.
first : character := data(1); -- 'T'
start : string := data(6..7); -- "is"
rest : string := data(14..data'Last); -- "you have"
last : character := data(data'Last); -- 'e'
final : string := data(data'Last - 3..data'Last);-- "have"
piece : string := data(14..16); -- "you"
------------------------------------------------------------------------------
-- String contents can be rearranged as long as the length of the string does
-- not change. If you want to change the length then use either Bounded or
-- Unbounded strings.
data : string := "This is what you have";
data(18..21) := "were"; -- "This is what you were"
data(1..7) := "Is this"; -- "Is this what you were"
------------------------------------------------------------------------------
use GNAT.Regpat;
-- roughly the same set of regular expressions as are available in Perl or
-- Python.
Match_Position : Natural;
Match_Position := Match(Compile("pattern"),data(data'last - 9..data'last));
if Match_Position > 0 then
Put_Line("Pattern matches in last 10 characters");
end if;
-- substitute "at" for "is", restricted to the first five characters
declare
Matches : Match_Array(0..4);
Regexp : string := "is";
Data : string := "This is what you have";
begin
Match(Regexp, Data(1..5), Matches);
if Matches(0).First > 0 then
Data(Matches(0).First .. Matches(0).Last) := "at";
end if;
end;
-- exchange the first and last letters in a string
data : string := "make a hat";
temp : character := data(1);
data(1) := data(data'Last);
data(data'Last) := temp; -- "take a ham"
-- extract a column with array slicing
data : string := "to be or not to be";
a1 : string := data(7..12); -- "or not"
-- forward 6, grab 2, backward 5, grab 2
a2 : string := data(7..8) & data(4..5); -- "orbe"
------------------------------------------------------------------------------
-- @@PLEAC@@_1.2
------------------------------------------------------------------------------
-- boolean values
-- use b if b is true, else use c
b, c : boolean;
-- [..]
a : boolean := b or else c; -- lazy evaluation
-- set x to y unless x is already true
x, y : boolean;
-- [..]
x := x or else y; -- Ada has no ternary operator
-------------------------------------
-- find the user name on Unix systems
with Gnat.Os_Lib; -- Gnat.Os_Lib is a Gnat extension
username : string := Gnat.Os_Lib.Getenv("USER");
logname : string := Gnat.Os_Lib.Getenv("LOGNAME");
------------------------------------------------------------------------------
-- @@PLEAC@@_1.3
------------------------------------------------------------------------------
-- Ada always requires temporary variables to swap values
------------------------------------------------------------------------------
-- @@PLEAC@@_1.4
------------------------------------------------------------------------------
num : integer := character'Pos(char);
char : character := character'Val(num);
------------------------------------------------------------------------------
-- @@PLEAC@@_1.5
------------------------------------------------------------------------------
s : string := "Some value"; c : character;
for index in S'Range loop
c := s(index);
end loop;
------------------------------------------------------------------------------
-- @@PLEAC@@_2.0
procedure Pleac_Numbers is
type Small_Int is range -10..10;
Numeric_String : String(1..80) := (1=> '6', Others => ' ');
-- Ada defaults to fixed length strings.
Int : Integer;
Flt : Float;
Small : Small_Int;
-- @@PLEAC@@_2.1
begin
Int := Integer'Value(Numeric_String);
exception
when Constraint_Error =>
Put_Line(Numeric_String & " is not an Integer");
end;
begin
Flt := Float'Value(Numeric_String);
exception
when Constraint_Error =>
Put_Line(Numeric_String & " is not a float");
end;
-- Ada also allows you to define your own numeric types and check
-- for valid conversion from a string, including out of range
-- errors
begin
Small := Small_Int'Value(Numeric_String);
exception
when Constraint_Error =>
Put_Line(Numeric_String & " is not a Small_Int");
end;
-- @@PLEAC@@_2.2
function equal(Num1, Num2 : Float; Accuracy : Integer) return Boolean is
My_Delta : Float := 10.0 ** (-Accuracy);
Diff : Float := abs (Num1 - Num2);
begin
return Diff < My_Delta;
end equal;
----------------------------------------------------------------------
-- Ada offers another form of Real numbers : Fixed point types
-- You specify the fixed precision of the type in the "delta"
-- parameter for the type
-- The following type will have a clearly specified range:
-- -999_999_999.999 to 999_999_999.999
type Real is delta 0.001 digits 12;
R1, R2 : Real;
-- [...]
if R1 = R2 then
Ada.Text_Io.Put_Line (Real'Image(R1) & " equals"
& Real'Image(R2));
end if;
wage : Float := 5.36;
week : Float := 40.0 * wage;
begin
Put("One week's wage is: $");
Put(Item => week, Exp => 0, Aft => 2);
New_Line;
end;
-- @@PLEAC@@_2.3
declare
a : float := 0.255;
begin
Put("Unrounded: ");
Put(Item => a, Exp => 0, Aft => 3);
New_Line;
Put("Rounded: ");
Put(Item => a, Exp => 0, Aft => 2);
New_Line;
end;
------
declare
type vals is array(1..4) of float;
a : vals := (3.3, 3.5, 3.7, -3.3);
begin
for num in vals'range loop
Put(Item => a(num), Exp => 0, Aft => 1);
Put(Ada.Characters.Latin_1.HT);
Put(Item => Float'Truncation(a(num)), Aft =>1, Exp => 0);
Put(Ada.Characters.Latin_1.HT);
Put(Item => Float'Floor(a(num)), Aft => 1,Exp => 0);
Put(Ada.Characters.Latin_1.HT);
Put(Item => Float'Ceiling(a(num)), Aft => 1,Exp => 0);
New_Line;
end loop;
end;
------------
-- @@PLEAC@@_2.4
-- Ada uses the notation Base#value# for a non-decimal value
-- Thus, a binary number is defined as 2#0011_0110#.
-- The underscores are optional, for readability only.
declare
num : Integer := 2#0011_0110#;
begin
Put("Decimal: ");
Put(Item => num);
New_Line;
Put("Binary: ");
Put(Item => num, Base => 2);
New_Line;
end;
-- @@PLEAC@@_2.5
declare
x : Integer := 5;
y : Integer := 10;
begin
for i in x..y loop
-- i is set to every Integer from x to y, inclusive
null;
end loop;
end;
declare
x : Integer := 5;
y : Integer := 12;
num : Integer := x;
begin
loop
-- operate on num
num := num + 7; -- step size = 7
exit when num > y;
end loop;
end;
Put("Childhood is: ");
for num in 5..12 loop
Put(Integer'Image(num));
end loop;
New_Line;
---------------
-- @@PLEAC@@_2.6
---------------
-- No standard roman numeral package available
---------------
-- @@PLEAC@@_2.7
-- Generating random discrete values
declare
type Rand_Range is range 25..75;
package Rand_Int is new Ada.Numerics.Discrete_Random(Rand_Range);
seed : Rand_Int.Generator;
Num : Rand_Range;
begin
Rand_Int.Reset(seed);
Num := Rand_Int.Random(seed);
Put_Line(Rand_Range'Image(Num));
end;
-- Generating a random 8 character password
declare
subtype alphas is Character range 'A'..'z';
package Rand_Alpha is new Ada.Numerics.Discrete_Random(alphas);
seed : Rand_Alpha.Generator;
Password : String(1..8);
begin
Rand_Alpha.Reset(seed);
for index in Password'Range loop
Password(index) := Rand_Alpha.Random(seed);
end loop;
Put_Line("Random Password: " & Password);
end;
-- Generating Random Floating Point Numbers
declare
seed : Ada.Numerics.Float_Random.Generator;
begin
Ada.Numerics.Float_Random.Reset(seed);
Put_Line("Random Float: " &
Float'Image(Ada.Numerics.Float_Random.Random(seed)));
end;
--------
-- @@PLEAC@@_2.8
------------
-- Ada random number generators are required to yield a period of
-- at least (2^31)-2 or greater.
--------
-- @@PLEAC@@_2.9
------------
-- Ada does not provide a standard biased random number package
------------
-- @@PLEAC@@_2.10
------------
-- Using the Cycle parameter of the Elementary Functions to define
-- a cycle of 0.0..359.99
declare
use Ada.Numerics.Elementary_Functions;
angle : float := 45.0;
degrees : constant float := 360.0;
degreeSine : float;
begin
DegreeSine := sin(X => angle, Cycle => degrees);
Put_Line("Sine of " & float'Image(angle) &
" degrees is " & float'Image(degreeSine));
end;
-- @@PLEAC@@_2.11
declare
y: float;
package Elm renames Ada.Numerics.Elementary_Functions;
begin
y := Elm.Arccos(X => 0.7);
Put_Line("arccos(0.7) = " & float'Image(y));
end;
-- @@PLEAC@@_2.12
-- The Ada.Numerics.Elementary_Functions.Log function returns
-- a natural logarithm when no base is specified, and a log to
-- the specified base when a base is specified.
declare
use Ada.Numerics.Elementary_Functions;
answer : float := log(X => 10000.0, Base => 10.0);
begin
Put_Line("Log10(10000) = " & Float'Image(answer));
end;
-- @@PLEAC@@_2.13
-- Compute the multiplication of two given matrices.
declare
type Data is array(Positive range <>,Positive range <>) of Integer;
type Matrix(Rows : Positive; Cols : Positive) is record
Mat : Data(1..Rows,1..Cols);
end record;
Matrix_Mismatch : exception;
function Mat_Mult(Matrix1 : Matrix;
Matrix2 : Matrix) return Matrix is
result : Matrix(Matrix1.Rows, Matrix2.Cols);
begin
if Matrix1.Rows /= Matrix2.Cols then
raise Matrix_Mismatch;
end if;
for i in 1..Matrix1.Rows loop
for j in 1..Matrix2.Cols loop
for k in 1..Matrix1.Cols loop
result.Mat(i,j) := result.Mat(i,j)+ (Matrix1.Mat(i,k) *
Matrix2.Mat(k,j));
end loop;
end loop;
end loop;
return result;
end Mat_Mult;
Mat1 : Matrix(Rows => 2,Cols => 3);
Mat2 : Matrix(Rows => 3,Cols => 2);
Mat3 : Matrix(Rows => 2,Cols => 2);
begin
Mat1.Mat := ((3,2,3), (5,9,8));
Mat2.Mat := ((4,7),(9,3),(8,1));
Mat3 := Mat_Mult(Mat1, Mat2);
end;
-- @@PLEAC@@_2.14
declare
package Cmplx_Flt is new
Ada.Numerics.Generic_Complex_Types(float);
use Cmplx_Flt;
a : Cmplx_Flt.Complex := (3.0, 5.0);
b : Cmplx_Flt.Complex := (2.0, -2.0);
c : Cmplx_Flt.Complex;
begin
c := a * b;
end;
-- @@PLEAC@@_2.15
-- Ada allows representation of any base from 2 through 16 on output
-- all Integers are stored internally as binary.
declare
Num : Integer;
begin
Put_Line("Gimme a number in decimal, octal, or hex:");
Get(Num);
Put_Line("Decimal value: " & Integer'Image(Num));
Put("Octal Value: ");
Put(Item => Num, Base => 8);
New_Line;
Put("Hexadecimal Value: ");
Put(Item => Num, Base => 16);
New_Line(2);
------
Put_Line("Enter a file permission in octal: ");
Get(Num);
Put_Line("Decimal Value:" & Integer'Image(Num));
end;
-- @@PLEAC@@_2.16
-- The Text Editing routines in Ada work for fixed decimal types
declare
type Large_Type is delta 0.01 digits 10;
package with_Commas is new
Ada.Text_Io.Editing.Decimal_Output(Large_Type);
use with_Commas;
use Ada.Text_IO.Editing;
Val : Large_Type := 12345678.90;
begin
put(Val, To_Picture("ZZ_ZZZ_ZZ9.99"));
end;
----------------
-- @@PLEAC@@_2.17
-----------------
-- There are no standard Ada regular expression packages,
-- however, then GNAT compiler does provide some regular expression
-- packages as extensions.
end Pleac_Numbers;
-- @@PLEAC@@_2.18
-----------------------------------------------------------------
------- Program Calculating Prime Factors
-----------------------------------------------------------------
-----with Ada.Text_Io; use Ada.Text_IO;
with Ada.Integer_Text_Io; use Ada.Integer_Text_Io;
with Ada.Command_Line; use Ada.Command_Line;
procedure Prime_Factors is
type Found_List is array(Positive range <>) of Natural;
type Factor_List (Max_Size : Positive) is record
Factors : Found_List(1..Max_Size) := (Others => 0);
Num_Found : Natural := 0;
end record;
function getFactors(n : in Integer) return Factor_List is
orig : Integer := n;
new_n : Integer := n;
Temp : Factor_List(Max_Size => n / 2);
sqi : Integer := 4;
i : Integer := 2;
begin
while sqi <= new_n loop
while (new_n mod i) = 0 loop
new_n := new_n / i;
if Temp.Factors(i) = 0 then
Temp.Factors(i) := 1;
else
Temp.Factors(i) := Temp.Factors(i) + 1;
Temp.Num_Found := Temp.Num_Found + 1;
end if;
end loop;
sqi := (i + 1)**2;
i := i + 1;
end loop;
if (new_n /= 1) and (new_n /= orig) then
Temp.Factors(new_n) := 1;
Temp.Num_Found := Temp.Num_Found + 1;
end if;
return Temp;
end getFactors;
procedure Display_Factors(Num : Integer; Item : in Factor_List) is
begin
Put(Integer'Image(Num) & ": ");
if Item.Num_Found = 0 then
Put_Line("PRIME");
else
for index in Item.Factors'Range loop
if Item.Factors(index) /= 0 then
Put(Item => index, width => 1);
if Item.Factors(index) > 1 then
Put("^");
Put(Item => Item.Factors(index), width => 1);
end if;
Ada.Text_Io.Put(" ");
end if;
end loop;
New_Line;
end if;
end Display_Factors;
begin
if Argument_Count < 1 then
Put_Line("Usage: " & Command_Name & " number...");
return;
end if;
for arg in 1..Argument_Count loop
Display_Factors(Positive'Value(Argument(arg)),
getFactors(Positive'Value(Argument(arg))));
end loop;
end Prime_Factors;
------------------------------------------------------------------------------
-- @@PLEAC@@_3.0
------------------------------------------------------------------------------
-- All standard Ada date / time subprograms are defined in the packages
-- Ada.Calendar and Ada.Real_Time
--
-- Time values can be split into a Year number, a Month number, a Day
-- (of the month) number, and a Seconds number.
------------------------------------------------------------------------------
-- @@PLEAC@@_3.1
------------------------------------------------------------------------------
Now : Time;
Now := Clock; -- A parameter-less function returning the current time value.
Put("The current date is ");
Put(Item => Year(Now), Width => 4);
Put(Item => Month(Now), Width => 3);
Put(Item => Day(Now), Width => 3);
The current date is 2002 2 25
------------------------------
Now : Time;
This_Year : Year_Number;
This_Month : Month_Number;
This_Day : Day_Number;
This_Seconds : Day_Duration;
Split(Date => Now, Year => This_Year, Month => This_Month,
Day => This_Day, Seconds => This_Seconds);
Put("The current date is ");
Put(Item => This_Year, Width => 4);
Put(Item => This_Month, Width => 3);
Put(Item => This_Day, Width => 3);
The current date is 2002 2 25
------------------------------------------------------------------------------
-- @@PLEAC@@_3.2
------------------------------------------------------------------------------
-- Ada does not directly deal with minutes. Minutes are contained in the
-- Seconds value, which is the number of seconds into the day for the current
-- time. Seconds is a value from 0.0 through 86400.0
This_Year : Year_Number;
This_Month : Month_Number;
This_Day : Day_Number;
This_Seconds : Day_Duration;
The_Time : Time;
The_Time := Time_Of(Year => This_Year, Month => This_Month,
Day => This_Day, Seconds => This_Seconds);
-------------------------------
-- Year_Number is an integer from 1901 through 2099
-- Month_Number is an integer from 1 through 12
-- Day_Number is an integer from 1 through 31
-- Day_Duration is a Fixed Point type from 0.0 through 86400.0
------------------------------------------------------------------------------
-- @@PLEAC@@_3.3
------------------------------------------------------------------------------
The_Time : Time;
The_Year : Year_Number;
The_Month : Month_Number;
The_Day : Day_Number;
The_Seconds : Day_Duration;
The_Minutes : Integer;
The_Hour : Integer;
Seconds : Integer;
Split(Date => The_Time, Year => The_Year, Month => The_Month,
Day => The_Day, Seconds => The_Seconds);
The_Hour := The_Seconds / 3600;
The_Minutes := (The_Seconds - (3600 * The_Hour)) / 60;
Seconds := The_Seconds mod 60;
------------------------------------------------------------------------------
-- @@PLEAC@@_3.4
------------------------------------------------------------------------------
-- Time addition involves adding a Duration to a Time.
-- A Duration is a total number of seconds.
Birthtime : Time;
Interval : Duration;
Then : Time;
Birthtime := Time_Of(Year => 1973, Month => 1, Day => 18,
Seconds => ((3.0 * 3600.0) + -- 3:45:50
(45.0 * 60.0) + 50.0));
Interval := 5.0 + -- 5 seconds
(17.0 * 60.0) + -- 17 minutes
(2.0 * 3600.0) + -- 2 hours
(55.0 * 86400.0); -- 55 days
Then := Birthtime + Interval; --
-- or
Then := Interval + Birthtime;
Put("Then is ");
Put(Item => Month(Then), Width => 2);
Put(Item => Day(Then), Width => 3);
Put(Item => Year(Then), Width => 5);
Put(Item => Seconds(Then) / 3600, Width => 3);
Put(":");
Put(Item => (Seconds(Then) - (Seconds(Then) / 3600 * 3600)) / 60,
Width => 2);
Put(":");
Put(Item => Seconds(Then) mod 60, Width => 2);
New_Line;
Then is 3 14 1973 6: 2:55
------------------------------------------------------------------------------
-- @@PLEAC@@_3.5
------------------------------------------------------------------------------
Seconds : Duration;
Recent : Time;
Earlier : Time;
Seconds := Recent - Earlier;
Earlier := Recent - Seconds;
------------------------------------------------------------------------------
-- @@PLEAC@@_3.6
------------------------------------------------------------------------------
-- Ada provides no standard subprogram for calculation of week number, day of
-- week, Julian Date, or Month name.
-- Those calculations can be performed, with month names localized to the
-- current locale, by simple user defined functions.
------------------------------------------------------------------------------
-- @@PLEAC@@_3.7
------------------------------------------------------------------------------
date : String := "1998-06-03"; -- YYYY-MM-DD format
The_Year : Year_Number;
The_Month : Month_Number;
The_Day : Day_Number;
Index : Positive;
Get(From => date, Item => The_Year, Last => Index); -- Get YYYY as an integer
Get(From => date(Index + 2..date'Last), -- Get MM skipping first "-"
Item => The_Month, Last => Index);
Get(From => date(Index + 2..date'Last), -- Get DD skipping second "-"
Item => The_Day, Last => Index);
-- Calculate the time value at midnight of that date
The_Time : Time;
The_Time := Time_Of(Year => The_Year, Month => The_Month,
Day => The_Day, Seconds => 0.0);
------------------------------------------------------------------------------
-- @@PLEAC@@_3.8
------------------------------------------------------------------------------
function Month_Name(Month : Month_Number) return String is
type Months is (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, SEP, OCT,
NOV, DEC);
begin
-- convert month number to enumeration value then convert enumeration
-- value to a string
return Months'Image(Months'Val(Month - 1));
end Month_Name;
-------------------------------
SEP 21 15:33:36 1997
-------------------------------
The_Time : Time;
The_Time := Time_Of(Year => 1997,
Month => 9,
Day => 21,
Seconds => 36.0 +
(33.0 * 60.0) +
(15.0 * 3600.0));
Put(Month_Name(Month(The_Time)) & " ");
Put(Item => Day(The_Time), Width => 2);
Put(Item => Seconds(The_Time) / 3600, Width => 3);
Put(":");
Put(Item => (Seconds(The_Time) - (Seconds(The_Time) / 3600 * 3600)) / 60,
Width => 2);
Put(":");
Put(Item => Seconds(The_Time) mod 60, Width => 2);
Put(Item => Year(The_Time), Width => 5);
New_Line;
------------------------------------------------------------------------------
-- @@PLEAC@@_3.9
------------------------------------------------------------------------------
-- High resolution time is provided by the Ada.Real_Time package.
-- High resolution time values shall be sufficient to uniquely represent the
-- range of real times from program start up to 50 years later.
-- Tick (the avearage time interval during which the clock value remains constant)
-- shall be no greater than 1 millisecond. Time_Unit (the smallest amount of real
-- time representable by the time type) shall be less than or equal to 20
-- microseconds.
with Ada.Real_Time; use Ada.Real_Time;
t0 : Time;
t1 : Time;
t0 := Clock; -- Get initial time stamp;
-- Perform some operation
t1 := Clock; -- Get ending time stamp;
elapsed : Time_Span;
elapsed := t1 - t0; -- Time in seconds i.e 0.0015
------------------------------------------------------------------------------
-- @@PLEAC@@_3.10
------------------------------------------------------------------------------
-- sleeps are achieved in Ada using the "delay" statement.
-- The parameter to the delay command is a Duration expressing a number of
-- seconds.
delay 0.0025;
------------------------------------------------------------------------------
-- @@PLEAC@@_3.11
------------------------------------------------------------------------------
-- To Be Done
------------------------------------------------------------------------------
-- @@PLEAC@@_7.0
------------------------------------------------------------------------------
-- Normal textual input and output is accomplished using the pacakge
-- Ada.Text_IO. The following I/O routines are taken from that package
file : File_Type;
begin
Open(File => file, Name => "/usr/local/widgets/data", Mode => In_File);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
-------------------------------
file : File_Type;
length : Natural;
line : String(1..1024); -- some string large enough to hold any line in
-- the file
begin
Open(File => file, Name => "/usr/local/widgets/data", Mode => In_File);
while not End_Of_File(file) loop
Get_Line(File => file, Item => line, Last => length);
Put_Line(Item => line(1..length)); -- writes to stdout
end loop;
Close(file);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error, -- writes to stderr
Item => "You do not have permission to open the file");
end;
-------------------------------
num : float;
while not End_Of_File loop
begin
Get(Item => num); -- read a float from stdin
Put_Line(float'Image(num)); -- write to stdout
exception
when Data_Error =.
Put(File => Standard_Error, -- write to stderr
Item => "File contains non-numeric data");
Skip_Line; -- skip the rest of the current input line
end;
end loop;
-------------------------------
logfile : File_Type;
begin
Open(File => logfile,
Name => "/tmp/log",
Mode => Out_File); -- open for output
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error, -- writes to stderr
Item => "You do not have permission to open the file");
end;
-------------------------------
oldfile : File_Type;
oldfile := Current_Output; -- save old file handle
Set_Output(logfile); -- switch standard output
Put_Line("Countdown initiated ...");
Set_Output(oldfile); -- return to original output
Put_Line("You have 30 seconds to reach maximum safety distance.");
------------------------------------------------------------------------------
--@@PLEAC@@_7.1
------------------------------------------------------------------------------
source : file_type;
sink : file_type;
-- open file for reading
begin
Open(File => source, Name => path, Mode => In_File);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
-- open file for writing
begin
Open(File => sink, Name => path, Mode => Out_File);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
-- Open file for writing, creating a new file
begin
Create(File => sink, Name => path);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
-------------------------------
-- You must instantiate the package Ada.Direct_Io to perform both input
-- and output on a file.
package dir_text is new Ada.Direct_Io(Character);
use dir_text;
direct : File_Type;
begin
Open(File => direct, Name => path, Mode => InOut_File);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
-------------------------------
sink : File_Type;
begin
Open(File => sink, Name => path, Mode => Append_File);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
------------------------------------------------------------------------------
-- @@PLEAC@@_7.2
------------------------------------------------------------------------------
-- Ada does not provide any rules about file names. Unusual file names are
-- opened the same as common file names.
------------------------------------------------------------------------------
-- @@PLEAC@@_7.3
------------------------------------------------------------------------------
-- Ada provides no facilities for expanding tildes in file names.
------------------------------------------------------------------------------
-- @@PLEAC@@_7.4
------------------------------------------------------------------------------
-- (The Ada equivalent)
sink : File_Type;
begin
Open(File => sink, Name => path, Mode => Append_File);
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File " & path " not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File " & path & " already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open file " & path);
end;
------------------------------------------------------------------------------
-- @@PLEAC@@_7.5
------------------------------------------------------------------------------
-- Passing in a null string for the file name creates a temporary file
begin
Create(File => sink, Name => "");
exception
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
------------------------------------------------------------------------------
-- @@PLEAC@@_7.6
------------------------------------------------------------------------------
-- Not allowed in Ada.
------------------------------------------------------------------------------
-- @@PLEAC@@_7.7
------------------------------------------------------------------------------
line : String(1..256);
length : Natural;
while not End_Of_File loop
Get_Line(Item => line, Last => length);
-- ... -- do something with the input line
end loop;
-------------------------------
-- The GNAT extension package Gnat.Command_Line provides some high level
-- command line parsing capabilities.
-- Simple command line parsing is provided by the standard package
-- Ada.Command_Line.
source : File_Type;
for argnum in 1..Argument_Count loop
begin
Open(File => Source, Name => Argument(argnum),
Mode => In_File);
while not End_Of_File(source) loop
-- process the file from the command line
end loop;
exception
when Name_Error =>
Put(File => Standard_Error, Item => "File name not found.");
when Status_Error =>
Put(File => Standard_Error, Item => "File already open.");
when Use_Error =>
Put(File => Standard_Error,
Item => "You do not have permission to open the file");
end;
end loop;
-------------------------------
-- arg demo 1: Process optional -c flag
loop
case GetOpt("-c") is
when ASCII.NUL =>
exit; -- exit loop
when 'c' =>
-- set whatever internal flag corresponds to the "-c" option
when Others =>
raise Program_Error; -- cannot occur!
end case;
end loop;
-------------------------------
-- arg demo 2: Process optional -NUMBER flag
loop
case GetOpt("1 2 3 4 5 6 7 8 9") is
when ASCII.NUL =>
exit;
when '1' =>
-- process 1
when '2' =>
-- process 2
when '3' =>
-- process 3
when '4' =>
-- process 4
when '5' =>
-- process 5
when '6' =>
-- process 6
when '7' =>
-- process 7
when '8' =>
-- process 8
when '9' =>
-- process 9
when Others =>
raise Program_Error;
end case;
end loop;
-------------------------------
-- arg demo 3: Process clustering -a, -i, -n, or -u flags
loop
case Get_Opt("a i n u") is
when ASCII.NUL =>
exit;
when 'a' =>
append := true;
when 'i' =>
ignore_ints := true;
when 'n' =>
nostdout := true;
when 'u' =>
unbuffer := true;
when Others =>
raise Program_Error;
end case;
end loop;
------------------------------------------------------------------------------
-- @@PLEAC@@_7.8
------------------------------------------------------------------------------
-- Ada has no "rename" built in. It can, however, call existing programs
-- to achieve the same purpose.
with Interfaces.C; use Interfaces.C;
procedure Rename_File(From, To : String) is
function system(Command : Char_Array) return Int;
pragma Import(C, system, "system");
rc : Int;
begin
rc := system(To_C("mv " & From & " " & To));
end Rename_File;
-------------------------------
Open(File => Old, Name => old_file, Mode => In_File);
Create(File => New, Name => new_file);
while not End_Of_File(Old) loop
Get_Line(File => Old, Item => Line, Last => Length);
-- process the data in Line
Put_Line(File => New, Item => Line(1..Length));
end loop;
Close(Old);
Close(New);
Rename_File(old_file, old_file & ".orig");
Rename_File(new_file, old_file);
------------------------------------------------------------------------------
-- @@PLEAC@@_10.0
------------------------------------------------------------------------------
-- Ada makes a distinction between functions and procedures.
-- Functions always return a value and never alter their parameters.
-- Procedures never return a value and may alter their parameters
procedure Hello is
begin
Put_Line("hi there!");
end Hello;
-------------------------------
Hello; -- Calling Hello with no parameters
-------------------------------
function Sum(A, B : Integer) return Integer is
begin
return A + B;
end Sum;
-------------------------------
C := Sum(X, Y); -- Calling a function
------------------------------------------------------------------------------
-- @@PLEAC@@_10.1
------------------------------------------------------------------------------
-- Ada subroutine parmameters must have one of three modes.
-- IN, OUT, IN OUT
-- IN is read-only inside the subroutine. All function parameters are IN
-- OUT is write-only inside a subroutine
-- IN OUT is read and write within the subroutine
function Hypotenuse(A, B : Float) return Float is
begin
return sqrt((A**2) + (B**2));
end Hypotenuse;
diag := Hypotenuse(3.0, 4.0); -- diag is 5.0
-------------------------------
Ada.Float_Text_Io.Put(Hypotenuse(3.0, 4.0)); -- prints 5.0E00
------------------------------------------------------------------------------
--@@PLEAC@@_10.2
------------------------------------------------------------------------------
procedure Swap(A, B : in out Integer) is
Temp := A; -- Temp is visible only within the Swap procedure
begin
A := B;
B := Temp;
end Swap;
------------------------------------------------------------------------------
-- @@PLEAC@@_10.3
------------------------------------------------------------------------------
-- Persistent private variables are declared inside a package body
package body Counter is
type Numbers is mod 100; -- will only have a value from 0 through 99
Count : Numbers := 0; -- Count is persistent across calls, and is
-- initialized to 0
function Take_Number return Integer is
Result : Integer := Integer(Count);
begin
Count := Count + 1; -- modular arithmetic. 99 + 1 => 0
return Result;
end Take_Number;
end Counter;
------------------------------------------------------------------------------
-- @@PLEAC@@_10.4
------------------------------------------------------------------------------
-- Ada provides no way to determine a function's name at run time
------------------------------------------------------------------------------
-- @@PLEAC@@_10.5
------------------------------------------------------------------------------
-- Ada parameter modes will always pass arrays by reference
-- The GNAT compiler provides a Hash as an extension, but the Ada language
-- does not define a Hash as part of its standard.
------------------------------------------------------------------------------
-- @@PLEAC@@_10.6
------------------------------------------------------------------------------
-- Ada return context is always determined at compile time.
-- There is no way to determine return context at run time.
------------------------------------------------------------------------------
-- @@PLEAC@@_10.7
------------------------------------------------------------------------------
Put(Item => Age, Width => 2);
Put(Item => Age);
Put(Width => 2, Item => Age);
Put(Age, Width => 2);
-------------------------------
function Put(Item : Integer; Width : Positive := 1) is
begin
[...]
end Put;
------------------------------------------------------------------------------
-- @@PLEAC@@_10.8
------------------------------------------------------------------------------
-- Ada functions must return exactly one value. Skipping values does not
-- occur in Ada.
------------------------------------------------------------------------------
-- @@PLEAC@@_10.9
------------------------------------------------------------------------------
-- Ada allows you to return a single item from a function.
-- That item may be of a compound type, such as an array, an array of arrays,
-- or a record.
------------------------------------------------------------------------------
-- @@PLEAC@@_10.10
------------------------------------------------------------------------------
-- There is no standard Ada failure value. Raise an exception upon failure.
------------------------------------------------------------------------------
-- @@PLEAC@@_10.11
------------------------------------------------------------------------------
-- Functions and procedures are prototyped in a package specification
-- The prototype includes the exact signature of the function or procedure
function Take_Number return Integer;
procedure Swap(A, B : in out Integer);
------------------------------------------------------------------------------
--@@PLEAC@@_10.12
------------------------------------------------------------------------------
raise Buffer_Empty_Error; -- raise an exception
-------------------------------
begin
[...]
exception
when Buffer_Empty_Exception =>
[...]
end;
-------------------------------
when Others=>
Clean_Up;
raise; -- reraise unknown error
------------------------------------------------------------------------------
-- @@PLEAC@@_10.13
------------------------------------------------------------------------------
-- Ada global variables are declared within a package specification
package Globals is
age : Natural;
end Globals;
procedure SetAge(New_Age : Natural) is
begin
age := New_Age;
end SetAge;
------------------------------------------------------------------------------
-- @@PLEAC@@_10.14
------------------------------------------------------------------------------
-- Ada does not allow redefinition of functions at run time.
-- Ada does allow functions and procedures to be overloaded.
-- Many functions or procedures can have the same name with a different list
-- of parameters, or a different return type.
type Real_Nums is array(1..100) of Float;
type Int_Nums is array(1..200) of Integer;
function Average(Nums : Real_Nums) return Float;
function Average(Nums : Real_Nums) return Integer;
function Average(Nums : Int_Nums) return Integer;
function Average(Nums : Int_Nums) return Float;
------------------------------------------------------------------------------
-- @@PLEAC@@_10.15
------------------------------------------------------------------------------
-- Undefined function and procedure calls are detected as errors by the
-- Ada compiler. No run time detection is possible.
------------------------------------------------------------------------------
-- @@PLEAC@@_10.16
------------------------------------------------------------------------------
function Outer(Num : Integer) return Integer is
function Inner(Arg : Integer) return Integer is
begin
return Arg * 19;
end Inner;
begin -- Outer
return Num + Inner(Num);
end Outer;
------------------------------------------------------------------------------
-- @@PLEAC@@_10.17
-- @@SKIP@@ Program: Sorting Your Mail
------------------------------------------------------------------------------
-- To Be Done
------------------------------------------------------------------------------
-- @@PLEAC@@_11.0
------------------------------------------------------------------------------
type Int_Ptr is access all Integer;
ref : Int_Ptr;
num : aliased Integer := 5;
ref := num'Access;
Put(Item => ref.all); -- Print the value ref refers to
ref.all := 3; -- Assign to ref's referant
-------------------------------
type Flt_Ptr is access all Float;
ref : Flt_Ptr;
pi : Float := 3.14159;
pi'Access := 4; -- Compile time error. The Access attribute cannot be used
-- on the left hand side of an assignment.
-- Also, "pi" is not defined as "aliased". This will also
-- generate a compiler error
-------------------------------
-- There is no direct relationship between arrays and references in Ada.
-- An array is a collection of like objects. An array name is NOT an
-- access or reference to the first element of the array as in C.
-------------------------------
-- Ada provides two kinds of access types, general access types and
-- pool-specific acess types. Referants for pool-specific access types
-- must always be dynamically allocated. Referants for general access
-- types may be dynamically allocated, or may refer to aliased objects
-- generated on the stack.
type Pool_Ptr is access Float; -- Pool specific access type
type Gen_Ptr is access all Float; -- General access type
------------------------------------------------------------------------------
-- @@PLEAC@@_11.1
------------------------------------------------------------------------------
type Sales is array (Integer range 1..7) of Float;
type Sales_Access is access Sales; -- Pool specific example
Weekly_Sales : Sales_Access := new Sales; -- dynamically allocate
-- the Sales array
-- and assign its reference to
-- Weekly_Sales
-------------------------------
last_index : Integer := Sales'Last;
first_index : Integer := Sales'First;
num_items : Integer := Sales'Length;
-------------------------------
-- Ada arrays are all fixed size. They cannot be enlarged after creation
-- Ada array types may be unconstrained in size, allowing the size of a
-- particular instance to be specified upon creation.
type String is array(Positive range <>) of Character;
s1 : String(1..10); -- s1 is a 10 element string
s2 : String(1..34); -- s2 is a 34 element string
s3 : String(11..20); -- s3 is a 10 element string with a
-- a starting index of 11
-------------------------------
type String_Ref is access String;
r1 : String_Ref;
r1 := new String(1..20); -- Dynamically allocate an array
Put(r1(N)); -- Print the character at index N
-------------------------------
r1(3..5) -- Array slice
-------------------------------
r1(3..5) := r1(9..11);
-------------------------------
-- Ada provides no way to make a reference to a slice
-------------------------------
for index in r1'Range loop
-- iterate through all elements in the array
-- referenced by r1
end loop;
-------------------------------
for index in s1'Range loop
-- iterate through all elements in array s1
end loop;
------------------------------------------------------------------------------
-- @@PLEAC@@_11.2
------------------------------------------------------------------------------
-- Ada provides no standard implementation of hashes
------------------------------------------------------------------------------
-- @@PLEAC@@_11.3
------------------------------------------------------------------------------
-- Ada provides no standard implemenation of hashes
------------------------------------------------------------------------------
-- @@PLEAC@@_11.4
------------------------------------------------------------------------------
-- Define an access type to a function taking two integer parameters and
-- returning a boolean
type func_ref is access function (A, B : Integer) return Boolean;
-- Define an access type to a procedure taking no parameters
type proc_ref is access procedure;
-- Define a function taking two integers and returning a boolean
function Less_Than(X, Y : Integer) return Boolean;
-- Define an instance of the func_ref access type
compare : func_ref;
compare := Less_Than'Access; -- Less than matches the signature defined in
-- the func_ref type declaration
-- Calling the function through the referenc
if compare(num1, num2) then
... -- act on the comparison
end if;
-- Define a procedure taking no parameters
procedure Print_Header;
-- Define an instance of proc_ref access type
action : proc_ref := Print_Header'Access;
-- Call the parameter-less procedure
action.all;
-------------------------------
-- Ada does not provide closures, or functions with static data
-- The same effect can be produced using Ada tasks.
package counters is
task type Counter_Maker is
entry Get_Count(Num : out Integer);
end Counter_Maker
type Counter_Ref is access Counter_Maker;
end counters;
package body counters is
task body Counter_Maker is
start : Integer := 0;
begin
loop
accept Get_Count(Num : out Integer)
do
Num := start;
end Get_Count;
start := start + 1;
end loop;
end Counter_Maker;
end counters;
counter1 : Counter_Ref := new Counter;
the_count : Integer;
for iter in 0..4 loop
counter1.Get_Count(the_count);
Put_Line(Integer'Image(the_count));
end loop;
-------------------------------
counter1 : Counter_Ref := new Counter;
counter2 : Counter_Ref := new Counter;
count1, count2 : Integer;
for iter in 0..4 loop
counter1.Get_Count(count1);
Put_Line(Integer'Image(count1));
end loop;
counter1.Get_Count(count1);
counter2.Get_Count(count2);
Put_Line(Integer'Image(count1) & " " &
Integer'Image(count2));
0
1
2
3
4
5 0
-------------------------------
function Time_Diff(Base_Time : Time) return Duration is
Now : Time := Clock;
begin
return Now - Base_Time;
end Time_Diff;
early : Time;
later : Time;
early := Clock;
delay 20.0;
later := Clock;
delay 10.0;
Put_Line("It's been " & Duration'Image(Time_Diff(early)) &
" seconds since early.");
Put_Line("It's been " & Duration'Image(Time_Diff(later)) &
" seconds since later");
-- It's been 30.007172430 seconds since early.
-- It's been 10.003749644 seconds since later.
------------------------------------------------------------------------------
-- @@PLEAC@@_11.5
------------------------------------------------------------------------------
-- Ada does not provide special syntax for obtaining reference to scalars
-- compared to vectors.
------------------------------------------------------------------------------
-- @@PLEAC@@_11.6
------------------------------------------------------------------------------
type Num_Ref is access all Integer;
type Ref_Array is array (1..10) of Num_Ref;
-------------------------------
array_of_refs : Ref_Array;
array_of_refs := (Others => null); -- Set all values to null references
for index in Ref_Array'Range loop
array_of_refs(index) := new Integer'(index);
end loop
-------------------------------
for index in Ref_Array'Range loop
Put_Line(Integer'Image(array_of_refs(index).all));
end loop;
-------------------------------
for index in Ref_Array'Range loop
array_of_refs(index).all := index * 10;
end loop;
------------------------------------------------------------------------------
-- @@PLEAC@@_11.7
------------------------------------------------------------------------------
-- @@PLEAC@@_11.15
------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-- Binary Tree Example
-------------------------------------------------------------------------------
package Binary_Trees is
type Tree is private;
procedure insert(Item : in Integer; Into : in out Tree);
procedure in_order(Item : in Tree);
procedure pre_order(Item : in Tree);
procedure post_order(Item : in Tree);
function search(Item : in Integer; From : in Tree) return boolean;
private
type node;
type Tree is access Node;
type Node is record
Value : Integer;
Left : Tree := Null;
Right : Tree := Null;
end record;
end Binary_Trees;
with Ada.Text_IO;
use Ada.Text_Io;
package body Binary_Trees is
procedure insert(Item : in Integer; Into : in out Tree) is
begin
if Into /= null then
if Into.Value > Item then
insert(Item, Into.Left);
elsif Into.Value < Item then
insert(Item, Into.Right);
end if; -- Do nothing if duplicate
else
Into := new Node;
Into.Value := Item;
end if;
end insert;
procedure in_order(Item : in Tree) is
begin
if Item = null then
return;
end if;
in_order(Item.Left);
Put(Integer'Image(Item.Value) & " ");
in_order(Item.Right);
end in_order;
procedure pre_order(Item : in Tree) is
begin
if Item = null then
return;
end if;
Put(Integer'Image(Item.Value) & " ");
pre_order(Item.Left);
pre_order(Item.Right);
end pre_order;
procedure post_order(Item : in Tree) is
begin
if Item = null then
return;
end if;
post_order(Item.Left);
post_order(Item.Right);
Put(Integer'Image(Item.Value) & " ");
end post_order;
function search(Item : Integer; From : Tree) return Boolean is
Result : Boolean;
begin
if From /= null then
if From.Value = Item then
Result := True;
elsif From.Value > Item then
Result := search(Item, From.Left);
else
Result := search(Item, From.Right);
end if;
else
Result := False;
end if;
return Result;
end search;
end Binary_Trees;
with Binary_Trees; use Binary_Trees;
with Ada.Numerics.Discrete_Random;
with Ada.Text_Io; use Ada.Text_Io;
with Ada.Integer_Text_Io; use Ada.Integer_Text_Io;
procedure Tree_Test is
package Rand_Num is new Ada.Numerics.Discrete_Random(Integer);
use Rand_Num;
Seed : Generator;
Val : Integer;
The_Tree : Tree;
begin
Reset(Seed);
for num in 1..20 loop
Val := Random(Seed);
insert(Item => Val, Into => The_Tree);
end loop;
-- now dump out the tree all three ways
Put("Pre Order: ");
pre_order(The_Tree);
New_Line;
Put("In order: ");
in_order(The_Tree);
New_Line;
Put("Post_Order: ");
post_order(The_Tree);
New_Line;
-- prompt until EOF
loop
Put("Search? ");
exit when Ada.Text_IO.End_Of_File;
Get(Val); -- read input as an integer
if search(Item => Val, From => The_Tree) then
Put_Line("Found " & Integer'Image(Val));
else
Put_Line("No " & Integer'Image(Val) & " in tree");
end if;
end loop;
end Tree_Test;
-- @@PLEAC@@_12.0
------------------------------------------------------------------------------
-- Ada packages provide both namespace and encapsulation. As such they act
-- both as perl packages and perl modules.
package Alpha is
name : String := "First";
end Alpha;
package Omega is
name : String := "Last";
end Omega;
With Ada.Text_Io; use Ada.Text_IO;
with Alpha, Omega;
with Ada.Text_Io;
procedure main is
begin
Put_Line("Alpha is " & Alpha.name & " ," &
"Omega is " & Omega.name);
end main;
----------------------
with Cards; -- Make the Cards package visible
use Cards; -- Place the Cards package within the current scope
-- Both operations happen only at compile time.
----------------------
package Cards is
type Card is private;
-- Print the value of a card
procedure Print(Item : in Card);
type Deck is private;
-- Create an initial deck (open a new deck of cards)
function Fill_Deck return Deck;
-- Print all the cards remaining in a deck
procedure Print(Item : in Deck);
-- Shuffle the deck (randomize the order of the cards in the deck)
procedure Shuffle(The_Deck : in out Deck);
-- Deal the next card from the deck
procedure Deal(The_Card : out Card; From : in out Deck);
-- Return the number of cards left in the deck
function Cards_Left(In_Deck : Deck) return Natural;
-- Deck_Empty exception raised when trying to deal from an empty deck.
Deck_Empty : Exception;
private
-- Define the face values of the cards
type Pips is (Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten,
Jack, Queen, King, Ace);
-- Define the card suits
type Suits is (Hearts, Spades, Clubs, Diamonds);
-- A card is defined by its combination of face value
-- and suit.
type Card is record
Pip : Pips;
Suit : Suits;
end record;
-- Define the number of cards in a standard deck.
subtype Deck_Index is integer range 1..52;
-- Cards in the deck are accessed through an order list.
-- The values in the order list are sorted to create a
-- shuffled deck.
type Order_List is array(Deck_Index) of Deck_Index;
-- A deck is an order list, an index into the order list
-- indicating the next card to deal, and a count of the
-- number of cards left (not yeat dealt) in the deck.
type Deck is record
This_Order : Order_List;
Deal_Next : Deck_Index := Deck_Index'First;
Num_Left : Natural := 0;
end record;
end Cards;
-------------------------
-- @@PLEAC@@_12.1
----------------------------------------------------------------------
-- Cards.ads
-- Package implementing a standard deck of playing cards
----------------------------------------------------------------------
package Cards is
type Card is private;
-- Print the value of a card
procedure Print(Item : in Card);
type Deck is private;
-- Create an initial deck (open a new deck of cards)
function Fill_Deck return Deck;
-- Print all the cards remaining in a deck
procedure Print(Item : in Deck);
-- Shuffle the deck (randomize the order of the cards in the deck)
procedure Shuffle(The_Deck : in out Deck);
-- Deal the next card from the deck
procedure Deal(The_Card : out Card; From : in out Deck);
-- Return the number of cards left in the deck
function Cards_Left(In_Deck : Deck) return Natural;
-- Deck_Empty exception raised when trying to deal from an empty deck.
Deck_Empty : Exception;
private
-- Define the face values of the cards
type Pips is (Two, Three, Four, Five, Six, Seven, Eight, Nine, Ten,
Jack, Queen, King, Ace);
-- Define the card suits
type Suits is (Hearts, Spades, Clubs, Diamonds);
-- A card is defined by its combination of face value
-- and suit.
type Card is record
Pip : Pips;
Suit : Suits;
end record;
-- Define the number of cards in a standard deck.
subtype Deck_Index is integer range 1..52;
-- Cards in the deck are accessed through an order list.
-- The values in the order list are sorted to create a
-- shuffled deck.
type Order_List is array(Deck_Index) of Deck_Index;
-- A deck is an order list, an index into the order list
-- indicating the next card to deal, and a count of the
-- number of cards left (not yeat dealt) in the deck.
type Deck is record
This_Order : Order_List;
Deal_Next : Deck_Index := Deck_Index'First;
Num_Left : Natural := 0;
end record;
end Cards;
--------------------
-- @@PLEAC@@_12.2
--------------------
-- No error trapping required in Ada, since all errors are detected
-- at compile time.
--------------------
-- @@PLEAC@@_12.3
--------------------
-- Not possible in Ada
--------------------
-- @@PLEAC@@_12.4
-------------------
-- Place the variables in the package implementation, or "body"
with Ada.Numerics.Float_Random;
use Ada.Numerics.Float_Random;
with Ada.Text_Io; use Ada.Text_Io;
package body Cards is
type Card_Deck is array(Deck_Index) of Card;
-------------
-- Internal Function: Initialize
-- Purpose: Initialize the value of the common Card_Deck
-------------
function Initialize return Card_Deck is
Result : Card_Deck;
Temp_Index : Integer := Deck_Index'First;
begin
for The_Suit in Suits loop
for The_Pip in Pips loop
Result(Temp_Index) := (The_Pip, The_Suit);
Temp_Index := Temp_Index + 1;
end loop;
end loop;
return Result;
end Initialize;
All_Decks : constant Card_Deck := Initialize;
-- private to the Cards package
----------
-- Procedure: Print
-- Purpose: Print the value of a card on standard output
----------
procedure Print(Item : in Card) is
package Pip_Io is new Ada.Text_Io.Enumeration_IO(Pips);
package Suit_Io is new Ada.Text_Io.Enumeration_Io(Suits);
begin
Pip_Io.Put(Item => Item.Pip);
Put(Item => " of ");
Suit_Io.Put(Item => Item.Suit);
New_Line;
end Print;
----------------
-- Function: Fill_Deck
-- Purpose: Create a new card deck with all cards in order
---------------
function Fill_Deck return Deck is
Result : Deck;
Temp_Index : Integer := Deck_Index'First;
begin
for Temp_Index in Deck_Index'Range loop
Result.This_Order(Temp_Index) := Temp_Index;
end loop;
Result.Num_Left := Deck_Index'Last;
return Result;
end Fill_Deck;
--------
-- Procedure: Print
-- Purpose: Print all the cards remaining in the deck
--------
procedure Print(Item : in Deck) is
begin
if Item.Num_Left > 0 then
for Temp_Index in Item.Deal_Next..Deck_Index'Last loop
Print(All_Decks(Item.This_Order(Temp_Index)));
end loop;
else
Put_Line("The deck is empty.");
end if;
end Print;
-----------
-- Procedure Swap
-- Exchange two Deck_Index values
-------------
procedure Swap(Left, Right : in out Deck_Index) is
Temp : Deck_Index := Left;
begin
Left := Right;
Right := Temp;
end Swap;
------------
-- Procedure: Shuffle
-- Purpose: Randomize the This_Order array for a deck to force
-- random access to the deck of cards
-- This algorithm is order O(n) and will work with any discrete
-- index type.
-- The Ada.Numerics.Float_Random routine is used so that the
-- random number generator is reset only once per shuffle. This
-- produces more random results than can be achieved by
-- resetting the generator for each iteration as would be needed
-- if the Ada.Numerics.Discrete_Random package had been used.
-----------
procedure Shuffle(The_Deck : in out Deck) is
use Ada.Numerics.Float_Random;
Seed : Generator;
Max_Search : Deck_Index := Deck_Index'Pred(Deck_Index'Last);
Difference : Integer;
Rand_Value : Integer;
Swap_Val : Deck_Index;
begin
Reset(Seed);
The_Deck.Deal_Next := Deck_Index'First;
The_Deck.Num_Left := Deck_Index'Last;
for Index in Deck_Index'First .. Max_Search loop
Difference := Deck_Index'Pos(Deck_Index'Last) -
Deck_Index'Pos(Index);
Rand_Value := Integer( Random(Seed) * Float(Difference)) +
Deck_Index'Pos(Index);
Swap_Val := Deck_Index'Val(Rand_Value);
Swap(The_Deck.This_Order(Index), The_Deck.This_Order(Swap_Val));
end loop;
The_Deck.Num_Left := Deck_Index'Last;
The_Deck.Deal_Next := Deck_Index'First;
end Shuffle;
procedure Deal(The_Card : out Card; From : in out Deck) is
begin
if From.Num_Left > 0 then
The_Card := All_Decks(From.This_Order(From.Deal_Next));
From.Num_Left := From.Num_Left - 1;
if From.Deal_Next < Deck_Index'Last then
From.Deal_Next := From.Deal_Next + 1;
end if;
else
raise Deck_Empty;
end if;
end Deal;
function Cards_Left(In_Deck : Deck) return Natural is
begin
return In_Deck.Num_Left;
end Cards_Left;
end Cards;
------------------
-- @@PLEAC@@_12.5
------------------
-- Not possible in Ada. All such determinations are done at compile time
------------------
-- @@PLEAC@@_13.0
------------------------------------------------------------------------------
-- Ada separates aspects of classes into packages, for encapsulation, and
-- tagged types, for type inheritance and type expansion.
-- Ada does not have constructors or destructors.
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package People is
type Person is tagged private;
procedure SetAge(Subject : out Person; Age : in Natural);
function GetAge(Subject : Person) return Natural;
procedure SetName(Subject : out Person; Name : in String);
function Get_Name(Subject : Person) return String;
private
type Person is tagged record
Age : Natural := 0;
Name : Unbounded_String := Null_Unbounded_String;
end record;
end People;
package body People is
procedure SetAge(Subject : out Person; Age : in Natural) is
begin
Subject.Age := Age;
end SetAge;
function GetAge(Subject : Person) return Natural is
begin
return Subject.Age;
end GetAge;
procedure SetName(Subject : out Person; Name : in String) is
begin
Subject.name := To_Unbounded_String(Name);
end SetName;
procedure GetName(Subject : Person) return String is
begin
return To_String(Subject.GetName);
end GetName;
end People;
-------------------------------
-- Creating an instance of a class
Charley : Person;
-- Using a class
SetName(Charley, "Charles");
SetAge(Charley, 15);
Put_Line(GetName(Charley) & " is " & Integer'Image(GetAge(Charley)) &
" years old.");
-- Charles is 15 years old.
------------------------------------------------------------------------------
-- @@PLEAC@@_13.1
------------------------------------------------------------------------------
-- Objects can be constructed on the stack, or dynamically
-- Constructing an object on the stack
Student : Person;
-- Constructing an object dynamically
type Person_Ptr is access Person;
Student_P : Person_Ptr := new Person;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.2
------------------------------------------------------------------------------
-- Only dynamically allocated objects need to be destroyed.
-- Instantiate an instance of Unchecked_Deallocation for the type
procedure free is new Ada.Unchecked_Deallocation(Person, Person_Ptr);
Student_P : Person_Ptr := new Person;
free(Student_p);
------------------------------------------------------------------------------
-- @@PLEAC@@_13.3
------------------------------------------------------------------------------
-- Public instance data can be accessed directly
-- Private instance data can only be accessed directly by subprograms defined
-- in the same package as the type definition.
package People is
type Person is tagged private;
procedure SetAge(Subject : out Person; Age : in Natural);
function GetAge(Subject : Person) return Natural;
procedure SetName(Subject : out Person; Name : in String);
function Get_Name(Subject : Person) return String;
private
type Person is tagged record
Age : Natural := 0;
Name : Unbounded_String := Null_Unbounded_String;
end record;
end People;
package body People is
procedure SetAge(Subject : out Person; Age : in Natural) is
begin
Subject.Age := Age;
end SetAge;
function GetAge(Subject : Person) return Natural is
begin
return Subject.Age;
end GetAge;
procedure SetName(Subject : out Person; Name : in String) is
begin
Subject.name := To_Unbounded_String(Name);
end SetName;
procedure GetName(Subject : Person) return String is
begin
return To_String(Subject.GetName);
end GetName;
end People;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.4
------------------------------------------------------------------------------
-- Class data is defined in the package body, and is not accessable by any
-- subprograms outside the package body.
package body Counters is
type Modular_Counter is mod 100;
Internal_Counter : Modular_Counter := 0;
--....
end Counters;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.5
------------------------------------------------------------------------------
-- Ada allows public definition of records without tags.
-- These approximate structs in C.
package Complex_Nums is
type Complex_Number is record
Real : Float := 0.0;
Imaginary : Float := 0.0;
end record;
end Complex_Nums;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.6
------------------------------------------------------------------------------
-- cloning dynamically allocated objects
P1 : new Person_Ptr;
P2 : new Person_Ptr;
P2.all := P1.all;
-- cloning stack based objects
P1 : Person;
P2 : Person := P1;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.7
-- @@PLEAC@@_13.8
------------------------------------------------------------------------------
type Person is tagged private;
type Employee is new Person with private;
type Salaried_Employee is new Employee with private;
type Person_Pointer is access Person'Class;
P : Person_Pointer;
if P in Employee then
-- P points to a member of Employee or Salaried_Employee
end if;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.9
------------------------------------------------------------------------------
package People is
type Person is tagged private;
procedure SetAge(Subject : out Person; Age : in Natural);
function GetAge(Subject : Person) return Natural;
procedure SetName(Subject : out Person; Name : in String);
function Get_Name(Subject : Person) return String;
private
type Person is tagged record
Age : Natural := 0;
Name : Unbounded_String := Null_Unbounded_String;
end record;
end People;
package body People is
procedure SetAge(Subject : out Person; Age : in Natural) is
begin
Subject.Age := Age;
end SetAge;
function GetAge(Subject : Person) return Natural is
begin
return Subject.Age;
end GetAge;
procedure SetName(Subject : out Person; Name : in String) is
begin
Subject.name := To_Unbounded_String(Name);
end SetName;
procedure GetName(Subject : Person) return String is
begin
return To_String(Subject.GetName);
end GetName;
end People;
-------------------------------
Dude : Person;
SetName(Dude, "Jason");
SetAge(Dude, 23);
-------------------------------
-- inheriting from Person
type Employee is new Person with record
Salary : Float := 0.0;
end record;
-------------------------------
emp1 : Employee;
-------------------------------
SetName(emp1, "Jason"); -- call the inherited procedures
SetAge(emp1, 23); -- to access the inherited private fields
emp1.Salary := 200.0; -- access the public salary field
Put_Line(GetName(emp1) & " is age " & Integer'Image(GetAge(emp1)) &
", the salary is " & Float'Image(emp1.Salary));
-------------------------------
-- Ada does not provide any built in tagged types
------------------------------------------------------------------------------
-- @@PLEAC@@_13.10
------------------------------------------------------------------------------
package Employees is
subtype Title_String is string(1..20);
type Employee is new Person with record
Salary : Float := 0;
Title : Title_String;
end record;
function GetName(Subject : Employee) return String;
end Employees;
package body Employees is
function GetName(Subject : Employee) return String is
begin
-- call the inherited GetName function:
return GetName(Person(Subject)) & " : " & Title;
end GetName;
end Employees;
------------------------------------------------------------------------------
-- @@PLEAC@@_13.14
------------------------------------------------------------------------------
type Nums_Array is array(Positive range 1..10) of Integer;
-- Overload the "+" operator to allow addition of integers and items of
-- type Num_Array
function "+" (left : Num_Array; Right : Integer) return Num_Array;
function "+" (left : Integer; Right : Num_Array) return Num_Array;
------------------------------------------------------------------------------