Category : Files from Magazines
Archive   : DDJ8608.ZIP
Filename : SHAMMAS.AUG

-----------------------------------------------------------------
Listing 1. Ada procedure to swap two integers.


procedure Swap(First, Second : in out integer) is

Temporary : integer;

begin
Temporary := First;
First := Second;
Second := Temporary;
end Swap;


Listing 2. Generic Ada procedure to swap two scalars.


generic
-- Declare generic types here
type Object is private;
-- List heading for generic routines here
procedure Swap(First, Second : in out Object);

-- Full definition of procedures is below
procedure Swap(First, Second : in out Object) is

Temporary : Object;

begin
Temporary := First;
First := Second;
Second := Temporary;
end Swap;




Listing 3. Generic Ada procedure to return the next element in a circular
list.

generic
type Circular_Item is (<>);
function Fetch_Next_In_Circular_List(Member : Circular_Item)
return Circular_Item;

-- Declare the generic function body
function Fetch_Next_In_Circular_List(Member : Circular_Item)
return Circular_Item is

begin
-- use predefined LAST attribute
if Member = Circular_Item'LAST
then -- use predefined FIRST attribute
return Circular_Item'FIRST;
else -- use predefined SUCCesive attribute
return Circular_Item'SUCC(Member);
end if;
end Fetch_Next_In_Circular_List;


-- Examples for generic instantiation are
-- type Day is (MON, TUE, WED, THU, FRI, SAT, SUN);
-- function NextDay is new Fetch_Next_In_Circular_List(Day);
-- NextDay(TUE) returns WED
-- NextDay(SUN) returns MON

-- subtype Hours is integer 0..24;
-- function NextTime is new Fetch_Next_In_Circular_List(Hours);
-- NextTime(4) returns 5
-- NextTime(24) returns 0


Listing 4. Generic Ada function that scans an array and returns the largest
value found.

generic
type Index_Range is range <>;
type Member is range <>;
type List is array (Index_Range) of Member;
funtion Largest(L : List) return Member;

funtion Largest(L : List) return Member is

-- Initilaize Big to lowest value
Big : Member := Member'FIRST;

begin
for i in Index_Range loop
if Big < L(i) then Big := L(i); end if;
end loop;
return Big;
end Largest;


Listing 5. Generic Ada function to return the average of a floating
point typed array.

generic
type Index_Range is range <>;
type Element is digits <>;
type List is array (Index_Range) of Element;
function Average(X : List) return Element;

function Average(X : List) return Element is

Sum : Element := 0.0; -- Initialize summation

begin
for i in Index_Range loop
Sum := Sum + X(i);
end loop;
return (Sum / FLOAT(Index_Range));
end Average;


Listing 6. Generic Ada procedure to solve the mathematical root of a
function.

generic
type Floating is digits <>;
-- declaring a subprogram parameter
-- the "with" keyword distinguishes it from other
-- declared generic routines.
with function F_of_X(X : Floating) return Floating;
procedure Root(Guess : in out Floating; Accuracy : in Floating;
Iter_Max : in INTEGER; Converge : out BOOLEAN);

procedure Root(Guess : in out Floating; Accuracy : in Floating;
Iter_Max : in INTEGER; Converge : out BOOLEAN) is

Increment, Diff : Floating;
Iter : INTEGER := 0;

begin
Converge := true;
loop
if abs(Guess) > 1.0
then Increment := 0.01 * Guess;
else Increment := 0.01;
end if;
Diff := 2.0 * Increment * F_of_X(Guess) /
(F_of_X(Guess + Increment) -
F_of_X(Guess - Increment));
Guess := Guess - Diff;
Iter := Iter + 1;
if Iter > Iter_Max then Converge := false; end if;
if (abs(Diff) < Accuracy) or (not Converge)
then exit;
end if;
end loop;
end Root;



Listing 7. Generic Shell sort procedure in Ada.

generic
type Range_Index is (<>);
type Data is private;
type List is array (Range_Index range <>) of Data;
-- declare generic function/operator
with function ">"(A,B : Data) return BOOLEAN;
procedure Shell_Sort(L : in out List; Num : INTEGER);

procedure Shell_Sort(L : in out List; Num : INTEGER) is

Offset, I, K : INTEGER;
Tempo : Data;
In_Order : BOOLEAN;

begin
Offset := Num;
while Offset > 1 loop
Offset := Offset / 2;
loop
In_Order := true;
K := Num - Offset;
for J in 1..K loop
I := J + Offset;
if L(J) > L(I) -- Using the ">" operator
then In_Order := false;
Tempo := L(I);
L(I) := L(J);
L(J) := Tempo;
end if;
end loop;
if In_Order then exit; end if;
end loop; -- open loop
end loop; -- while loop
end Shell_Sort;




Listing 8. Generic Modula-2 function to search for a specific value in an
integer/cardinal array.


PROCEDURE LinearSearch(VAR Element : ARRAY OF WORD; (* input *)
SearchValue : INTEGER; (* input *)
VAR Index : CARDINAL (* output *)
) : BOOLEAN;

