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.
|