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
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(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;
NumRead: Integer;
A: Integer;
Tmp: String;
TmpPos : Byte;
Ch: String;
InWord: Boolean;
begin
StdInputHandle := GetStdHandle(std_Input_Handle);
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.
|
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;
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.
|
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
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 := 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
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.
|
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
Readln(input, num);
list.Add( Pointer(num) );
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
ReadLn(input, num);
tot := tot + num;
end;
WriteLn(tot);
end.
|