[The Original Shootout]   [NEWS]   [FAQ]   [Methodology]   [Platform Details]   [Acknowledgements]   [Scorecard]
All Source For delphi
Ackermann's Function
```program Ackermann;

function Ack(M, N: cardinal): cardinal;
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 code: integer; NUM, a : cardinal;

begin
NUM := 1;
if ParamCount=1 then
val(ParamStr(1),NUM,Code);
a := Ack(3, NUM);
WriteLn('Ack(3,',NUM,'): ',a);
end.
```
Fibonacci Numbers
```program fibo;

function fib(N : cardinal) : cardinal;
begin
if N < 2 then fib := 1
else fib := fib(N-2) + fib(N-1);
End;

var NUM, code : integer;
begin
NUM :=1;
if ParamCount=1 then
Val(ParamStr(1),NUM,code);

WriteLn(fib(NUM));
end.

```
Hash (Associative Array) Access
```program hash1_2;

uses
simpleHash in 'simpleHash.pas';

const
cHexChars: array [0..15] of char = '0123456789abcdef';
cNullStr: PChar = '00000000';

function hexStr(i: cardinal): string;
var n: integer;
begin
if i=0 then
result:='0'
else begin
setString(result,cNullStr,8);
n:=8;
while (i>0) do begin
result[n]:=cHexChars[i and \$f];
i:=i shr 4;
dec(n);
end;
for n:=1 to 8 do
if result[n]<>'0' then begin
delete(result,1,n-1);
exit;
end;
end;
end;

var h: TStringHash; n, Count, i: cardinal; code: integer; s: string;
begin
n :=1;
if ParamCount=1 then
Val(ParamStr(1),n,code);

h:=TStringHash.Create;
for i:=1 to n do
count:=0;
for i:=1 to n do begin
str(i,s);
if h.get(s)<>nil then inc(Count);
end;
h.Destroy;

writeln(Count);
end.
```
Hashes, Part II
```program hash2_2;

uses
simpleHash in 'simpleHash.pas';

var h1,h2: TStringHash;
p1,p2: PHashEntry;
n, i: cardinal;
code: integer;
s: string;
begin
n :=1;
if ParamCount=1 then
Val(ParamStr(1),n,code);

h1:=TStringHash.Create;
for i:=1 to 10000 do begin
str(i, s);
end;

h2:=TStringHash.Create;
for i:=1 to n do begin
p1:=h1.getFirst;
while p1<>nil do begin
p2:=h2.get(p1^.Key);
if p2=nil then
else
inc(p2^.Value,p1^.Value);
p1:=h1.getNext;
end;
end;
writeLn(h1.get('foo_1')^.Value,' ',
h1.get('foo_9999')^.Value,' ',
h2.get('foo_1')^.Value,' ',
h2.get('foo_9999')^.Value);
h1.Destroy;
h2.Destroy;
end.

```
Heapsort
```program heapsort;

const
IM = 139968;
IA =   3877;
IC =  29573;

var
LAST: integer = 42;
function gen_random(n: double): double;
begin
LAST := (LAST * IA + IC) mod IM;
result := n * LAST / IM;
end;

// 1:1 translation of Java-version, error if n=1
procedure sort(n: integer; var a: array of double);
var
rra: double;
i, j, l, ir: integer;
begin
l:=(n shr 1)+1;
ir:=n;
while True do begin
if l>1 then begin
dec(l);
rra:=a[l];
end else begin
rra:=a[ir];
a[ir]:=a[1];
dec(ir);
if (ir=1) then begin
a[1]:=rra; exit;
end;
end;
i:=l;
j:=l shl 1;
while (j<=ir) do begin
if (j<ir)and(a[j]<a[j+1]) then
inc(j);
if (rra<a[j]) then begin
a[i]:=a[j];
i:=j;
inc(j,j);
end else
j:=ir+1;
end;
a[i]:=rra;
end;
end;

var NUM, code, i: integer;
ary: array of double;
begin
NUM:=1;
if ParamCount=1 then Val(ParamStr(1),NUM,code);

setLength(ary,NUM+1);
ary[0]:=0.0;
for i:=1 to NUM do
ary[i]:=gen_random(1);

sort(NUM, ary);

WriteLn(ary[NUM]:10:10);
end.

```
Hello World
```program hello;

begin
write('hello world'#13#10);
end.

```
List Operations
```program lists2;

const SIZE = 10000;
var NUM: cardinal;
code, i, j, k: integer;
begin
NUM:=1;
if ParamCount=1 then Val(ParamStr(1),NUM,code);

for i:=1 to NUM do begin

for j:=1 to SIZE do

if l1.getFirst(j) then
repeat
until not l1.getNext(j);

for j:=1 to SIZE do

for j:=1 to SIZE do

l1.reverse;

l1.getFirst(j);
if j<>SIZE then begin
writeln('l1 has invalid first element'); exit;
end;

if (l1.Count<>SIZE)or(l1.Count<>l2.Count) then begin
writeln('sizes don''t match'); exit;
end;
l1.getFirst(j); l2.getFirst(k);
repeat
if j<>k then begin
writeln('l1 and l2 not equal'); exit;
end;
until not(l1.getNext(j) and l2.getNext(k));

writeln(l1.count);

l1.Destroy; l2.Destroy; l3.Destroy;
end;
end.

```
Matrix Multiplication
```program matrix;

const
SIZE = 30;

type TMatrix = array[0..SIZE-1, 0..SIZE-1] of integer;

procedure mkmatrix( rows, cols : integer; var mx : TMatrix);
var
R, C, count : integer;
begin
Dec(rows); Dec(cols);
count:=1;
for R:=0 to rows do
for C:=0 to cols do begin
mx[R, C] := count;
Inc(count);
end;
end;

procedure mmult(rows, cols: integer; const m1, m2: TMatrix; var mm: TMatrix);
var
i, j, k, val: integer;
begin
Dec(rows); Dec(cols);
for i:=0 to rows do
for j:=0 to cols do begin
val:=0;
for k:=0 to cols do
Inc(val, m1[i,k]*m2[k,j]);
mm[i,j] := val;
end;
end;

var NUM, code, i: integer;
M1, M2, MM: TMatrix;
begin
NUM:=1;
if ParamCount=1 then Val(ParamStr(1),NUM,code);

mkmatrix(SIZE, SIZE, M1);
mkmatrix(SIZE, SIZE, M2);
for i:=0 to NUM do
mmult(size, size, M1, M2, MM);
WriteLn( MM[0, 0],' ',MM[2, 3],' ',MM[3, 2],' ',MM[4, 4]);
end.

```
Method Calls
```program methCall;

type
TToggle = class(TObject)
private
FValue : boolean;
function getValue: boolean;
public
constructor create(aValue: boolean);
function Activate: TToggle; virtual;
end;

TNthToggle = class(TToggle)
private
FCounter, FCountMax : integer;
public
constructor create(aValue: boolean; aMaxCount: integer);
function Activate: TToggle; override;
property CountMax: integer read FCountMax write FCountMax;
end;

constructor TToggle.Create(aValue: boolean);
begin
FValue:=aValue;
end;

function TToggle.Activate: TToggle;
begin
FValue:=not FValue;
result:=self;
end;

function TToggle.getValue: boolean;
begin
result:=FValue;
end;

constructor TNthToggle.Create(aValue: boolean; aMaxCount: integer);
begin
inherited create(aValue);
FCountMax:=aMaxCount;
end;

function TNthToggle.Activate: TToggle;
begin
inc(FCounter);
if FCounter>=CountMax then begin
inherited Activate;
FCounter:=0;
end;
result:=self;
end;

var NUM, code, i: integer;
value: boolean;
toggle: TToggle;
nToggle: TNthToggle;

begin
value:=false; // just to shut up the compiler
NUM :=1;
if (ParamCount=1) then Val(ParamStr(1),NUM,code);

toggle := TToggle.Create(True);
for i:=1 to NUM do
value:=toggle.Activate.Value;
toggle.Destroy;
if value then Write('true'#13#10) else Write('false'#13#10);

nToggle:=TNthToggle.Create(True,3);
for i:=1 to NUM do
value:=nToggle.Activate.Value;
nToggle.Destroy;
if value then Write('true'#13#10) else Write('false'#13#10);
end.

```
Nested Loops
```program nestedloop;

var NUM, a, b, c, d, e, f, x : Cardinal;
code: integer;
begin
NUM :=1;
if (ParamCount=1) then Val(ParamStr(1),NUM,code);

x := 0;
for a:=1 to NUM do
for b:=1 to NUM do
for c:=1 to NUM do
for d:=1 to NUM do
for e:=1 to NUM do
for f:=1 to NUM do
inc(x);
WriteLn(x);
end.

```
Object Instantiation
```program objInst;

type
TToggle = class(TObject)
private
FValue : boolean;
function getValue: boolean;
public
constructor create(aValue: boolean);
function Activate: TToggle; virtual;
end;

TNthToggle = class(TToggle)
private
FCounter, FCountMax : integer;
public
constructor create(aValue: boolean; aMaxCount: integer);
function Activate: TToggle; override;
property CountMax: integer read FCountMax write FCountMax;
end;

constructor TToggle.Create(aValue: boolean);
begin
FValue:=aValue;
end;

function TToggle.Activate: TToggle;
begin
FValue:=not FValue;
result:=self;
end;

function TToggle.getValue: boolean;
begin
result:=FValue;
end;

constructor TNthToggle.Create(aValue: boolean; aMaxCount: integer);
begin
inherited create(aValue);
FCountMax:=aMaxCount;
end;

function TNthToggle.Activate: TToggle;
begin
inc(FCounter);
if FCounter>=CountMax then begin
inherited Activate;
FCounter:=0;
end;
result:=self;
end;

var NUM, code, i: integer;
o: TToggle;
o2: TNthToggle;
begin
NUM :=1;
if (ParamCount=1) then Val(ParamStr(1),NUM,code);

o:=TToggle.Create(True);
for i:=1 to 5 do
if o.Activate.Value then
Write('true'#13#10)
else
Write('false'#13#10);
o.Destroy;
for i:=1 to NUM do begin
o:=TToggle.Create(True);
o.Destroy;
end;
WriteLn;

o2:=TNthToggle.Create(True,3);
for i:=1 to 8 do
if o2.Activate.Value then
Write('true'#13#10)
else
Write('false'#13#10);
o2.Destroy;
for i:=1 to NUM do begin
o2:=TNthToggle.Create(True,3);
o2.Destroy;
end;
WriteLn;
end.

```
Random Number Generator
```program random;

const
IM = 139968;
IA =   3877;
IC =  29573;

var
LAST: integer;

function gen_random(n: integer): double;
begin
LAST := (LAST * IA + IC) mod IM;
result := n * LAST / IM;
end;

var NUM, code, i: integer;
begin
NUM :=1;
if ParamCount=1 then
Val(ParamStr(1),NUM,code);

LAST := 42;
for i:= 1 to NUM-1 do
gen_random(100);
WriteLn(gen_random(100):10:9);
end.

```
Reverse a File
```program reversefile2;

uses Windows;

// avoids using SysUtils and its initializations
function FileRead(Handle: THandle; var Buffer; Count: LongWord): Integer;
begin
if not ReadFile(Handle, Buffer, Count, LongWord(Result), nil) then
Result := -1;
end;

function FileWrite(Handle: THandle; const Buffer; Count: LongWord): Integer;
begin
if not WriteFile(Handle, Buffer, Count, LongWord(Result), nil) then
Result := -1;
end;

var buf: array of char;
inHandle,outHandle: THandle;
filePos,i,e: cardinal;
begin
inHandle:=GetStdHandle(STD_INPUT_HANDLE);
outHandle:=GetStdHandle(STD_OUTPUT_HANDLE);
filePos:=0;
setLength(buf, (high(buf)+1)*2);

end;

e:=filePos-1;
for i:=filePos-2 downto 0 do
if buf[i]=#10 then begin
fileWrite(outHandle,buf[i+1],e-i);
e:=i;
end;
fileWrite(outHandle,buf[0],e+1);
end.
```
Sieve of Erathostenes
```program sieve;

const MAX = 8192;

var NUM, code, i, n, k, count: integer;
flags : array[0..MAX] of boolean;
begin
NUM :=1;
if ParamCount=1 then
Val(ParamStr(1),NUM,code);

for n:=1 to NUM do begin
count := 0;
fillChar(flags,sizeof(flags),True);
for i := 2 to MAX do
if flags[i] then begin
inc(Count);
k:=i+i;
while k<=MAX do begin
flags[k]:=false;
inc(k,i);
end;
end;
end;
WriteLn('Count: ',Count);
end.

```
Statistical Moments
```program moments;

uses Classes, math;

function Compare(A, B : Pointer) : integer;
begin
if PDouble(A)^>PDouble(B)^ then
Result := 1
else if PDouble(A)^<PDouble(B)^ Then
Result:=-1
else
Result:=0;
end;

var
i, N, middle : integer;
list : TList;
median, mean, deviation,
average_deviation, standard_deviation,
variance, skew, kurtosis, sum: double;
p: PDouble;
begin
list := TList.Create;
While Not Eof(input) do begin
new(p);
end;
N := list.Count;
sum:=0.0;
for i:=0 to N-1 do
sum:=sum+PDouble(list.items[i])^;

mean := sum / N;
average_deviation:=0.0;
variance:=0.0;
skew:=0.0;
kurtosis:=0.0;

for i:=0 to N-1 do begin
deviation:=PDouble(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:=PDouble(list.items[middle])^
else
median:=(PDouble(list.items[middle])^+PDouble(list.items[middle-1])^)*0.5;

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.

```
String Concatenation
```program strcat;

var NUM, code, i: integer;
str : string;
begin
NUM :=1;
if ParamCount=1 then
Val(ParamStr(1),NUM,code);

str := '';
For i := 1 To NUM Do
str := str + 'hello'#10;
WriteLn(Length(str));
end.

```
Sum a Column of Integers
```program sumcol;

var
num, tot: integer;
begin
tot:=0;
while not Eof(input) do begin
tot := tot + num;
end;
WriteLn(tot);
end.

```
Word Frequency Count
```program wordfreq;

uses
SysUtils, Classes, Windows,
simpleHash in 'simpleHash.pas';

const
cWhiteSpace = [#0..#255]-['a'..'z','A'..'Z'];
BUF_SIZE = 4096;

var handle: THandle;
buf: array[1..BUF_SIZE+1] of char;
s,w: string;
words: TStringHash;
forSort: TList;
p: PHashEntry;

var w: string; p: PHashEntry;
begin
w:=lowercase(s);
p:=words.get(w);
if p<>nil then
inc(p^.Value)
else
end;

function sortFunc(Item1, Item2: Pointer): Integer;
begin
with PHashEntry(Item1)^ do begin
if Value<PHashEntry(Item2)^.Value then
result:=1
else if Value>PHashEntry(Item2)^.Value then
result:=-1
else begin // values equal
if Key=PHashEntry(Item2)^.Key then
result:=0
else if Key<PHashEntry(Item2)^.Key then
result:=1
else
result:=-1;
end;
end;
end;

begin
handle:=GetStdHandle(STD_INPUT_HANDLE);
words:=TStringHash.Create;

s:='';
buf[BUF_SIZE+1]:=#0;
i:=1;
if (s<>'')and(buf[1] in cWhiteSpace) then begin
end;
repeat
inc(i);
break; // repeat
wStart:=i;
repeat
inc(i);
until (buf[i] in cWhiteSpace);
if s<>'' then begin
w:=s+w; s:='';
end;
else // word exceeding buffer
s:=w;
end;
if (s<>'') then

forSort:=TList.Create;
forSort.Capacity:=words.Count;
p:=words.getFirst;
while p<>nil do begin