+ Initial import

tests/bench/shootout/src/ackerm.pp

@@ -0,0 +1,23 @@
+{ Ackermann's Function }
+program ackermann;
+uses SysUtils;
+
+function Ack(M, N : integer) : integer;
+begin    
+    if M = 0 then Ack := N+1
+    else if N = 0 then Ack := Ack(M-1, 1)
+    else Ack := Ack(M-1, Ack(M, N-1))
+End;
+
+var NUM, a : integer;
+
+begin
+    if ParamCount = 0 then
+        NUM := 1
+    else
+        NUM := StrToInt(ParamStr(1));
+        
+    if NUM < 1 then NUM := 1;
+    a := Ack(3, NUM);
+    WriteLn( 'Ack(3,' + IntToStr(NUM) + '): ' + IntToStr(a) );
+end.

tests/bench/shootout/src/array.pp

@@ -0,0 +1,38 @@
+{ Array Access }
+
+Program ary3;
+
+uses SysUtils, Classes;
+
+var
+    n, i, k, last : longint;
+    X, Y : TList;
+begin
+    if ParamCount = 0 then
+        n := 1
+    else
+        n := StrToInt(ParamStr(1));
+        
+    if n < 1 then n := 1;
+    
+    last := n - 1;
+    X := TList.Create;
+    X.Capacity := n;
+    For i := 0 To last do
+        X.Add( Pointer(i+1) );
+    
+    Y := TList.Create;
+    Y.Capacity := n;
+    For i := 0 To last do
+        Y.Add( Pointer(0) );
+    
+    
+    For k := 0 To 999 do
+    begin
+        For i := last downto 0 do
+        begin
+            Y.Items[i] := Pointer(longint(Y.Items[i]) + longint(X.Items[i]));
+        end;
+    end;
+    Writeln (IntToStr(longint(Y.Items[0])), ' ', IntToStr(longint(Y.Items[last])));
+end.

tests/bench/shootout/src/fibo.pp

@@ -0,0 +1,25 @@
+{ Fibonacci Numbers }
+
+program fibo;
+uses SysUtils;
+
+function fib(N : integer) : longint;
+begin    
+    if N < 2 then fib := 1
+    else fib := fib(N-2) + fib(N-1);
+End;
+
+var 
+    NUM : integer;
+    f : longint;
+
+begin
+    if ParamCount = 0 then
+        NUM := 1
+    else
+        NUM := StrToInt(ParamStr(1));
+        
+    if NUM < 1 then NUM := 1;
+    f := fib(NUM);
+    WriteLn( IntToStr(f) );
+end.

tests/bench/shootout/src/hash.pp

@@ -0,0 +1,131 @@
+{ Hash (Associative Array) Access }
+{$mode objfpc}
+
+Program hash;
+
+uses SysUtils, Classes;
+
+
+type
+   THashEntryPtr = ^THashEntryRec;
+   THashEntryRec = record
+      name : string;
+      number : longint;
+      next : THashEntryPtr;
+   end;
+
+const
+   TABLE_SIZE = 100000;
+
+type THash = class
+    private
+        hashtable : array[0..TABLE_SIZE - 1] of THashEntryRec;
+        function hash(s : string) : longint;
+    public
+        constructor Create;
+        function store(name : string; number : longint; var error : longint)
+: boolean;
+        function fetch(name : string; var number : longint) : boolean;
+        function exists(name : string) : boolean;
+end;
+
+constructor THash.Create;
+var
+   i : longint;
+begin
+   for i := 0 to TABLE_SIZE - 1 do
+      hashtable[i].next := nil;
+end;
+
+
+function THash.hash(s : string) : longint;
+var
+   i, j : longint;
+begin
+    if length(s) = 0 then Result := 0
+    else
+    begin
+        j := ord(s[1]) mod TABLE_SIZE;
+        for i := 2 to length(s) do
+            j := (j shl 8 + ord(s[i])) mod TABLE_SIZE;
+        Result := j;
+    end;
+end;
+
+function THash.store(name : string; number : longint; var error : longint) :
+boolean;
+var
+   node, prev : THashEntryPtr;
+begin
+   error := 0;
+
+   prev := @hashtable[hash(name)];
+   node := prev^.next;
+   
+   while (node <> nil) and (node^.name <> name) do
+   begin
+      prev := node;
+      node := node^.next;
+   end;
+
+   if node <> nil then error := 1
+   else begin
+      new(prev^.next);
+      node := prev^.next;
+      if node = nil then error := -1
+      else begin
+         node^.name := name;
+     node^.number := number;
+     node^.next := nil;
+      end;
+   end;
+   
+   Result := error = 0;
+end;
+
+function THash.fetch(name : string; var number : longint) : boolean;
+var
+   node : THashEntryPtr;
+begin
+   node := hashtable[hash(name)].next;
+   while (node <> nil) and (node^.name <> name) do
+      node := node^.next;
+   if node <> nil then number := node^.number;
+   Result := node <> nil;
+end;
+
+function THash.exists(name : string) : boolean;
+var
+   node : THashEntryPtr;
+begin
+   node := hashtable[hash(name)].next;
+   while (node <> nil) and (node^.name <> name) do
+      node := node^.next;
+   Result := node <> nil;
+end;
+    
+
+var
+    n, i, c, err : longint;
+    X : THash;
+begin
+    if ParamCount = 0 then
+        n := 1
+    else
+        n := StrToInt(ParamStr(1));
+        
+    if n < 1 then n := 1;
+    
+    X := THash.Create();
+    
+    For i := 1 To n do
+        X.store( Format('%x', [i]), i, err );
+    
+    c := 0;
+    For i:= n downto 1 do
+    begin
+        if X.exists( IntToStr(i) ) Then Inc(c);
+    end;
+    
+    Writeln (IntToStr(c));
+end.

tests/bench/shootout/src/heapsort.pp

@@ -0,0 +1,126 @@
+{ Heapsort }
+
+program heapsort;
+uses SysUtils, Classes;
+
+const
+    IM = 139968;
+    IA =   3877;
+    IC =  29573;
+
+var 
+    ary: TList;
+    r : real;
+    rr : ^real;
+    N, i, LAST : longint;
+
+function gen_random(n : longint) : real;
+begin    
+    LAST := (LAST * IA + IC) mod IM;
+    gen_random := n * LAST / IM;
+end;
+
+procedure myheapsort(n : longint; var ra : TList);
+var    
+    rr : ^real;
+    rra : real;
+    i, j, l, ir : longint;
+begin
+    rra := 0;
+    i := 0;
+    j := 0;
+    l := n shr 1 + 1;
+    ir := n;
+    
+    while 1 = 1 do
+    begin
+        if l > 1 then begin
+            Dec(l);
+            rra := real(ra.Items[l]^);
+        end
+        else begin
+            rra := real(ra.Items[ir]^);
+
+            
+
+            GetMem(rr, SizeOf(real));
+            rr^ := real(ra.Items[1]^);
+            ra.items[ir] := rr;                        
+            
+                        
+            Dec(ir);
+            if ir = 1 then 
+            begin
+                
+
+                GetMem(rr, SizeOf(real));
+                rr^ := rra;
+                ra.items[1] := rr;
+                
+                exit;
+            end;
+        end;
+        
+        i := l;
+        j := l shl 1;
+
+        
+
+        while j <= ir do begin
+            if (j < ir) and (real(ra.items[j]^) < real(ra.items[j+1]^)) then
+Inc(j);
+            
+            
+            
+            
+            if rra < real(ra.items[j]^) then begin
+                
+
+                GetMem(rr, SizeOf(real));
+                rr^ := real(ra.items[j]^);
+                ra.items[i] := rr;
+                
+                i := j;
+                Inc(j, i);
+            end
+            else begin
+                j := ir + 1;
+            end;
+        end;
+        
+        GetMem(rr, SizeOf(real));
+        rr^ := rra;
+        ra.items[i] := rr;
+        
+    end;
+end;
+            
+begin
+    if ParamCount = 0 then
+        N := 1
+    else
+        N := StrToInt(ParamStr(1));
+    if N < 1 then N := 1;
+    LAST := 42;
+    ary := TList.Create;
+    ary.Capacity := N;
+    r := 0.0;        
+    GetMem( rr, SizeOf(real) );
+    rr^ := r;        
+    ary.Add( rr );
+    for i:= 1 to N do begin
+        r := gen_random(1);        
+        GetMem( rr, SizeOf(real) );
+        rr^ := r;        
+        
+        ary.Add( rr );
+    end;
+    for i:= 1 to N do begin
+        r := real(ary.items[i]^);
+        
+    end;
+    myheapsort(N, ary);
+    r := real(ary.items[N]^);
+    WriteLn( r:10:10 );
+    ary.Free;
+end.

tests/bench/shootout/src/hello.pp

@@ -0,0 +1,8 @@
+{ Hello World }
+
+program hello;
+uses SysUtils;
+
+begin
+    WriteLn( 'hello world' );
+end.

tests/bench/shootout/src/lists.pp

@@ -0,0 +1,104 @@
+{ List Operations }
+
+Program lists;
+
+uses SysUtils, classes;
+
+const SIZE : longint = 10000;
+
+Function test_lists : integer;
+var 
+    i, len1, len2 : longint;
+    Li1, Li2, Li3 : TList;
+    lists_equal : Integer;
+begin
+        
+    Li1 := TList.Create;
+    Li1.Capacity := SIZE;
+    For i := 0 to SIZE Do
+        Li1.Add(Pointer(i));
+    
+    
+    
+    Li2 := TList.Create;
+    Li2.Capacity := SIZE;
+    For i:= 0 to SIZE Do
+        Li2.Add(Li1.Items[i]);
+    
+    { remove each individual item from left side of Li2 and
+      append to right side of Li3 (preserving order) }
+    Li3 := TList.Create;
+    Li3.Capacity := SIZE;
+    For i := 0 to SIZE Do
+    begin
+        Li3.Add( Li2.First );
+        Li2.Remove( Li2.First );
+    end;
+    
+    
+    { remove each individual item from right side of Li3 and
+      append to right side of Li2 (reversing list) }
+    For i := 0 To SIZE Do
+    begin
+        Li2.Add( Li3.Last );
+        Li3.Count -= 1;       
+    end;
+
+    
+
+    
+    For i := 0 To (SIZE div 2) Do
+    begin
+        Li1.Exchange( i, SIZE-i );
+    end;
+    
+    
+    If longint(Li1.first) <> SIZE Then
+    begin
+        
+        test_lists := 0;
+        exit;
+    end;
+
+       
+    len1 := Li1.Count - 1;
+    len2 := Li2.Count - 1;
+    If  len1 <> len2 Then
+    begin
+        test_lists := 0;
+        exit;
+    end;
+
+    lists_equal := 1;    
+    For i := 0 To len1 Do
+    begin
+        If longint(Li1.items[i]) <> longint(Li2.items[i]) Then
+        begin
+            lists_equal := 0;            
+            break;
+        end;
+    end;
+    
+    If lists_equal = 0 Then
+    begin
+        test_lists := 0;
+    end
+    else
+        test_lists := len1;
+end;
+
+var
+    ITER, i, result: integer;
+
+begin
+    if ParamCount = 0 then
+        ITER := 1
+    else
+        ITER := StrToInt(ParamStr(1));
+        
+    if ITER < 1 then ITER := 1;
+    
+    For i := 1 To ITER Do result := test_lists();
+    Writeln (IntToStr(result));
+
+end.

tests/bench/shootout/src/matrix.pp

@@ -0,0 +1,71 @@
+{ Matrix Multiplication }
+
+program matrix;
+uses SysUtils;
+
+const
+    size = 30;
+
+type tMatrix = array[0..size, 0..size] of longint;
+
+procedure mkmatrix( rows, cols : integer; var mx : tMatrix);
+var 
+    R, C : integer;
+    count : longint;
+begin
+    Dec(rows);
+    Dec(cols);
+    count := 1;
+    for R := 0 to rows do
+    begin
+        for C := 0 to cols do
+        begin
+            mx[R, C] := count;
+            Inc(count);
+        end;
+    end;
+End;
+
+procedure mmult(rows, cols : integer; m1, m2 : tMatrix; var mm : tMatrix );
+var
+    i, j, k : integer;
+    val: longint;
+begin
+    Dec(rows);
+    Dec(cols);    
+    For i := 0 To rows do
+    begin
+        For j := 0 To cols do
+        begin
+            val := 0;
+            For k := 0 To cols do
+            begin
+                Inc(val, m1[i, k] * m2[k, j]);
+            end;
+            mm[i, j] := val;
+        end;
+    end;
+End;
+
+
+var NUM, I : integer;
+    M1, M2, MM : tMatrix;
+
+begin
+    if ParamCount = 0 then
+        NUM := 1
+    else
+        NUM := StrToInt(ParamStr(1));
+        
+    if NUM < 1 then NUM := 1;
+
+    mkmatrix(size, size, M1);
+    mkmatrix(size, size, M2);
+    
+    for I := 0 To NUM do
+    begin
+        mmult(size, size, M1, M2, MM);
+    end;
+    WriteLn( IntToStr(MM[0, 0]) + ' ' + IntToStr(MM[2, 3]) + ' ' +
+             IntToStr(MM[3, 2]) + ' ' + IntToStr(MM[4, 4]));
+end.

tests/bench/shootout/src/methcall.pp

@@ -0,0 +1,94 @@
+{ Method Calls }
+
+program methcall;
+
+
+uses SysUtils;
+
+type TToggle = class 
+    private
+        value : boolean;
+
+    public
+        property Bool : boolean read value write value;
+        procedure Activate;
+end;    
+
+type TNthToggle = class 
+    constructor Create;
+    private
+        value : boolean;
+        counter : integer;
+        cmax : integer;
+    public
+        property CountMax : integer read cmax write cmax;
+        property Bool : boolean read value write value;
+        procedure Activate;
+end;
+
+constructor TNthToggle.Create;
+begin
+    counter := 0;
+end;
+
+procedure TToggle.Activate;
+begin
+    if value = True Then
+        value := False
+    else
+        value := True;
+end;
+
+procedure TNthToggle.Activate;
+begin
+    counter := counter + 1;
+    if counter >= cmax Then begin
+        if value = True Then
+            value := False
+        Else
+            value := True;
+        counter := 0;
+    end;
+end;
+
+
+var 
+    NUM, i : longint;
+    val : boolean;
+    oToggle : TToggle;
+    onToggle : TNthToggle;
+begin
+    if ParamCount = 0 then
+        NUM := 1
+    else
+        NUM := StrToInt(ParamStr(1));
+        
+    if NUM < 1 then NUM := 1;
+
+    val := True;
+    oToggle := TToggle.Create;    
+    oToggle.Bool := val;
+    For i := 1 to NUM do
+    begin
+        oToggle.Activate;
+        val := oToggle.Bool;
+    end;
+    If val = True Then
+        WriteLn('true')
+    else
+        WriteLn('false');
+
+    val := True;
+    onToggle := TNthToggle.Create;
+    onToggle.Bool := val;
+    onToggle.CountMax := 3;
+    For i := 1 to NUM do
+    begin
+        onToggle.Activate;
+        val := onToggle.Bool;
+    end;
+    If val = True Then
+        WriteLn('true')
+    else
+        WriteLn('false');
+end.

tests/bench/shootout/src/moments.pp

@@ -0,0 +1,88 @@
+{ Statistical Moments }
+
+Program moments;
+uses SysUtils, Classes;
+
+function Power(Base : Real ; Exponent: Integer): Real;
+var i : integer;
+var pow : real;
+begin
+    pow := Base;
+    For i:= 2 To Exponent do pow := pow * Base;
+    Power := pow;
+end;
+
+function Compare(A, B : Pointer) : longint;
+begin
+    if A > B then
+        Compare := 1
+    else if A < B Then
+        Compare := -1
+    else
+        Compare := 0;
+end;
+
+
+var
+    i, N, sum, num, middle : longint;
+    list : TList;
+    median, mean, deviation, 
+    average_deviation, standard_deviation, 
+    variance, skew, kurtosis : real;
+begin
+    list := TList.Create;
+    While Not Eof(input) do
+    begin
+        Readln(input, num);
+        list.Add( Pointer(num) );
+    end;    
+    N := list.Count;
+    For i := 0 To N-1 do Inc(sum, longint(list.Items[i]));
+    mean := sum / N;
+    average_deviation := 0;
+    standard_deviation := 0;
+    variance := 0;
+    skew := 0;
+    kurtosis := 0;
+
+    For i := 0 To N-1 do
+    begin
+        deviation := longint(list.Items[i]) - mean;
+        average_deviation := average_deviation + Abs(deviation);
+        variance := variance + Power(deviation, 2);
+        skew := skew + Power(deviation, 3);
+        kurtosis := kurtosis + Power(deviation, 4);
+        
+    end;
+    average_deviation := average_deviation / N;
+    variance := variance / (N-1);
+    standard_deviation := Sqrt(variance);
+    
+
+    If variance <> 0 Then
+    begin
+        skew := skew / (N * variance * standard_deviation);
+        kurtosis := kurtosis / (N * variance * variance ) - 3.0;
+    end;
+
+    list.Sort(@Compare);
+    
+
+    middle := N Div 2;
+
+    If (N Mod 2) <> 0 Then
+        median := longint(list.Items[middle])
+    Else
+        median := (longint(list.Items[middle]) +
+longint(list.Items[middle-1])) / 2;
+
+
+    WriteLn('n:                  ', N);
+    WriteLn('median:             ', median:6:6);
+    WriteLn('mean:               ', mean:6:6);
+    WriteLn('average_deviation:  ', average_deviation:6:6);
+    WriteLn('standard_deviation: ', standard_deviation:6:6);
+    WriteLn('variance:           ', variance:6:6);
+    WriteLn('skew:               ', skew:6:6);
+    WriteLn('kurtosis:           ', kurtosis:6:6);
+end.

tests/bench/shootout/src/nestedloop.pp

@@ -0,0 +1,27 @@
+{ Nested Loops }
+
+
+
+
+program nestedloop;
+uses SysUtils;
+
+var n, a, b, c, d, e, f : integer;
+var x : longint;
+
+begin
+    if ParamCount = 0 then
+        n := 1
+    else
+        n := StrToInt(ParamStr(1));
+    if n < 1 then n := 1;
+    x := 0;
+    For a := 1 to n Do
+    For b := 1 to n Do
+    For c := 1 to n Do
+    For d := 1 to n Do
+    For e := 1 to n Do
+    For f := 1 to n Do
+    Inc(x);
+    WriteLn( IntToStr(x) );
+end.

tests/bench/shootout/src/random.pp

@@ -0,0 +1,33 @@
+{ Random Number Generator }
+
+program random;
+uses SysUtils;
+
+const
+    IM = 139968;
+    IA =   3877;
+    IC =  29573;
+
+var 
+    LAST, NUM, i : longint;
+    result : real;
+
+function gen_random(n : integer) : real;
+begin    
+    LAST := (LAST * IA + IC) mod IM;
+    gen_random := n * LAST / IM;
+end;
+
+begin
+    if ParamCount = 0 then
+        NUM := 1
+    else
+        NUM := StrToInt(ParamStr(1));
+    if NUM < 1 then NUM := 1;
+    LAST := 42;
+    for i:= 1 to NUM do
+    begin
+        result := gen_random(100);
+    end;
+    WriteLn( result:10:9 );
+end.

tests/bench/shootout/src/reversefile.pp

@@ -0,0 +1,22 @@
+{ Reverse a File }
+
+Program reversefile;
+uses SysUtils, Classes;
+
+var
+    i, N : longint;
+    list : TList;
+    line : string;
+    pline : pointer;    
+begin
+    list := TList.Create;
+    While Not Eof(input) do
+    begin
+        Readln(input, line);
+        Getmem(pline, Length(line)+1);
+        Move(line, pline^, Length(line)+1);
+        list.Add( pline );
+    end;
+    N := list.Count;
+    For i := N-1 Downto 0 do WriteLn( string(list.items[i]^) );
+end.

tests/bench/shootout/src/sieve.pp

@@ -0,0 +1,41 @@
+{ Sieve of Erathostenes }
+
+program sieve;
+uses SysUtils;
+
+var 
+    NUM, i, k, count : integer;
+    flags : array[0..8192] of integer;
+
+begin
+    if ParamCount = 0 then
+        NUM := 1
+    else
+        NUM := StrToInt(ParamStr(1));
+        
+    if NUM < 1 then NUM := 1;
+
+    while NUM > 0 do
+    begin
+        Dec(NUM);
+        count := 0;
+        for i := 0 to 8192 do
+        begin
+            flags[i] := i;
+        end;
+        for i := 2 to 8192 do
+        begin
+            if flags[i] <> -1 then
+            begin
+                k := i+i;
+                while k <= 8192 do
+                begin
+                    flags[k] := -1;
+                    Inc(k, i);
+                end;
+                Inc(count);
+            end;
+        end;
+    end;
+    WriteLn('Count: ' + IntToStr(Count));
+end.

tests/bench/shootout/src/strcat.pp

@@ -0,0 +1,20 @@
+{ String Concatenation }
+
+program strcat;
+
+uses SysUtils;
+var 
+    NUM, i : longint;
+    str : string;
+
+begin
+    if ParamCount = 0 then NUM := 1
+    else NUM := StrToInt(ParamStr(1));
+    if NUM < 1 then NUM := 1;
+
+    str := '';
+    For i := 1 To NUM Do
+        str := str + 'hello'#13;
+    WriteLn( Longint(Length(str)) );
+    WriteLn( str );    
+end.

tests/bench/shootout/src/sumcol.pp

@@ -0,0 +1,14 @@
+{ Sum a Column of Integers }
+
+program sumcol;
+
+var
+    num, tot: longint;
+begin
+    While Not Eof(input) Do
+    begin
+        ReadLn(input, num);    
+        tot := tot + num;
+    end;
+    WriteLn(tot);
+end.

tests/bench/shootout/src/wc.pp

@@ -0,0 +1,46 @@
+
+{ Count Lines/Words/Chars }
+
+program wc;
+
+
+uses SysUtils;
+
+var
+    nl, nw, nc: longint;
+    Buf: array[1..4096] of byte;
+    NumRead: Integer;
+
+    A: Integer;
+    Tmp: String;
+    TmpPos : Byte;
+    Ch: String;
+    InWord: Boolean;
+begin
+    nl := 0;
+    nc := 0;
+    nw := 0;
+    InWord := False;
+    NumRead := FileRead(StdInputHandle, Buf, 4096);
+    While NumRead > 0 Do
+    begin
+        Inc(nc, NumRead);
+        For A := 1 To NumRead Do
+        begin
+            if Buf[A] = 10 Then Inc(nl);
+            if Buf[A] = 13 Then Dec(nc);
+            if (Buf[A] = 32) Or (Buf[A] = 10) Or (Buf[A] = 13) Or (Buf[A] = 9) Then 
+                InWord := False
+            else
+            begin
+                If InWord = False Then
+                begin
+                    Inc(nw);
+                    InWord := True;
+                end;
+            end;
+        end;
+        NumRead := FileRead(StdInputHandle, Buf, 4096);
+    end;
+    WriteLn(IntToStr(nl) + ' ' + IntToStr(nw) + ' ' + IntToStr(nc));
+end.