home *** CD-ROM | disk | FTP | other *** search
/ Programmer's ROM - The Computer Language Library / programmersrom.iso / ada / piwg / a000094.ada < prev    next >
Encoding:
Text File  |  1988-05-03  |  27.8 KB  |  969 lines
  1. -- A000094.ADA   "Henessy" benchmarks
  2. --
  3. --  modified to use CPU_TIME_CLOCK rather than CALENDAR.CLOCK for PIWG
  4. --  ( Editorial note: These are unchanged by PIWG other than the the use of
  5. --    CPU time rather than wall time. These procedures are for comparison
  6. --    purposes. Many came from other languages and are used for comparing
  7. --    Ada to other languages. Most of these procedures would be considered
  8. --    poor Ada programming. The matrix multiply is also a poor numerical
  9. --    method. )
  10. --
  11. -- This is a suite of benchmarks that are relatively short, both in program
  12. -- size and execution time.  It requires no input, and prints the execution
  13. -- time for each program, using the system- dependent routine Getclock,
  14. -- below, to find out the current CPU time.  It does a rudimentary check to
  15. -- make sure each program gets the right output.  These programs were
  16. -- gathered by John Henessy and modified by Peter Nye. 
  17.  
  18. -- Ada version translated from Pascal
  19. -- 11/15/85 by Mitchell Gart, Alsys Inc.
  20.  
  21. with TEXT_IO, CPU_TIME_CLOCK, DURATION_IO;
  22.  
  23. procedure A000094 is
  24.  
  25.    -- Global variables:
  26.    TIMER: DURATION ;
  27.    XTIMES: ARRAY(1..11) OF DURATION;
  28.    SORTELEMENTS: constant := 5000;
  29.    type LISTSIZE is range 0..SORTELEMENTS;
  30.    RANDARRAY: ARRAY (LISTSIZE) OF INTEGER;
  31.    type LONG_INTEGER is range -2**30 .. 2**30 ; 
  32.    SEED: LONG_INTEGER;
  33.  
  34.    -- Shared by Bubble and Quick 
  35.    type sortarray is array (listsize) of integer;
  36.    sortlist: sortarray;
  37.    biggest, littlest: integer;
  38.    top: listsize;
  39.  
  40.  
  41.    -- global procedures 
  42.  
  43. --   Getclock was replaced by CPU_TIME_CLOCK
  44. --   function Getclock return CALENDAR.TIME renames CALENDAR.CLOCK;
  45.  
  46.  
  47.    procedure Initrand is
  48.    begin
  49.       seed := 74755;
  50.    end;
  51.  
  52.    function Rand return integer is
  53.    begin
  54.       seed := (seed * 1309 + 13849) mod 32767;
  55.       return INTEGER(SEED);
  56.    end;
  57.  
  58.  
  59.  
  60.    generic
  61.       type ELEM is private;
  62.       with function CVT(VAL: INTEGER)      return ELEM;
  63.       with function "+"(LEFT, RIGHT: ELEM) return ELEM is <>;
  64.       with function "*"(LEFT, RIGHT: ELEM) return ELEM is <>;
  65.    procedure MATRIX_MULT;
  66.  
  67.    -- Integer and real matrix multiplication, programmed with generics:
  68.  
  69.    procedure MATRIX_MULT is
  70.       rowsize: constant := 40;
  71.       type index is range 1 .. rowsize;
  72.       type matrix is array (index,index) of ELEM;
  73.       ima, imb, imr: matrix;
  74.  
  75.       procedure Initmatrix (m: out matrix) is
  76.          K: LISTSIZE;
  77.       begin
  78.          K := 0;
  79.          for I in INDEX'FIRST..INDEX'LAST loop
  80.             for J in INDEX'FIRST..INDEX'LAST loop
  81.                M(I,J) := CVT(RANDARRAY(K) mod 120 - 60);
  82.                K := K+1;
  83.             end loop;
  84.          end loop;
  85.       end INITMATRIX;
  86.    
  87.       procedure Innerproduct (
  88.                    RESULT:     out ELEM; 
  89.                    A,B:        in  MATRIX;
  90.                    ROW,COLUMN: in  INDEX ) is
  91.          -- computes the inner product of A(row, and B--,column) 
  92.          RES : ELEM := CVT(0);
  93.       begin
  94.          for I in INDEX'FIRST..INDEX'LAST loop
  95.             RES := RES + A(ROW,I)*B(I,COLUMN);
  96.          end loop;
  97.          RESULT := RES;
  98.       end INNERPRODUCT;
  99.    
  100.    begin    -- MATRIX_MULT
  101.       INITMATRIX (IMA);
  102.       INITMATRIX (IMB);
  103.       for I in INDEX'FIRST..INDEX'LAST loop
  104.          for J in INDEX'FIRST..INDEX'LAST loop
  105.             INNERPRODUCT(IMR(I,J),IMA,IMB,I,J);
  106.          end loop;
  107.       end loop;
  108.    end MATRIX_MULT;
  109.  
  110.    -- Having to specify these conversion routines is sort of a pain.
  111.    -- At least they are only called during matrix initialization,
  112.    -- not during the product loop.
  113.  
  114.    function INT_CVT(I: INTEGER) return INTEGER is
  115.    begin 
  116.       return I;
  117.    end INT_CVT;
  118.  
  119.    function FLOAT_CVT(I: INTEGER) return FLOAT is
  120.    begin 
  121.       return FLOAT(I);
  122.    end FLOAT_CVT;
  123.  
  124.    -- Here are the instantiations.  "*" and "+" are implied parameters.
  125.  
  126.    procedure Intmm is new MATRIX_MULT(INTEGER, INT_CVT);
  127.  
  128.    procedure mm is new MATRIX_MULT(FLOAT, FLOAT_CVT);
  129.  
  130.  
  131.  
  132.    procedure Puzzle is 
  133.  
  134.       -- A compute-bound program from Forest Baskett. 
  135.  
  136.       size: constant := 511;
  137.       classmax: constant := 3;
  138.       typemax: constant := 12;
  139.       d: constant := 8;
  140.  
  141.       type piececlass is range 0..classmax;
  142.       type piecetype is range 0..typemax;
  143.       type position is range 0..size;
  144.       type piecerange is range 0..13;
  145.  
  146.       piececount: array (piececlass) of piecerange;
  147.       class: array (piecetype) of piececlass;
  148.       piecemax: array (piecetype) of position;
  149.       puzzl: array (position) of boolean;
  150.       p: array (piecetype, position) of boolean;
  151.       m,n: position;
  152.       kount: integer;
  153.   
  154.       function Fit (i : piecetype; j : position) return boolean is
  155.   
  156.             k,m      :       position;
  157.   
  158.       begin
  159.          for k in 0 .. piecemax(i) loop
  160.             if p(i,k) and then puzzl(j+k) then return false; end if;
  161.          end loop;
  162.          return true;
  163.       end;
  164.   
  165.       function Place (i : piecetype; j : position) return position is
  166.       begin
  167.          for K in 0 .. PIECEMAX(I) loop
  168.             if p(i,k) then puzzl(j+k) := true; end if;
  169.          end loop;
  170.          piececount(class(i)) := piececount(class(i)) - 1;
  171.          for K in J .. SIZE loop
  172.             if not PUZZL(K) then 
  173.                return K;
  174.             end if;
  175.          end loop;
  176.          return 0;
  177.       end;
  178.   
  179.       procedure Remove (i : piecetype; j : position) is
  180.       begin
  181.          for K in 0 .. PIECEMAX(I) loop
  182.             if P(I,K) then PUZZL(J+K) := FALSE; end if;
  183.          end loop;
  184.          PIECECOUNT(CLASS(I)) := PIECECOUNT(CLASS(I)) + 1;
  185.       end REMOVE;
  186.   
  187.       function Trial (J : position) return boolean is
  188.          k : position;
  189.       begin
  190.          kount := kount + 1;
  191.          for I in PIECETYPE'FIRST..PIECETYPE'LAST loop
  192.             if PIECECOUNT(CLASS(I)) /= 0 then
  193.                if Fit (i, j) then 
  194.                   k := Place (i, j);
  195.                   if Trial(k) OR (k = 0) then 
  196.                      return TRUE;
  197.                   else 
  198.                      Remove (i, j);
  199.                   end if;
  200.                end if;
  201.             end if;
  202.          end loop;
  203.          return FALSE;
  204.       end TRIAL;
  205.   
  206.    begin    -- PUZZLE
  207.  
  208.       for m in POSITION'FIRST..POSITION'LAST loop puzzl(m) := true; end loop;
  209.       for i in 1 .. 5 loop for j in 1 .. 5 loop for k in 1 .. 5 loop
  210.          puzzl(POSITION(i+d*(j+d*k))) := false;
  211.       end loop; end loop; end loop;
  212.       for i in PIECETYPE'FIRST..PIECETYPE'LAST loop 
  213.          for m in POSITION'FIRST..POSITION'LAST loop 
  214.             p(i, m) := false;
  215.          end loop; 
  216.       end loop;
  217.       for i in 0..3 loop for j in 0 .. 1 loop for k in 0 .. 0 loop
  218.             p(0,POSITION(i+d*(j+d*k))) := true;
  219.          end loop; end loop; 
  220.       end loop;
  221.       class(0) := 0;
  222.       piecemax(0) := 3+d*1+d*d*0;
  223.       for i in 0 .. 1 loop for j in 0 .. 0 loop for k in 0 .. 3 loop
  224.          p(1,POSITION(i+d*(j+d*k))) := true;
  225.       end loop; end loop; end loop;
  226.       class(1) := 0;
  227.       piecemax(1) := 1+d*0+d*d*3;
  228.       for i in 0 .. 0 loop for j in 0 .. 3 loop for k in 0 .. 1 loop
  229.          p(2,POSITION(i+d*(j+d*k))) := true;
  230.       end loop; end loop; end loop;
  231.       class(2) := 0;
  232.       piecemax(2) := 0+d*3+d*d*1;
  233.       for i in 0 .. 1 loop for j in 0 .. 3 loop for k in 0 .. 0 loop
  234.          p(3,POSITION(i+d*(j+d*k))) := true;
  235.       end loop; end loop; end loop;
  236.       class(3) := 0;
  237.       piecemax(3) := 1+d*3+d*d*0;
  238.       for i in 0 .. 3 loop for j in 0 .. 0 loop for k in 0 .. 1 loop
  239.          p(4,POSITION(i+d*(j+d*k))) := true;
  240.       end loop; end loop; end loop;
  241.       class(4) := 0;
  242.       piecemax(4) := 3+d*0+d*d*1;
  243.       for i in 0 .. 0 loop for j in 0 .. 1 loop for k in 0 .. 3 loop
  244.          p(5,POSITION(i+d*(j+d*k))) := true;
  245.       end loop; end loop; end loop;
  246.       class(5) := 0;
  247.       piecemax(5) := 0+d*1+d*d*3;
  248.       for i in 0 .. 2 loop for j in 0 .. 0 loop for k in 0 .. 0 loop
  249.          p(6,POSITION(i+d*(j+d*k))) := true;
  250.       end loop; end loop; end loop;
  251.       class(6) := 1;
  252.       piecemax(6) := 2+d*0+d*d*0;
  253.       for i in 0 .. 0 loop for j in 0 .. 2 loop for k in 0 .. 0 loop
  254.          p(7,POSITION(i+d*(j+d*k))) := true;
  255.       end loop; end loop; end loop;
  256.       class(7) := 1;
  257.       piecemax(7) := 0+d*2+d*d*0;
  258.       for i in 0 .. 0 loop for j in 0 .. 0 loop for k in 0 .. 2 loop
  259.          p(8,POSITION(i+d*(j+d*k))) := true;
  260.       end loop; end loop; end loop;
  261.       class(8) := 1;
  262.       piecemax(8) := 0+d*0+d*d*2;
  263.       for i in 0 .. 1 loop for j in 0 .. 1 loop for k in 0 .. 0 loop
  264.          p(9,POSITION(i+d*(j+d*k))) := true;
  265.       end loop; end loop; end loop;
  266.       class(9) := 2;
  267.       piecemax(9) := 1+d*1+d*d*0;
  268.       for i in 0 .. 1 loop for j in 0 .. 0 loop for k in 0 .. 1 loop
  269.          p(10,POSITION(i+d*(j+d*k))) := true;
  270.       end loop; end loop; end loop;
  271.       class(10) := 2;
  272.       piecemax(10) := 1+d*0+d*d*1;
  273.       for i in 0 .. 0 loop for j in 0 .. 1 loop for k in 0 .. 1 loop
  274.          p(11,POSITION(i+d*(j+d*k))) := true;
  275.       end loop; end loop; end loop;
  276.       class(11) := 2;
  277.       piecemax(11) := 0+d*1+d*d*1;
  278.       for i in 0 .. 1 loop for j in 0 .. 1 loop for k in 0 .. 1 loop
  279.          p(12,POSITION(i+d*(j+d*k))) := true;
  280.       end loop; end loop; end loop;
  281.       class(12) := 3;
  282.       piecemax(12) := 1+d*1+d*d*1;
  283.       piececount(0) := 13;
  284.       piececount(1) := 3;
  285.       piececount(2) := 1;
  286.       piececount(3) := 1;
  287.       m := 1+d*(1+d*1);
  288.       kount := 0;
  289.       if Fit(0, m) then 
  290.          n := Place(0, m);
  291.       else 
  292.          TEXT_IO.PUT_LINE("Error1 in Puzzle");
  293.       end if;
  294.       if NOT Trial(n) then 
  295.          TEXT_IO.PUT_LINE("Error2 in Puzzle.");
  296.       elsif kount /= 2005 then 
  297.          TEXT_IO.PUT_LINE("Error3 in Puzzle.");
  298.       end if;
  299.    end PUZZLE;
  300.  
  301.  
  302.  
  303.    procedure TREES is 
  304.  
  305.       -- Sorts an array using treesort 
  306.  
  307.       type NODE;
  308.       type NODEPTR is access NODE;
  309.       type NODE is record
  310.            LEFT,
  311.            RIGHT: NODEPTR;
  312.            VAL:   INTEGER;
  313.       end record;
  314.   
  315.       -- tree 
  316.       TREE: NODEPTR;
  317.   
  318.       procedure INITARR is
  319.       begin
  320.          BIGGEST := 0; LITTLEST := 0;
  321.          for I in LISTSIZE'FIRST .. LISTSIZE'LAST loop
  322.             SORTLIST(I) := (RANDARRAY(I) mod 10000) - 5000;
  323.             if SORTLIST(I) > BIGGEST then 
  324.                BIGGEST := SORTLIST(I);
  325.             elsif SORTLIST(I) < LITTLEST then 
  326.                LITTLEST := SORTLIST(I);
  327.             end if;
  328.          end loop;
  329.       end INITARR;
  330.  
  331.       procedure INSERT(N: INTEGER;  T: in out NODEPTR) is
  332.          -- insert n into tree 
  333.  
  334.          procedure CreateNode(t: in out nodeptr; n: in integer) is
  335.          begin
  336.             T := new NODE;
  337.             T.LEFT := null; 
  338.             T.RIGHT := null;
  339.             T.VAL := N;
  340.          end CREATENODE;
  341.  
  342.       begin
  343.          if N>T.VAL then
  344.             if T.LEFT=NULL then 
  345.                CREATENODE(T.LEFT, N);
  346.             else 
  347.                INSERT(N, T.LEFT);
  348.             end if;
  349.          elsif N<T.VAL then
  350.             if T.RIGHT=null then 
  351.                CREATENODE(T.RIGHT,N);
  352.             else 
  353.                INSERT(N,T.RIGHT);
  354.             end if;
  355.          end if;
  356.       end INSERT;
  357.  
  358.  
  359.       function CHECKTREE(P: NODEPTR) return BOOLEAN is
  360.          -- check by inorder traversal 
  361.          RESULT: BOOLEAN;
  362.       begin
  363.          RESULT := TRUE;
  364.          if P.LEFT/=null then
  365.             if P.LEFT.VAL <= P.VAL then 
  366.                RESULT:=FALSE;
  367.             else 
  368.                RESULT := CHECKTREE(P.LEFT) and RESULT;
  369.             end if;
  370.          end if;
  371.          if P.RIGHT/=null then
  372.             if P.RIGHT.VAL >= P.VAL then 
  373.                RESULT := FALSE;
  374.             else 
  375.                RESULT := CHECKTREE(P.RIGHT) and RESULT;
  376.             end if;
  377.          end if;
  378.          return RESULT;
  379.       end CHECKTREE;
  380.  
  381.    begin    -- TREES
  382.  
  383.       INITARR;
  384.       TREE := new NODE;
  385.       TREE.LEFT := null; TREE.RIGHT := null; TREE.VAL:=SORTLIST(1);
  386.       for I in 2 .. SORTELEMENTS loop 
  387.          INSERT(SORTLIST(LISTSIZE(I)),TREE);
  388.       end loop;
  389.       if not CHECKTREE(TREE) then 
  390.          TEXT_IO.PUT(" Error in Tree.");
  391.       end if;
  392.  
  393.    end TREES;
  394.  
  395.  
  396.  
  397.    procedure Perm is 
  398.       -- Permutation program, heavily recursive, written by Denny Brown. 
  399.       type       permrange is range 0 .. 10;
  400.       permarray: array (permrange) of permrange;
  401.       pctr:      long_integer;
  402.       i:         integer;
  403.  
  404.       procedure Swap(a, b : in permrange) is
  405.          t : permrange;
  406.       begin
  407.          t := permarray(a);  
  408.          permarray(a) := permarray(b);  
  409.          permarray(b) := t;
  410.       end;
  411.  
  412.       procedure Initialize is
  413.       begin
  414.          for i in 1 .. 7 loop
  415.             permarray(permrange(i)) := permrange(i-1);
  416.          end loop;
  417.       end;
  418.  
  419.       procedure Permute(n : permrange) is
  420.       begin   
  421.          pctr := pctr + 1;
  422.          if n /= 1 then  
  423.              Permute(n-1);
  424.              for k in reverse 1..n-1 loop
  425.                 Swap(n, k);
  426.                 Permute(n-1);
  427.                 Swap(n, k);
  428.              end loop;
  429.           end if;
  430.        end permute;
  431.  
  432.     begin   -- Perm 
  433.        pctr := 0;
  434.        for i in 1 .. 5 loop
  435.           Initialize;
  436.           Permute(7);
  437.        end loop;
  438.        if pctr /= 43300 then          
  439.           TEXT_IO.PUT_LINE(" Error in Perm.");
  440.        end if;
  441.     end Perm;
  442.  
  443.  
  444.  
  445.    procedure Towers is
  446.  
  447.       -- Program to Solve the Towers of Hanoi
  448.       towersbase: constant := 2.39;
  449.       maxcells: constant := 18;
  450.       type discsizrange is range 1..maxcells;
  451.       type stackrange is range 1..3;
  452.       type cellcursor is range 0..maxcells;
  453.       type element is record
  454.          discsize:discsizrange;
  455.          next:cellcursor;
  456.       end record;
  457.    
  458.       stack: array(stackrange) of cellcursor;
  459.       cellspace: array(1..maxcells) of element;
  460.       cfreelist: cellcursor;
  461.       movesdone: integer;
  462.       -- Freelist: integer;
  463.  
  464.       procedure Error (emsg: string) is
  465.       begin
  466.          TEXT_IO.PUT("Error in Towers:  ");
  467.          TEXT_IO.PUT_LINE(EMSG);
  468.       end;
  469.  
  470.       procedure Makenull (s:stackrange) is
  471.       begin
  472.          stack(s):=0;
  473.       end;
  474.  
  475.       function Getelement return cellcursor is
  476.          RESULT: CELLCURSOR;
  477.       begin
  478.          if cfreelist>0 then
  479.             RESULT := cfreelist;
  480.             cfreelist:=cellspace(integer(cfreelist)).next;
  481.             return RESULT;
  482.          else
  483.             Error("out of space   ");
  484.          end if;
  485.       end getelement;
  486.  
  487.       procedure Push(i:discsizrange;s:stackrange) is
  488.          errorfound:boolean;
  489.          localel:cellcursor;
  490.       begin
  491.           errorfound:=false;
  492.           if stack(s) > 0 then
  493.               if cellspace(integer(stack(s))).discsize<=i then
  494.                     errorfound:=true;
  495.                     Error("disc size error");
  496.               end if;
  497.           end if;
  498.           if NOT errorfound then
  499.               localel:=Getelement;
  500.               cellspace(integer(localel)).next:=stack(s);
  501.               stack(s):=localel;
  502.               cellspace(integer(localel)).discsize:=i;
  503.           end if;
  504.       end PUSH;
  505.  
  506.       procedure Init (s:stackrange;n:discsizrange) is
  507.          discctr:discsizrange;
  508.       begin
  509.          Makenull(s);
  510.          for discctr in reverse 1..n loop
  511.             Push(discctr,s);
  512.          end loop;
  513.       end;
  514.  
  515.       function Pop (s:stackrange) return discsizrange is
  516.          temp: cellcursor;
  517.          result: discsizrange;
  518.       begin
  519.          if stack(s) > 0 then
  520.             result := cellspace(integer(stack(s))).discsize;
  521.             temp:=cellspace(integer(stack(s))).next;
  522.             cellspace(integer(stack(s))).next:=cfreelist;
  523.             cfreelist:=stack(s);
  524.             stack(s):=temp;
  525.             return result;
  526.          else
  527.              Error("nothing to pop ");
  528.          end if;
  529.       end pop;
  530.  
  531.       procedure Move (s1,s2:stackrange) is
  532.       begin
  533.          Push(Pop(s1),s2);
  534.          movesdone:=movesdone+1;
  535.       end;
  536.  
  537.       procedure Tower(i,j,k:integer) is
  538.          other:integer;
  539.       begin
  540.          if k=1 then
  541.             Move(stackrange(i),stackrange(j));
  542.          else
  543.             other:=6-i-j;
  544.             Tower(i,other,k-1);
  545.             Move(stackrange(i),stackrange(j));
  546.             Tower(other,j,k-1);
  547.          end if;
  548.       end tower;
  549.  
  550.  
  551.    begin -- Towers 
  552.       for I in 1..MAXCELLS loop
  553.          cellspace(integer(I)).NEXT := cellcursor(I - 1);
  554.       end loop;
  555.       cfreelist:=maxcells;
  556.       Init(1,14);
  557.       Makenull(2);
  558.       Makenull(3);
  559.       movesdone:=0;
  560.       Tower(1,2,14);
  561.       if movesdone /= 16383 then
  562.           TEXT_IO.PUT_LINE("Error in Towers.");
  563.       end if;
  564.    end Towers;
  565.  
  566.  
  567.  
  568.    procedure Queens is 
  569.  
  570.       -- The eight queens problem, solved 50 times. 
  571.  
  572.       i: integer;
  573.  
  574.       procedure Doit is
  575.  
  576.          subtype doubleboard is integer range   2..16;
  577.          subtype doublenorm  is integer range   -7..7;
  578.          subtype boardrange  is integer range   1..8;
  579.          type aarray is array (boardrange) of boolean;
  580.          type barray is array (doubleboard) of boolean;
  581.          type carray is array (doublenorm) of boolean;
  582.          type xarray is array (boardrange) of boardrange;
  583.  
  584.          i: integer;
  585.          q: boolean;
  586.          a: aarray;
  587.          b: barray;
  588.          c: carray;
  589.          x: xarray;
  590.  
  591.          procedure Try (
  592.             i : in integer; 
  593.             q : in out boolean; 
  594.             a : in out barray;
  595.             b : in out aarray) is
  596.  
  597.             j :   integer;
  598.  
  599.          begin
  600.             j := 0;
  601.             q := false;
  602.             while (not Q) and (J /= 8) loop
  603.                j := j + 1;
  604.                q := false;
  605.                if B(J) and A(I+J) and C(I-J) then
  606.                   x(i) := j;
  607.                   b(j) := false;
  608.                   a(i+j) := false;
  609.                   c(i-j) := false;
  610.                   if i < 8 then
  611.                      Try(i+1,q,a,b);
  612.                      if NOT q then
  613.                         b(j) := true;
  614.                         a(i+j) := true;
  615.                         c(i-j) := true;
  616.                      end if;
  617.                   else 
  618.                      q := true;
  619.                   end if;
  620.                end if;
  621.             end loop;
  622.          end TRY;
  623.  
  624.       begin    -- Doit
  625.          i := 0 - 7;
  626.          while I <= 16 loop
  627.             if (I >= 1) and (I <= 8) then A(I) := TRUE; end if;
  628.             if i >= 2 then B(I) := TRUE; end if;
  629.             if i <= 7 then c(i) := true; end if;
  630.             i := i + 1;
  631.          end loop;
  632.  
  633.          Try(1, q, b, a);
  634.          if not Q then
  635.             TEXT_IO.PUT_LINE(" Error in Queens.");
  636.          end if;
  637.       end DOIT;
  638.  
  639.    begin    -- Queens
  640.       for i in 1 .. 50 loop
  641.          Doit;
  642.       end loop;
  643.    end QUEENS;
  644.  
  645.  
  646.  
  647.    procedure Quick is 
  648.  
  649.       -- Sorts an array using quicksort 
  650.  
  651.       procedure INITARR is
  652.       begin
  653.          BIGGEST := -6500; LITTLEST := 6500;
  654.          for I in 1 .. SORTELEMENTS loop
  655.             SORTLIST(LISTSIZE(I)) := (RANDARRAY(LISTSIZE(I)) mod 10000) - 5000;
  656.             if SORTLIST(LISTSIZE(I)) > BIGGEST then 
  657.                BIGGEST := SORTLIST(LISTSIZE(I));
  658.             elsif SORTLIST(LISTSIZE(I)) < LITTLEST then 
  659.                LITTLEST := SORTLIST(LISTSIZE(I));
  660.             end if;
  661.          end loop;
  662.       end INITARR;
  663.  
  664.       procedure QUICKSORT(A: in out SORTARRAY; L,R: LISTSIZE) is
  665.       -- quicksort the array A from start to finish 
  666.          I,J: INTEGER;
  667.          X,W: INTEGER;
  668.       begin
  669.          I:=INTEGER(L); J:=INTEGER(R);
  670.          X:=A((L+R)/2);
  671.          loop
  672.             while A(LISTSIZE(I))<X loop I := I+1; end loop;
  673.             while X<A(LISTSIZE(J)) loop J := J-1; end loop;
  674.             if I<=J then 
  675.                W := A(LISTSIZE(I));
  676.                A(LISTSIZE(I)) := A(LISTSIZE(J));
  677.                A(LISTSIZE(J)) := W;
  678.                I := i+1;    
  679.                J:= J-1;
  680.             end if;
  681.             exit when I > J;
  682.          end loop;
  683.          if L <LISTSIZE(J) then QUICKSORT(A,L,LISTSIZE(J)); end if;
  684.          if LISTSIZE(I)<R then QUICKSORT(A,LISTSIZE(I),R); end if;
  685.       end QUICKSORT;
  686.  
  687.    begin    -- QUICK
  688.       INITARR;
  689.       QUICKSORT(SORTLIST, 1, SORTELEMENTS);
  690.       if (SORTLIST(1) /= LITTLEST) or (SORTLIST(SORTELEMENTS) /= BIGGEST) then
  691.          TEXT_IO.PUT(" Error in Quick.");
  692.       end if;
  693.    end QUICK;
  694.  
  695.  
  696.  
  697.  
  698.    procedure Bubble is 
  699.  
  700.       -- Sorts an array using bubblesort 
  701.  
  702.       J:      INTEGER;
  703.       I, TOP: LISTSIZE;
  704.       LIMIT:  constant LISTSIZE := SORTELEMENTS/10;
  705.  
  706.       procedure INITARR is
  707.          I: LISTSIZE;
  708.       begin
  709.          BIGGEST := 0; LITTLEST := 0;
  710.          for I in 1 .. LISTSIZE'(SORTELEMENTS) loop
  711.             SORTLIST(I) := (RANDARRAY(I) mod 10000) - 5000;
  712.             if SORTLIST(I) > BIGGEST then 
  713.                BIGGEST := SORTLIST(I);
  714.             elsif SORTLIST(I) < LITTLEST then 
  715.                LITTLEST := SORTLIST(I);
  716.             end if;
  717.          end loop;
  718.       end INITARR;
  719.  
  720.    begin    -- BUBBLE
  721.       INITARR;
  722.       TOP := LIMIT;
  723.       while TOP>1 loop
  724.          I:=1;
  725.          while I<TOP loop 
  726.             if SORTLIST(I) > SORTLIST(I+1) then 
  727.                J := SORTLIST(I);
  728.                SORTLIST(I) := SORTLIST(I+1);
  729.                SORTLIST(I+1) := J;
  730.             end if;
  731.             I:=I+1;
  732.         end loop;
  733.         TOP:=TOP-1;
  734.       end loop;
  735.       for I in 2 .. LIMIT loop
  736.          if (SORTLIST(I-1) > SORTLIST(I)) then
  737.             TEXT_IO.PUT("Error3 in Bubble.");
  738.          end if;
  739.       end loop;
  740.    end BUBBLE;
  741.  
  742.  
  743.  
  744.    procedure OSCAR is 
  745.  
  746.       -- fft 
  747.  
  748.       FFTSIZE: constant := 256 ;
  749.       FFTSIZE2: constant := 129  ;
  750.  
  751.       type COMPLEX is record  
  752.          rp,
  753.          ip: FLOAT;
  754.       end record;
  755.       type CARRAY is array (1..FFTSIZE) of COMPLEX ;
  756.       type C2ARRAY is array (1..FFTSIZE2) of COMPLEX ;
  757.  
  758.       Z, W   : CARRAY ;
  759.       E      : C2ARRAY ;
  760.       ZR, ZI : FLOAT;
  761.  
  762.       function COS (X: FLOAT) return FLOAT is
  763.          -- computes cos of x (x in radians) by an expansion 
  764.          type T is range 2..10;
  765.          I: T;
  766.          RESULT,POWER: FLOAT;
  767.          FACTOR: LONG_INTEGER;
  768.       begin
  769.          RESULT := 1.0; FACTOR := 1;  POWER := X;
  770.          for I in 2 .. 10 loop 
  771.             FACTOR := FACTOR * LONG_INTEGER(I);  POWER := POWER*X;
  772.             if (I mod 2) = 0 then  
  773.                if (i mod 4) = 0 then 
  774.                   result := result + power/FLOAT(FACTOR);
  775.                else 
  776.                   result := result - power/FLOAT(FACTOR);
  777.                end if;
  778.             end if;
  779.          end loop;
  780.          return RESULT;
  781.       end;
  782.  
  783.       function MIN0( ARG1, ARG2 : INTEGER) return INTEGER is
  784.       begin
  785.          if ARG1 < ARG2 then
  786.             return ARG1;
  787.          else
  788.             return ARG2;
  789.          end if;
  790.       end MIN0;
  791.   
  792.       procedure UNIFORM11( IY:  in out LONG_INTEGER;
  793.                            YFL: out    FLOAT) is
  794.       begin
  795.          IY := (4855*IY + 1731) mod 8192;
  796.          YFL := FLOAT(IY)/8192.0;
  797.       end UNIFORM11;
  798.  
  799.       procedure EXPTAB(N: INTEGER;
  800.                        E: in out C2ARRAY) is
  801.  
  802.          H: array (1..25) of FLOAT ;
  803.          I, J, K, L, M : INTEGER;
  804.          THETA, DIVISOR : FLOAT;
  805.  
  806.       begin     -- exptab 
  807.          THETA := 3.1415926536;
  808.          DIVISOR := 4.0;
  809.          for I  in 1 .. 25 loop
  810.             H(I) := 1.0/(2.0*COS( THETA/DIVISOR ));
  811.             DIVISOR := DIVISOR + DIVISOR;
  812.          end loop;
  813.     
  814.          M := N / 2 ;
  815.          L := M / 2 ;
  816.          J := 1 ;
  817.          E(1).RP := 1.0 ;
  818.          E(1).IP := 0.0;
  819.          E(L+1).RP := 0.0;
  820.          E(L+1).IP := 1.0 ;
  821.          E(M+1).RP := -1.0 ;
  822.          E(M+1).IP := 0.0 ;
  823.     
  824.          loop
  825.             I := L / 2 ;
  826.             K := I ;
  827.     
  828.             loop
  829.                E(K+1).RP := H(J)*(E(K+I+1).RP+E(K-I+1).RP) ;
  830.                E(K+1).IP := H(J)*(E(K+I+1).IP+E(K-I+1).IP) ;
  831.                K := K+L ;
  832.                exit when K > M ;
  833.             end loop;
  834.     
  835.             J := MIN0( J+1, 25);
  836.             L := I ;
  837.             exit when L <= 1 ;
  838.          end loop;
  839.     
  840.       end EXPTAB;
  841.  
  842.       procedure FFT( N:      in     INTEGER ;
  843.                      Z, W:   in out CARRAY ;
  844.                      E:      in     C2ARRAY ;
  845.                      SQRINV: in     FLOAT) is
  846.  
  847.          I, J, K, L, M, INDEX: INTEGER ;
  848.  
  849.       begin
  850.          m := n / 2 ;
  851.          l := 1 ;
  852.  
  853.          loop
  854.             k := 0 ;
  855.             j := l ;
  856.             i := 1 ;
  857.  
  858.             loop
  859.  
  860.                loop
  861.                   W(I+K).RP := Z(I).RP+Z(M+I).RP ;
  862.                   W(I+K).IP := Z(I).IP+Z(M+I).IP ;
  863.                   W(I+J).RP := E(K+1).RP*(Z(I).RP-Z(I+M).RP)
  864.                         -E(K+1).IP*(Z(I).IP-Z(I+M).IP) ;
  865.                   W(I+J).IP := E(K+1).RP*(Z(I).IP-Z(I+M).IP)
  866.                         +E(K+1).IP*(Z(I).RP-Z(I+M).RP) ;
  867.                   I := I+1 ;
  868.                   exit when I > J ;
  869.                end loop;
  870.  
  871.                K := J ;
  872.                J := K+L ;
  873.                exit when J > M ;
  874.             end loop;
  875.  
  876.             -- Z := W; 
  877.             INDEX := 1;
  878.             loop
  879.                Z(INDEX) := W(INDEX);
  880.                INDEX := INDEX+1;
  881.                exit when INDEX > N;
  882.             end loop;
  883.             L := L+L ;
  884.             exit when l > m ;
  885.          end loop;
  886.  
  887.          for I in 1 .. N loop
  888.             Z(I).RP := SQRINV*Z(I).RP ;
  889.             Z(I).IP := -SQRINV*Z(I).IP;
  890.          end loop;
  891.       end FFT;
  892.  
  893.    begin     -- oscar 
  894.  
  895.       EXPTAB(FFTSIZE,E) ;
  896.       SEED := 5767 ;
  897.       for I in 1 .. FFTSIZE loop
  898.          UNIFORM11( SEED, ZR );
  899.          UNIFORM11( SEED, ZI );
  900.          Z(I).RP := 20.0*ZR - 10.0;
  901.          Z(I).IP := 20.0*ZI - 10.0;
  902.       end loop;
  903.  
  904.       for I in 1 .. 20 loop 
  905.          FFT(FFTSIZE,Z,W,E,0.0625) ;
  906.          -- Printcomplex( 6, 99, z, 1, 256, 17 ); 
  907.       end loop;
  908.  
  909.    end OSCAR;
  910.  
  911.  
  912.  
  913.    procedure ackerman is
  914.       -- Ackerman function Ack(3,6) run 10 times:
  915.       x : integer;
  916.       function ack (m, n: integer) return integer is
  917.       begin
  918.          if m = 0 then
  919.             return n + 1;
  920.          elsif n = 0 then
  921.             return ack (m - 1, 1);
  922.          else 
  923.             return ack (m - 1, ack (m, n - 1));
  924.          end if;
  925.       end;
  926.    begin
  927.       for i in 1 .. 10 loop
  928.          x := ack (3, 6);
  929.       end loop;
  930.    end ackerman;
  931.  
  932.  
  933.  
  934. begin        -- BENCH  A00094 
  935.    INITRAND;   
  936.    for I in 1..SORTELEMENTS loop      
  937.       RANDARRAY(LISTSIZE(I)) := RAND;   
  938.    end loop;   
  939.    TEXT_IO.PUT_LINE("A000094");
  940.    TEXT_IO.PUT("   Perm");timer := CPU_TIME_CLOCK;
  941.    Perm;   xtimes(1) := CPU_TIME_CLOCK-timer;
  942.    TEXT_IO.PUT(" Towers");timer := CPU_TIME_CLOCK;
  943.    Towers; xtimes(2) := CPU_TIME_CLOCK-timer;   
  944.    TEXT_IO.PUT(" Queens");timer := CPU_TIME_CLOCK;
  945.    Queens; xtimes(3) := CPU_TIME_CLOCK-timer;   
  946.    TEXT_IO.PUT("  Intmm");timer := CPU_TIME_CLOCK;
  947.    Intmm;  xtimes(4) := CPU_TIME_CLOCK-timer;
  948.    TEXT_IO.PUT("     Mm");timer := CPU_TIME_CLOCK;
  949.    Mm;     xtimes(5) := CPU_TIME_CLOCK-timer;   
  950.    TEXT_IO.PUT(" Puzzle");timer := CPU_TIME_CLOCK;
  951.    Puzzle; xtimes(6) := CPU_TIME_CLOCK-timer;   
  952.    TEXT_IO.PUT("  Quick");timer := CPU_TIME_CLOCK;
  953.    Quick;  xtimes(7) := CPU_TIME_CLOCK-timer;
  954.    TEXT_IO.PUT(" Bubble");timer := CPU_TIME_CLOCK;
  955.    Bubble; xtimes(8) := CPU_TIME_CLOCK-timer;   
  956.    TEXT_IO.PUT("   Tree");timer := CPU_TIME_CLOCK;
  957.    Trees;  xtimes(9) := CPU_TIME_CLOCK-timer;   
  958.    TEXT_IO.PUT("    FFT");timer := CPU_TIME_CLOCK;
  959.    Oscar;  xtimes(10):= CPU_TIME_CLOCK-timer;   
  960.    TEXT_IO.PUT("    Ack");timer := CPU_TIME_CLOCK;
  961.    Ackerman;xtimes(11):= CPU_TIME_CLOCK-timer;   
  962.    TEXT_IO.NEW_LINE;
  963.    for I in 1..11 loop      
  964.       DURATION_IO.PUT(XTIMES(I), FORE=>4, AFT=>2, EXP=>0);
  965.    end loop;   
  966.    TEXT_IO.NEW_LINE;
  967.  
  968. end A000094;
  969.