VAR Found : BOOLEAN;
hi : CARDINAL;

BEGIN
Index ;= 0; hi := HIGH(Element); Found := FALSE;
WHILE (Index <= hi) AND (NOT Found) DO
(* Logical expression tested converts *)
(* array element into an integer type *)
IF SearchValue = INTEGER(Element[Index])
THEN Found := TRUE
ELSE INC(Index)
END; (* IF *)
END; (* WHILE *)
RETURN Found
END LinearSearch;



Listing 9. Generic Modula-2 Shell sort procedure.



procedure ShellSort(VAR L : ARRAY OF WORD; (* in/out *)
Sample1,
Sample2 : ARRAY OF WORD; (* input *)
Num : CARDINAL; (* input *)
IsGreater : UserDefinedProc); (* input *)

VAR Offset, I, K, DataSize : CARDINAL;
In_Order : BOOLEAN;


PROCEDURE FetchItem(Item_Num : CARDINAL; (* input *)
VAR Item : ARRAY OF WORD); (* output *)
(* Procedure copies an element from main array in Item *)

VAR Count : CARDINAL;

BEGIN
FOR Count := 0 TO DataSize - 1 DO
Item[Count] := L[Count + Item_Num * DataSize]
END;
END FetchItem;


PROCEDURE PutItem(Item_Num : CARDINAL; (* input *)
VAR Item : ARRAY OF WORD); (* output *)
(* Procedure copies an element to main array *)

VAR Count : CARDINAL;

BEGIN
FOR Count := 0 TO DataSize - 1 DO
L[Count + Item_Num * DataSize] := Item[Count]
END;
END PutItem;


BEGIN (* --------------- Shell Sort -------------------*)
DataSize := HIGH(Sample1) + 1;
Offset := Num;
WHILE Offset > 1 DO
Offset := Offset DIV 2;
REPEAT
In_Order := TRUE;
K := Num - 1 - Offset;
FOR J := 0 TO K DO
I := J + Offset;
FetchItem(I,Sample1);
FetchItem(J,Sample2);
(* Logical expression employs *)
(* user-supplied logical function *)
IF IsGtreater(Sample1,Sample2)
THEN In_Order := FALSE;
(* Swap items *)
PutItem(J, Sample1);
PutItem(I, Sample2);
END; (* IF *)
END; (* FOR *)
UNTIL In_Order;
END; (* WHILE *)
END Shell_Sort;



Listing 10. Modula-2 function compares "Frequency" fields.


PROCEDURE GreaterFreq(Field1, Field2 : ARRAY OF WORD) : BOOLEAN;

VAR Ptr1, Ptr2 : POINTER TO NameUse; (* record type defined *)
(* elsewhere in program *)
BEGIN
(* Get address of records *)
RecordPointer1 := ADR(Field1);
RecordPointer2 := ADR(Field2);
RETURN RecordPointer1^.Frequency > RecordPointer2^.Frequency
END GreaterFreq;


Listing 11. Iterator example. Professional Pascal program compares a
list of names with a list of keys and report any matches found.


program Pick_Data;

const MAX_NAME = 1000;
MAX_KEY = 50;

type Name_type = String(80);
Name_Array = array [1..MAX_NAME] of Name_type;
Key_Array = array [1..MAX_KEY] of Name_type;
Count = array [1..MAX_KEY] of Integer;

var K : Integer;
Names : Name_Array;
Keys : Key_Array;
Key_Count : Count;
Num_Name, Num_Key : Integer;
Name_File, Key_File : Text;


iterator Select(Num_Name, Num_Key) :
(Key_Index, Name_Index : Integer);
var I, J : Integer;
begin
(* Loop counter are automatic in Prof. Pascal *)
for I := 1 to Num_Key do
for J := 1 to Num_Name do
if Keys[J] = Names[I]
then begin
Key_Count[J] := Key_Count[J] + 1;
Yield(J,I)
end
end;

begin
Reset(Name_File,'NAMES.TXT'); Num_Name := 0;
Reset(Key_File,'KEYS.TXT'); Num_Key := 0;
(* Read names from name file *)
while not EOF(Name_File) do begin
Num_Name := Num_Name + 1;
Readln(Name_File,Names[Num_Name]);
end;
Close(Name_File);
(* Read keys from name file *)
while not EOF(Key_File) do begin
Num_Key := Num_Key + 1;
Key_Count[Num_Key] := 0;
Readln(Key_File,Keys[Num_Key]);
end;
Close(Key_File);
(* Loop that finds and displays matching keys and names *)
for Key_Index, Name_Index in Select(Num_Name, Num_Key) do
Writeln(Keys[Key_Index,'is key # ",Key_Index,
' matches name # ',Name_Index);

(* Loop to display name matching frequency *)
for K := 1 to Num_Key do
Writeln('Key # ',K,' has found ',Key_Count,' matched names');

[END]