Virtual Pascal Back to the Win32 Shootout Back to dada's perl lab

[The Original Shootout]   [NEWS]   [FAQ]   [Methodology]   [Platform Details]   [Acknowledgements]   [Scorecard]
All Source For vpascal
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.
```
Array Access
```Program ary3;

uses SysUtils, Classes;

var
n, i, k, last : integer;
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

Y := TList.Create;
Y.Capacity := n;
For i := 0 To last do

For k := 0 To 999 do
begin
For i := last downto 0 do
begin
Y.Items[i] := Pointer(Integer(Y.Items[i]) + Integer(X.Items[i]));
end;
end;
Writeln (IntToStr(Integer(Y.Items[0])), ' ', IntToStr(Integer(Y.Items[last])));
end.
```
Count Lines/Words/Chars
```program wc;

uses SysUtils, Windows;

var
StdInputHandle: longint;

nl, nw, nc: longint;
Buf: array[1..4096] of byte;

A: Integer;
Tmp: String;
TmpPos : Byte;
Ch: String;
InWord: Boolean;
begin
StdInputHandle := GetStdHandle(std_Input_Handle);
nl := 0;
nc := 0;
nw := 0;
InWord := False;
While NumRead > 0 Do
begin
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;
end;
WriteLn(IntToStr(nl) + ' ' + IntToStr(nw) + ' ' + IntToStr(nc));
end.
```
Fibonacci Numbers
```program fibo;
uses SysUtils;

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

var NUM, f : integer;

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.
```
Hash (Associative Array) Access
```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.
```
Heapsort
```program heapsort;

uses SysUtils, Classes;

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

var
ary: TList;
r : real;
rr : ^real;
N, i, LAST : integer;

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

procedure myheapsort(n : integer; var ra : TList);
var
rr : ^real;
rra : real;
i, j, l, ir : integer;
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;
for i:= 1 to N do begin
r := gen_random(1);
GetMem( rr, SizeOf(real) );
rr^ := r;

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.

```
Hello World
```program hello;
uses SysUtils;

begin
WriteLn( 'hello world' );
end.
```
List Operations
```Program lists;

uses SysUtils, Classes;

const SIZE : integer = 10000;

Function test_lists : integer;
var
i, len1, len2 : integer;
Li1, Li2, Li3 : TList;
lists_equal : Integer;
begin

Li1 := TList.Create;
Li1.Capacity := SIZE;
For i := 0 to SIZE Do

Li2 := TList.Create;
Li2.Capacity := SIZE;
For i:= 0 to SIZE Do

{ 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
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
Li3.Count := Li3.Count - 1;
end;

For i := 0 To (SIZE div 2) Do
begin
Li1.Exchange( i, SIZE-i );
end;

If integer(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 integer(Li1.items[i]) <> integer(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.
```
Matrix Multiplication
```program matrix;
uses SysUtils;

const
size = 30;

type tMatrix = array[0..size, 0..size] 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
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, val: integer;
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.
```
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 : integer;
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.
```
Nested Loops
```program nestedloop;
uses SysUtils;

var n, a, b, c, d, e, f, x : integer;

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.
```
Random Number Generator
```program random;
uses SysUtils;

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

var
LAST, NUM, i : integer;
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.
```
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
Getmem(pline, Length(line)+1);
Move(line, pline^, Length(line)+1);
end;
N := list.Count;
For i := N-1 Downto 0 do WriteLn( string(list.items[i]^) );
end.
```
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.
```
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) : integer;
begin
if Integer(A) > Integer(B) then
Result := 1
else if Integer(A) < Integer(B) Then
Result := -1
else
Result := 0;
end;

var
i, N, sum, num, middle : integer;
list : TList;
median, mean, deviation,
average_deviation, standard_deviation,
variance, skew, kurtosis : real;

begin
list := TList.Create;
While Not Eof(input) do
begin
end;
N := list.Count;
For i := 0 To N-1 do Inc(sum, Integer(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 := Integer(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 := Integer(list.Items[middle])
Else
median := (Integer(list.Items[middle]) + Integer(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.
```
String Concatenation
```program strcat;

uses SysUtils;
var
NUM, i : integer;
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( Length(str) );
end.
```
Sum a Column of Integers
```program sumcol;

var
num, tot: longint;
begin
While Not Eof(input) Do
begin