Delphi Back to the Win32 Shootout
Back to dada's perl lab

[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
    h.add(hexStr(i),i);
  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);
    h1.add('foo_'+s,i);
  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
        h2.add(p1^.Key,p1^.Value)
      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;


uses linkedList in 'linkedList.pas';
const SIZE = 10000;
var NUM: cardinal;
    code, i, j, k: integer;
    l1,l2,l3: TLinkedList;
begin
  NUM:=1;
  if ParamCount=1 then Val(ParamStr(1),NUM,code);

  for i:=1 to NUM do begin
    l1:=TLinkedList.Create;
    l2:=TLinkedList.Create;
    l3:=TLinkedList.Create;

    for j:=1 to SIZE do
      l1.addTail(j);

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

    for j:=1 to SIZE do
      l3.addTail(l2.removeFront);

    for j:=1 to SIZE do
      l2.addTail(l3.removeTail);

    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;
    property Value: boolean read getValue;
  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;
    property Value: boolean read getValue;
  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;
const MAX_READ = 4096;

// 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;
    numRead: integer;
    inHandle,outHandle: THandle;
    filePos,i,e: cardinal;
begin
  inHandle:=GetStdHandle(STD_INPUT_HANDLE);
  outHandle:=GetStdHandle(STD_OUTPUT_HANDLE);
  setLength(buf, MAX_READ);
  numRead:=fileRead(inHandle,buf[0],MAX_READ);
  filePos:=0;
  while numRead>0 do begin
    inc(filePos,numRead);
    if integer(filePos)+MAX_READ-1>high(buf) then
      setLength(buf, (high(buf)+1)*2);

    numRead:=fileRead(inHandle,buf[filePos],MAX_READ);
  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);
    Readln(p^);
    list.Add(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
    readLn(input, num);
    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;
    numRead,i,wStart: cardinal;
    p: PHashEntry;

  procedure addWord(const s: string);
  var w: string; p: PHashEntry;
  begin
    w:=lowercase(s);
    p:=words.get(w);
    if p<>nil then
      inc(p^.Value)
    else
      words.add(w,1);
  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;
  numRead:=fileRead(handle,buf,BUF_SIZE);
  while numRead>0 do begin
    i:=1;
    if (s<>'')and(buf[1] in cWhiteSpace) then begin
      addWord(s); s:='';
    end;
    repeat
      while (buf[i] in cWhiteSpace)and(i<=numRead) do
        inc(i);
      if i>numRead then
        break; // repeat
      wStart:=i;
      repeat
        inc(i);
      until (buf[i] in cWhiteSpace);
      setString(w,PChar(addr(buf[wStart])),i-wStart);
      if s<>'' then begin
        w:=s+w; s:='';
      end;
      if i<=numRead then
        addWord(w)
      else // word exceeding buffer
        s:=w;
    until (i>numRead);
    numRead:=fileRead(handle,buf,BUF_SIZE);
  end;
  if (s<>'') then
    addWord(s);

  forSort:=TList.Create;
  forSort.Capacity:=words.Count;
  p:=words.getFirst;
  while p<>nil do begin
    forSort.Add(p);
    p:=words.getNext;
  end;

  forSort.Sort(sortFunc);

  for i:=0 to forSort.Count-1 do begin
    p:=PHashEntry(forSort.Items[i]);
    write(format('%7d'#9'%s'#13#10,[p^.Value,p^.Key]));
  end;

  words.Free; forSort.Free;
end.