Power-Programmierung/CD1.mdf/magazine/drdobbs/1986/08/shammas.aug

Text File | 1986-08-31 | 11KB | 369 lines

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