Re: Calculate the string statement

Hi,

long years ago I made a parser for math functions with the argument x
and parameters like a, b, ...
It has the abilities to differentiate the function and calculate values from
given x.
If you wonder about some types I declared, then you should know, that I
ported it
from schtac pascal on a commodore 4032 to turbo pascal 5.
However it is german language.

Here is the main module diff.pas :
=======================
program diff;

uses crt,
zusatz,
Strings;

const zlen = 16;
type t = (arg,verkn,funkt,sconst,zconst);
p = ^op;
op = record
case typ : t of
arg :();
verkn :(vkn :char;
op1,op2:p;
);
funkt :(fkt :string;
opr :p;
);
sconst:(scn :string);
zconst:(zcn :real);
end;
cp = ^cl;
cl = record
scn : string;
zcn : real;
nxt : cp;
end;

var fkt,dfkt : p;
clist : cp;
diffanz,i : integer;
x,f : real;
erfolg : boolean;
ch : char;

function sign(x:real):integer;
begin
if x<>0 then
if x>0 then
sign:=+1
else
sign:=-1
else
sign:=0;
end;

procedure delbl(var s:string);
var i : integer;
begin
i:=1;
while i<=length(s) do
begin
if s[i]=' ' then
s:=copy(s,1,pred(i))+copy(s,succ(i),$ff)
else
inc(i);
end;
end; (* delbl *)

procedure strreal(zk:string; var z:real; var erfolg:boolean);
var code : integer;
begin
delbl(zk);
val(zk,z,code);
erfolg:=code=0;
end; (* strreal *)

procedure realstr(z:real; var zk:string);
var ma : real;
ex : integer;
exk : string;
sm : integer;
nm : integer;
i,ic : integer;
d,e : integer;
r : real;

function ziff(i:integer):char;
begin
ziff:=chr(i+ord('0'));
end; (* ziff *)

begin (* realstr *)
nm:=zlen-6;
ma:=abs(z);
sm:=0;
if z<0 then sm:=1;
ex:=0;
zk:='';
if ma>0 then
begin
r:=5;
for i:=1 to nm do
r:=r/10;
if ma>=10 then
while ma>=10 do
begin
ma:=ma/10;
ex:=ex+1;
end
else
while ma<1 do
begin
ma:=ma*10;
ex:=ex-1;
end;
ma:=ma+r;
if ma>=10 then
begin
ma:=ma/10;
ex:=ex+1;
end;
end;
for i:=1 to nm do
begin
ic:=trunc(ma);
zk:=zk+ziff(ic);
ma:=(ma-ic)*10;
end;
ex:=ex-nm+1;
ic:=nm;
while (ic>1) and (zk[ic]='0') do
begin
dec(ic);
zk:=copy(zk,1,ic);
ex:=ex+1;
end;
if z=0 then
ex:=0;
if sm=1 then
begin
zk:='-'+zk;
ic:=ic+1;
end;
e:=2;
if ic-sm>1 then e:=3;
if nm-ic<e then e:=nm-ic;
if ex>e then
begin
ex:=ex+ic-1-sm;
if ic-sm>1 then
begin
insert('.',zk,sm+2);
ic:=ic+1;
end;
e:=zlen;
exk:=ziff(ex mod 10);
e:=e-1;
if ex>=10 then
begin
exk:=ziff(ex div 10)+exk;
e:=e-1;
end;
exk:='E'+exk;
zk:=zk+exk
end
else
if ex>=0 then
for i:=1 to ex do
zk:=zk+'0'
else
begin
ex:=abs(ex);
e:=ic-1-sm;
if ex<=e then
begin
e:=ic+1-ex;
insert('.',zk,e);
end
else
begin
e:=ic-sm+2;
if ic-sm=1 then e:=2;
if ex<=e then
begin
d:=ex-ic+sm+2;
if ic>zlen-d then ic:=zlen-d;
insert(spc(d),zk,1+sm);
for i:=1+sm to d+sm do
zk[i]:='0';
zk[2+sm]:='.';
end
else
begin
ex:=ex-ic+1+sm;
if ic-sm>1 then
begin
insert('.',zk,2+sm);
ic:=ic+1;
end;
e:=zlen;
exk:=ziff(ex mod 10);
e:=e-1;
if ex>=10 then
begin
exk:=ziff(ex div 10)+exk;
e:=e-1;
end;
exk:='-'+exk;
e:=e-1;
exk:='E'+exk;
zk:=zk+exk;
end;
end;
end;
end; (* realstr *)

procedure wrtf;

procedure w(f:p; ebene:integer);

var fehler : boolean;
zk : string;

procedure wsum;
begin
fehler:=false;
if ebene>0 then write('(');
w(f^.op1,0);
write(f^.vkn);
w(f^.op2,0);
if ebene>0 then write(')');
end; (* wsum *)

procedure wdif;
begin
fehler:=false;
if ebene>0 then write('(');
if f^.op1^.typ=zconst then
begin
if f^.op1^.zcn<>0 then
w(f^.op1,0);
end
else
w(f^.op1,0);
write(f^.vkn);
w(f^.op2,1);
if ebene>0 then write(')');
end; (* wdif *)

procedure wmul;
begin
fehler:=false;
if ebene>2 then write('(');
w(f^.op1,2);
write(f^.vkn);
w(f^.op2,2);
if ebene>2 then write(')');
end; (* wmul *)

procedure wquo;
begin
fehler:=false;
if ebene>2 then write('(');
w(f^.op1,2);
write(f^.vkn);
w(f^.op2,3);
if ebene>2 then write(')');
end; (* wquo *)

procedure wpot;
begin
fehler:=false;
if ebene>4 then write('(');
w(f^.op1,5);
write(f^.vkn);
w(f^.op2,4);
if ebene>4 then write(')');
end; (* wpot *)

begin (* w *)
fehler:=true;
if f=nil then
begin
fehler:=false;
write('?')
end
else
case f^.typ of
arg : begin
fehler:=false;
write('x');
end;
verkn : case f^.vkn of
'+': wsum;
'-': wdif;
'*': wmul;
'/': wquo;
'^': wpot;
end;
funkt : begin
fehler:=false;
write(f^.fkt);
write('(');
w(f^.opr,0);
write(')');
end;
sconst : begin
fehler:=false;
write(f^.scn);
end;
zconst : begin
fehler:=false;
realstr(f^.zcn,zk);
write(zk);
end;
end;
if fehler then
write('Pointerfehler!');
end; (* w *)

begin (* wrtf *)
w(fkt,0);
end; (* wrtf *)

procedure holefunc;
var err, i : integer;
s, t,
erm : string;

procedure kltest;
var klammer,i : integer;
begin
klammer:=0;
i:=1;
while (i<=length(s)) and (klammer>=0) do
begin
if s[i]='(' then
klammer:=klammer+1;
if s[i]=')' then
klammer:=klammer-1;
i:=i+1;
end;
if klammer<0 then
begin
err:=i;
erm:='rechte Klammer zuviel';
end
else
if klammer>0 then
begin
err:=length(s)+1;
erm:='rechte Klammer zuwenig';
end;
end; (* kltest *)

procedure teilfunc(var f:p; von,bis:integer);
var pos : integer;
s3 : string;
zk : string;
vk : char;

procedure klblock(var v,b:integer);
var klammer,i : integer;
begin
klammer:=0;
i:=b+1;
repeat
i:=i-1;
if s[i]=')' then
klammer:=klammer+1;
if s[i]='(' then
klammer:=klammer-1;
until (i=v) or (klammer=0);
v:=i;
if klammer>0 then
begin
klammer:=0;
i:=v-1;
repeat
i:=i+1;
if s[i]='(' then
klammer:=klammer+1;
if s[i]=')' then
klammer:=klammer-1;
until klammer<0;
err:=i;
erm:='rechte Klammer zuviel';
end;
end; (* klblock *)

procedure ltblock(var v,b:integer);
var i,i1 : integer;
begin
s3:=' ';
i1:=b;
repeat
i:=i1;
if i1>v then
i1:=i1-1;
until (i=v) or not(s[i1] in ['A'..'Z']);
if i<=b-3 then
begin
err:=i+3;
erm:='Buchstabenkette zu lang';
end
else
begin
v:=i;
i1:=0;
for i:=v to b do
begin
i1:=i1+1;
s3[i1]:=s[i];
end;
end;
end; (* ltblock *)

procedure zablock(var v,b:integer);
var i,i1,i2,v1 : integer;
begin
zk:=spc(zlen);
i:=b;
if i>v then
i1:=i-1
else
i1:=i;
if i1>v then
i2:=i1-1
else
i2:=i1;
repeat
v1:=i+1;
if s[i] in ['.','0'..'9'] then
v1:=0
else
if s[i]='E' then
begin
if s[i1] in ['.','0'..'9'] then
v1:=0;
end
else
if s[i] in ['+','-'] then
if s[i1]='E' then
if s[i2] in ['.','0'..'9'] then
v1:=0;
if v1=0 then
if i=v then
v1:=i;
i :=i1;
i1:=i2;
if i1>v then
i2:=i1-1;
until v1>0;
if v1<=b-zlen then
begin
err:=v1+zlen;
erm:='Zahlenkonstante zu lang';
end
else
begin
v:=v1;
i1:=0;
for i:=v to b do
begin
i1:=i1+1;
zk[i1]:=s[i];
end;
end;
end; (* zablock *)

procedure suchvk;
var v,b : integer;

procedure sklammer;
begin
v:=von;
klblock(v,b);
if err=0 then
if vk=' ' then
begin
vk:='(';
b:=v-1;
if b>=von then
if s[b] in ['A'..'Z'] then
begin
pos:=v;
v:=von;
ltblock(v,b);
if err=0 then
begin
vk:='F';
b:=v-1;
end;
end
end
else
if not(vk in ['+','-','*','/','^']) then
begin
err:=b+1;
erm:='fehlende Verkn?pfung';
end
else
b:=v-1;
end; (* sklammer *)

procedure sletter;
begin
v:=von;
ltblock(v,b);
if err=0 then
if vk=' ' then
begin
if s3='X ' then
vk:='X'
else
vk:='S';
b:=v-1;
end
else
if not(vk in ['+','-','*','/','^']) then
begin
err:=b+1;
erm:='fehlende Verkn?pfung';
end
else
b:=v-1;
end; (* sletter *)

procedure szahl;
begin
v:=von;
zablock(v,b);
if err=0 then
if vk=' ' then
begin
vk:='Z';
pos:=v;
b:=v-1;
end
else
if not(vk in ['+','-','*','/','^']) then
begin
err:=b+1;
erm:='fehlende Verkn?pfung';
end
else
b:=v-1;
end; (* szahl *)

procedure sverkn;

procedure neuverkn;
begin
vk:=s[b];
pos:=b;
end; (* neuverkn *)

begin (* sverkn *)
if s[b]='+' then
neuverkn
else
if s[b]='-' then
begin
if not(vk in ['+','-']) then
neuverkn;
end
else
if s[b]='*' then
begin
if not(vk in ['+','-']) then
neuverkn;
end
else
if s[b]='/' then
begin
if not(vk in ['+','-','*','/']) then
neuverkn;
end
else
if s[b]='^' then
if not(vk in ['+','-','*','/']) then
neuverkn;
b:=b-1;
end; (* sverkn *)

begin (* suchvk *)
vk:=' ';
b:=bis;
repeat
if s[b]=')' then
sklammer
else
if s[b] in ['A'..'Z'] then
sletter
else
if s[b] in ['.','0'..'9'] then
szahl
else
if s[b] in ['+','-','*','/','^'] then
sverkn
else
begin
err:=b;
erm:='unzul"ssiges Zeichen';
end;
until (b<von) or (err>0);
end; (* suchvk *)

procedure tklamm;
var v,b : integer;
begin
v:=von+1;
b:=bis-1;
if b>=v then
teilfunc(f,v,b)
else
begin
err:=v;
erm:='leere Klammer';
end;
end; (* tklamm *)

procedure tfunkt;
begin
if (s3='EXP') or
(s3='LN ') or
(s3='SIN') or
(s3='COS') or
(s3='TAN') or
(s3='COT') or
(s3='ASN') or
(s3='ACS') or
(s3='ATN') or
(s3='ACT')
then
begin
delbl(s3);
new(f);
f^.typ:=funkt;
f^.fkt:=s3;
f^.opr:=nil;
teilfunc(f^.opr,pos,bis);
end
else
begin
err:=von;
erm:='unzul"ssiger Funktionsbezeichner';
end;
end; (* tfunkt *)

procedure targ;
begin
new(f);
f^.typ:=arg;
end; (* targ *)

procedure tletter;
begin
if (s3='EXP') or
(s3='LN ') or
(s3='SIN') or
(s3='COS') or
(s3='TAN') or
(s3='COT') or
(s3='ASN') or
(s3='ACS') or
(s3='ATN') or
(s3='ACT')
then
begin
err:=bis+1;
erm:='fehlendes Funktionsargument';
end
else
begin
delbl(s3);
new(f);
f^.typ:=sconst;
f^.scn:=s3;
end;
end; (* tletter *)

procedure tzahl;
var z : real;
erfolg : boolean;
begin
strreal(zk,z,erfolg);
if erfolg then
begin
new(f);
f^.typ:=zconst;
f^.zcn:=z;
end
else
begin
err:=von;
erm:='unzul"ssige Zahlenkonstante';
end;
end; (* tzahl *)

procedure tdif;
var b,v : integer;
begin
b:=pos-1;
v:=pos+1;
if bis>=v then
begin
new(f);
f^.typ:=verkn;
f^.vkn:=vk;
f^.op2:=nil;
teilfunc(f^.op2,v,bis);
if b>=von then
begin
f^.op1:=nil;
teilfunc(f^.op1,von,b);
end
else
begin
new(f^.op1);
f^.op1^.typ:=zconst;
f^.op1^.zcn:=0;
end;
end
else
begin
err:=v;
erm:='zweiter Operand fehlt';
end;
end; (* tdif *)

procedure tverkn;
var b,v : integer;
begin
b:=pos-1;
v:=pos+1;
if b>=von then
if bis>=v then
begin
new(f);
f^.typ:=verkn;
f^.vkn:=vk;
f^.op1:=nil;
f^.op2:=nil;
teilfunc(f^.op1,von,b);
teilfunc(f^.op2,v,bis);
end
else
begin
err:=v;
erm:='zweiter Operand fehlt';
end
else
begin
err:=von;
erm:='erster Operand fehlt';
end;
end; (* tverkn *)

begin (* teilfunc *)
suchvk;
if err=0 then
case vk of
' ': begin
err:=von;
erm:='unidentifizierter Ausdruck';
end;
'(': tklamm;
'F': tfunkt;
'X': targ;
'S': tletter;
'Z': tzahl;
'-': tdif;
'+',
'*',
'/',
'^': tverkn;
end;
end; (* teilfunc *)

begin (* holefunc *)
err:=0;
s:='';
repeat
clrscr;
writeln;
writeln;
if err>0 then
begin
for i:=1 to err-1 do
write(' ');
writeln('^');
writeln(erm);
end;
writeln;
writeln;
writeln('Argument: ','X');
writeln;
write('m"gliche Operatoren: ');
write('+',' ');
write('-',' ');
write('*',' ');
write('/',' ');
write('^',' ');
writeln;
writeln;
writeln('m"gliche Funktionen:');
write('EXP',' ');
write('LN' ,' ');
write('SIN',' ');
write('COS',' ');
write('TAN',' ');
write('COT',' ');
write('ASN',' ');
write('ACS',' ');
write('ATN',' ');
write('ACT',' ');
writeln;
writeln;
write('Zahlenkonstanten haben eine maximale ');
writeln('L"nge von ',zlen:2,' Zeichen');
writeln;
write('Buchstabenkonstanten d?rfen nur aus ');
writeln('Buchstaben bestehen und haben eine');
writeln('maximale L"nge von 3 Zeichen');
gotoxy(1,1);
writeln('f(x):=?');
t := modify(s, 80);
clrscr;
err:=0;
kltest;
if err=0 then
begin
i:=length(s);
if i=0 then
begin
err:=1;
erm:='leere Eingabe';
end
else
begin
fkt:=nil;
teilfunc(fkt,1,i);
end;
end;
until err=0;
end; (* holefunc *)

procedure c(f:p; var t:p);
begin
new(t);
t^:=f^;
if f^.typ=verkn then
begin
c(f^.op1,t^.op1);
c(f^.op2,t^.op2);
end
else
if f^.typ=funkt then
c(f^.opr,t^.opr);
end; (* c *)

procedure dsp(var f:p);
begin
if f^.typ=verkn then
begin
dsp(f^.op1);
dsp(f^.op2);
end
else
if f^.typ=funkt then
dsp(f^.opr);
dispose(f);
end; (* c *)

procedure d(f:p; var df:p);
var fehler : boolean;
s3 : string;

procedure dsum;
begin
fehler:=false;
new(df);
df^.typ:=verkn;
df^.vkn:='+';
d(f^.op1,df^.op1);
d(f^.op2,df^.op2);
end; (* dsum *)

procedure ddif;
begin
fehler:=false;
new(df);
df^.typ:=verkn;
df^.vkn:='-';
d(f^.op1,df^.op1);
d(f^.op2,df^.op2);
end; (* ddif *)

procedure dmul;
begin
fehler:=false;
(* summe *)
new(df);
df^.typ:=verkn;
df^.vkn:='+';
(* 1. summand = produkt *)
new(df^.op1);
df^.op1^.typ:=verkn;
df^.op1^.vkn:='*';
d(f^.op1,df^.op1^.op1);
c(f^.op2,df^.op1^.op2);
(* 2. summand = produkt *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='*';
c(f^.op1,df^.op2^.op1);
d(f^.op2,df^.op2^.op2);
end; (* dmul *)

procedure dquo;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* nenner = (f^.op2) hoch 2 *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='^';
c(f^.op2,df^.op2^.op1);
new(df^.op2^.op2);
df^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.zcn:=2;
(* zaehler = differenz *)
new(df^.op1);
df^.op1^.typ:=verkn;
df^.op1^.vkn:='-';
(* minuend = produkt *)
new(df^.op1^.op1);
df^.op1^.op1^.typ:=verkn;
df^.op1^.op1^.vkn:='*';
d(f^.op1,df^.op1^.op1^.op1);
c(f^.op2,df^.op1^.op1^.op2);
(* subtrahend = produkt *)
new(df^.op1^.op2);
df^.op1^.op2^.typ:=verkn;
df^.op1^.op2^.vkn:='*';
c(f^.op1,df^.op1^.op2^.op1);
d(f^.op2,df^.op1^.op2^.op2);
end; (* dquo *)

procedure dpot;
begin
fehler:=false;
(* produkt *)
new(df);
df^.typ:=verkn;
df^.vkn:='*';
(* 1. faktor = potenz *)
new(df^.op1);
df^.op1^.typ:=verkn;
df^.op1^.vkn:='^';
(* basis = f^.op1 *)
c(f^.op1,df^.op1^.op1);
(* exponent = differenz *)
new(df^.op1^.op2);
df^.op1^.op2^.typ:=verkn;
df^.op1^.op2^.vkn:='-';
(* minuend = f^.op2 *)
c(f^.op2,df^.op1^.op2^.op1);
(* subtrahend = 1 *);
new(df^.op1^.op2^.op2);
df^.op1^.op2^.op2^.typ:=zconst;
df^.op1^.op2^.op2^.zcn:=1;
(* 2. faktor = produkt *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='*';
(* 1. faktor = f^.op2 *)
c(f^.op2,df^.op2^.op1);
(* 2. faktor = nachdifferentiation *)
d(f^.op1,df^.op2^.op2);
end; (* dpot *)

procedure dyhz;
begin
fehler:=false;
(* logarithmisches differenzieren *)
(* produkt *)
new(df);
df^.typ:=verkn;
df^.vkn:='*';
(* 1. faktor = f *)
c(f,df^.op1);
(* 2. faktor = summe *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='+';
(* 1. summand = produkt *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=verkn;
df^.op2^.op1^.vkn:='*';
(* 1. faktor = d(f^.op2) *)
d(f^.op2,df^.op2^.op1^.op1);
(* 2. faktor = ln(f^.op1) *)
new(df^.op2^.op1^.op2);
df^.op2^.op1^.op2^.typ:=funkt;
df^.op2^.op1^.op2^.fkt:='LN ';
delbl(df^.op2^.op1^.op2^.fkt);
c(f^.op1,df^.op2^.op1^.op2^.opr);
(* 2. summand = produkt *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=verkn;
df^.op2^.op2^.vkn:='*';
(* 1. faktor = f^.op2 *)
c(f^.op2,df^.op2^.op2^.op1);
(* 2. faktor = quotient *)
new(df^.op2^.op2^.op2);
df^.op2^.op2^.op2^.typ:=verkn;
df^.op2^.op2^.op2^.vkn:='/';
(* zaehler = d(f^.op1) *)
d(f^.op1,df^.op2^.op2^.op2^.op1);
(* nenner = f^.op1 *)
c(f^.op1,df^.op2^.op2^.op2^.op2);
end; (* dyhz *)

procedure dexp;
begin
fehler:=false;
new(df);
df^.typ:=verkn;
df^.vkn:='*';
c(f,df^.op1);
d(f^.opr,df^.op2);
end; (* dexp *)

procedure dlny;
begin
fehler:=false;
new(df);
df^.typ:=verkn;
df^.vkn:='/';
d(f^.opr,df^.op1);
c(f^.opr,df^.op2);
end; (* dlny *)

procedure dsin;
begin
fehler:=false;
(* produkt *)
new(df);
df^.typ:=verkn;
df^.vkn:='*';
(* 1. faktor = cos(f^.opr) *)
new(df^.op1);
df^.op1^.typ:=funkt;
df^.op1^.fkt:='COS';
c(f^.opr,df^.op1^.opr);
(* 2. faktor = nachdifferentiation *)
d(f^.opr,df^.op2);
end; (* dsin *)

procedure dcos;
begin
fehler:=false;
(* - produkt *)
new(df);
df^.typ:=verkn;
df^.vkn:='-';
new(df^.op1);
df^.op1^.typ:=zconst;
df^.op1^.zcn:=0;
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='*';
(* 1. faktor = sin(f^.opr) *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=funkt;
df^.op2^.op1^.fkt:='SIN';
c(f^.opr,df^.op2^.op1^.opr);
(* 2. faktor = nachdifferentiation *)
d(f^.opr,df^.op2^.op2);
end; (* dcos *)

procedure dtan;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* zaehler = nachdifferentiation *)
d(f^.opr,df^.op1);
(* nenner = potenz *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='^';
(* basis = cos(f^.opr) *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=funkt;
df^.op2^.op1^.fkt:='COS';
c(f^.opr,df^.op2^.op1^.opr);
(* exponent = 2 *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.zcn:=2;
end; (* dtan *)

procedure dcot;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* zaehler = - nachdifferentiation *)
new(df^.op1);
df^.op1^.typ:=verkn;
df^.op1^.vkn:='-';
new(df^.op1^.op1);
df^.op1^.op1^.typ:=zconst;
df^.op1^.op1^.zcn:=0;
d(f^.opr,df^.op1^.op2);
(* nenner = potenz *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='^';
(* basis = sin(f^.opr) *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=funkt;
df^.op2^.op1^.fkt:='SIN';
c(f^.opr,df^.op2^.op1^.opr);
(* exponent = 2 *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.zcn:=2;
end; (* dcot *)

procedure dasn;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* zaehler = nachdifferentiation *)
d(f^.opr,df^.op1);
(* nenner = potenz *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='^';
(* exponent = 0.5 *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.zcn:=0.5;
(* basis = differenz *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=verkn;
df^.op2^.op1^.vkn:='-';
(* minuend = 1 *)
new(df^.op2^.op1^.op1);
df^.op2^.op1^.op1^.typ:=zconst;
df^.op2^.op1^.op1^.zcn:=1;
(* subtrahend = potenz *)
new(df^.op2^.op1^.op2);
df^.op2^.op1^.op2^.typ:=verkn;
df^.op2^.op1^.op2^.vkn:='^';
(* basis = f^.opr *)
c(f^.opr,df^.op2^.op1^.op2^.op1);
(* exponent = 2 *)
new(df^.op2^.op1^.op2^.op2);
df^.op2^.op1^.op2^.op2^.typ:=zconst;
df^.op2^.op1^.op2^.op2^.zcn:=2;
end; (* dasn *)

procedure dacs;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* zaehler = - nachdifferentiation *)
new(df^.op1);
df^.op1^.typ:=verkn;
df^.op1^.vkn:='-';
new(df^.op1^.op1);
df^.op1^.op1^.typ:=zconst;
df^.op1^.op1^.zcn:=0;
d(f^.opr,df^.op1^.op2);
(* nenner = potenz *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='^';
(* exponent = 0.5 *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.zcn:=0.5;
(* basis = differenz *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=verkn;
df^.op2^.op1^.vkn:='-';
(* minuend = 1 *)
new(df^.op2^.op1^.op1);
df^.op2^.op1^.op1^.typ:=zconst;
df^.op2^.op1^.op1^.zcn:=1;
(* subtrahend = potenz *)
new(df^.op2^.op1^.op2);
df^.op2^.op1^.op2^.typ:=verkn;
df^.op2^.op1^.op2^.vkn:='^';
(* basis = f^.opr *)
c(f^.opr,df^.op2^.op1^.op2^.op1);
(* exponent = 2 *)
new(df^.op2^.op1^.op2^.op2);
df^.op2^.op1^.op2^.op2^.typ:=zconst;
df^.op2^.op1^.op2^.op2^.zcn:=2;
end; (* dacs *)

procedure datn;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* zaehler = nachdifferentiation *)
d(f^.opr,df^.op1);
(* nenner = summe *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='+';
(* 1. summand = 1 *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=zconst;
df^.op2^.op1^.zcn:=1;
(* 2. summand = potenz *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=verkn;
df^.op2^.op2^.vkn:='^';
(* basis = f^.opr *)
c(f^.opr,df^.op2^.op2^.op1);
(* exponent = 2 *)
new(df^.op2^.op2^.op2);
df^.op2^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.op2^.zcn:=2;
end; (* datn *)

procedure dact;
begin
fehler:=false;
(* quotient *)
new(df);
df^.typ:=verkn;
df^.vkn:='/';
(* zaehler = - nachdifferentiation *)
new(df^.op1);
df^.op1^.typ:=verkn;
df^.op1^.vkn:='-';
new(df^.op1^.op1);
df^.op1^.op1^.typ:=zconst;
df^.op1^.op1^.zcn:=0;
d(f^.opr,df^.op1^.op2);
(* nenner = summe *)
new(df^.op2);
df^.op2^.typ:=verkn;
df^.op2^.vkn:='+';
(* 1. summand = 1 *)
new(df^.op2^.op1);
df^.op2^.op1^.typ:=zconst;
df^.op2^.op1^.zcn:=1;
(* 2. summand = potenz *)
new(df^.op2^.op2);
df^.op2^.op2^.typ:=verkn;
df^.op2^.op2^.vkn:='^';
(* basis = f^.opr *)
c(f^.opr,df^.op2^.op2^.op1);
(* exponent = 2 *)
new(df^.op2^.op2^.op2);
df^.op2^.op2^.op2^.typ:=zconst;
df^.op2^.op2^.op2^.zcn:=2;
end; (* dact *)

begin (* d *)
fehler:=true;
case f^.typ of
arg : begin
fehler:=false;
new(df);
df^.typ:=zconst;
df^.zcn:=1;
end;
verkn : case f^.vkn of
'+':dsum;
'-':ddif;
'*':dmul;
'/':dquo;
'^':if f^.op2^.typ in [sconst,zconst] then
dpot
else
dyhz;
end;
funkt : begin
if f^.fkt='EXP' then dexp;
s3:= 'LN ';
delbl(s3);
if f^.fkt=s3 then dlny;
if f^.fkt='SIN' then dsin;
if f^.fkt='COS' then dcos;
if f^.fkt='TAN' then dtan;
if f^.fkt='COT' then dcot;
if f^.fkt='ASN' then dasn;
if f^.fkt='ACS' then dacs;
if f^.fkt='ATN' then datn;
if f^.fkt='ACT' then dact;
end;
sconst,
zconst : begin
fehler:=false;
new(df);
df^.typ:=zconst;
df^.zcn:=0;
end;
end;
if fehler then
writeln('Differentiationsfehler!');
end; (* d *)

procedure vereinf(var f:p);
var fehler : boolean;
t : p;

procedure vsum;
begin
fehler:=false;
if f^.op1^.typ=zconst then
begin
if f^.op1^.zcn=0 then
begin
t:=f^.op2;
dsp(f^.op1);
dispose(f);
f:=t;
end
else
if f^.op2^.typ=zconst then
begin
t:=f^.op2;
t^.zcn:=f^.op1^.zcn+f^.op2^.zcn;
dsp(f^.op1);
dispose(f);
f:=t;
end
end
else
if f^.op2^.typ=zconst then
if f^.op2^.zcn=0 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end;
end; (* vsum *)

procedure vdif;
begin
fehler:=false;
if f^.op1^.typ=zconst then
begin
if f^.op2^.typ=zconst then
begin
t:=f^.op2;
t^.zcn:=f^.op1^.zcn-f^.op2^.zcn;
dsp(f^.op1);
dispose(f);
f:=t;
end
end
else
if f^.op2^.typ=zconst then
if f^.op2^.zcn=0 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end;
end; (* vdif *)

procedure vmul;
begin
fehler:=false;
if f^.op1^.typ=zconst then
begin
if f^.op1^.zcn=1 then
begin
t:=f^.op2;
dsp(f^.op1);
dispose(f);
f:=t;
end
else
if f^.op1^.zcn=0 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end
else
if f^.op2^.typ=zconst then
begin
t:=f^.op2;
t^.zcn:=f^.op1^.zcn*f^.op2^.zcn;
dsp(f^.op1);
dispose(f);
f:=t;
end
end
else
if f^.op2^.typ=zconst then
if f^.op2^.zcn=1 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end
else
if f^.op2^.zcn=0 then
begin
t:=f^.op2;
dsp(f^.op1);
dispose(f);
f:=t;
end;
end; (* vmul *)

procedure vquo;
begin
fehler:=false;
if f^.op1^.typ=zconst then
begin
if f^.op1^.zcn=0 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end
else
if f^.op2^.typ=zconst then
if f^.op2^.zcn<>0 then
begin
t:=f^.op2;
t^.zcn:=f^.op1^.zcn/f^.op2^.zcn;
dsp(f^.op1);
dispose(f);
f:=t;
end
end
else
if f^.op2^.typ=zconst then
if f^.op2^.zcn=1 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end;
end; (* vquo *)

procedure vpot;
begin
fehler:=false;
if f^.op2^.typ=zconst then
begin
if f^.op2^.zcn=1 then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end
else
if f^.op2^.zcn=0 then
begin
t:=f^.op1;
t^.zcn:=1;
dsp(f^.op2);
dispose(f);
f:=t;
end
else
if f^.op1^.typ=zconst then
if f^.op1^.zcn>0 then
begin
t:=f^.op2;
t^.zcn:=exp(f^.op2^.zcn*ln(f^.op1^.zcn));
dsp(f^.op1);
dispose(f);
f:=t;
end
end
else
if f^.op1^.typ=zconst then
if (f^.op1^.zcn=0) or (f^.op1^.zcn=1) then
begin
t:=f^.op1;
dsp(f^.op2);
dispose(f);
f:=t;
end
end; (* vpot *)

begin (* vereinf *)
fehler:=false;
if f^.typ=verkn then
begin
fehler:=true;
vereinf(f^.op1);
vereinf(f^.op2);
case f^.vkn of
'+':vsum;
'-':vdif;
'*':vmul;
'/':vquo;
'^':vpot;
end;
end
else
if f^.typ=funkt then
vereinf(f^.opr);
if fehler then
writeln('Vereinfachungsfehler!');
end; (* vereinf *)

procedure wrtw;
var zx,zf : string;
i : integer;
begin
realstr(x,zx);
realstr(f,zf);
write('f');
for i:=1 to diffanz do write('''');
write('(');
write(zx);
write(')=');
write(zf);
end; (* wrtw *)

procedure calc(f:p; var w:real; var erfolg:boolean);
var x1,x2 : real;
fehler : boolean;
s3 : string;

procedure csum;
begin
fehler:=false;
erfolg:=true;
w:=x1+x2;
end; (* csum *)

procedure cdif;
begin
fehler:=false;
erfolg:=true;
w:=x1-x2;
end; (* cdif *)

procedure cmul;
begin
fehler:=false;
erfolg:=true;
w:=x1*x2;
end; (* cmul *)

procedure cquo;
begin
fehler:=false;
erfolg:=x2<>0;
if erfolg then
w:=x1/x2;
end; (* cquo *)

procedure cpot;
begin
fehler:=false;
erfolg:=x1>0;
if erfolg then
w:=exp(x2*ln(x1));
end; (* cpot *)

procedure cexp;
begin
fehler:=false;
erfolg:=x1<88;
if erfolg then
if x1<-88 then
w:=0
else
w:=exp(x1);
end; (* cexp *)

procedure clny;
begin
fehler:=false;
erfolg:=x1>0;
if erfolg then
w:=ln(x1);
end; (* clny *)

procedure csin;
begin
fehler:=false;
erfolg:=true;
w:=sin(x1);
end; (* csin *)

procedure ccos;
begin
fehler:=false;
erfolg:=true;
w:=cos(x1);
end; (* ccos *)

procedure ctan;
begin
fehler:=false;
w:=cos(x1);
erfolg:=w<>0;
if erfolg then
w:=sin(x1)/w;
end; (* ctan *)

procedure ccot;
begin
fehler:=false;
w:=sin(x1);
erfolg:=w<>0;
if erfolg then
w:=cos(x1)/w;
end; (* ccot *)

procedure casn;
begin
fehler:=false;
erfolg:=abs(x1)<=1;
if erfolg then
if abs(x1)=1 then
w:=sign(x1)*pi/2
else
w:=arctan(x1/sqrt(1-sqr(x1)));
end; (* casn *)

procedure cacs;
begin
fehler:=false;
erfolg:=abs(x1)<=1;
if erfolg then
if x1=0 then
w:=pi/2
else
begin
w:=arctan(sqrt(1-sqr(x1))/abs(x1));
if x1<0 then
w:=pi-w;
end;
end; (* cacs *)

procedure catn;
begin
fehler:=false;
erfolg:=true;
w:=arctan(x1);
end; (* catn *)

procedure cact;
begin
fehler:=false;
erfolg:=true;
if x1=0 then
w:=pi/2
else
begin
w:=arctan(1/abs(x1));
if x1<0 then
w:=pi-w;
end;
end; (* cact *)

procedure cscn;
var pt : cp;
gefunden : boolean;
zk : string;

procedure neu(var pt:cp);
begin
new(pt);
pt^.nxt:=nil;
pt^.scn:=s3;
write('Welchen Wert soll die Konstante ');
write(s3);
write(' annehmen? ');
readln(w); writeln;
writeln;
pt^.zcn:=w;
realstr(w,zk);
write(s3);
write('=');
write(zk);
writeln;
writeln;
end; (* neu *)

begin (* cscn *)
if clist=nil then
neu(clist);
pt:=clist;
gefunden:=false;
repeat
if pt^.scn=s3 then
begin
w:=pt^.zcn;
gefunden:=true;
end
else
if pt^.nxt=nil then
neu(pt^.nxt);
pt:=pt^.nxt;
until gefunden;
end; (* cscn *)

begin (* calc *)
fehler:=true;
case f^.typ of
arg : begin
fehler:=false;
erfolg:=true;
w:=x;
end;
verkn : begin
calc(f^.op1,x1,erfolg);
if erfolg then
calc(f^.op2,x2,erfolg);
if erfolg then
case f^.vkn of
'+': csum;
'-': cdif;
'*': cmul;
'/': cquo;
'^': cpot;
end;
end;
funkt : begin
calc(f^.opr,x1,erfolg);
if erfolg then
begin
if f^.fkt='EXP' then cexp;
s3:= 'LN ';
delbl(s3);
if f^.fkt=s3 then clny;
if f^.fkt='SIN' then csin;
if f^.fkt='COS' then ccos;
if f^.fkt='TAN' then ctan;
if f^.fkt='COT' then ccot;
if f^.fkt='ASN' then casn;
if f^.fkt='ACS' then cacs;
if f^.fkt='ATN' then catn;
if f^.fkt='ACT' then cact;
end;
end;
sconst: begin
fehler:=false;
erfolg:=true;
s3:=f^.scn;
cscn;
end;
zconst: begin
fehler:=false;
erfolg:=true;
w:=f^.zcn;
end;
end;
if erfolg then
if fehler then
writeln('Kalkulationsfehler!');
end; (* calc *)

begin (* diff *)
GetKey := GetKeyUpr;
CList := Nil;
Repeat
holefunc;
diffanz := 0;
clrscr;
repeat
write('f');
for i := 1 to diffanz do write('''');
write('(x)=');
wrtf;
writeln;
writeln;
writeln('Funktionswert ausrechnen');
writeLn('Differenzieren');
writeln('Neue Funktion');
writeln('Ende');
writeln;
ch := choice(['F', 'D', 'N', 'E']);
writeln;
case ch of
'F' : begin
write('x? ');
readln(x);
clrscr;
calc(fkt,f,erfolg);
if erfolg then
begin
wrtw;
writeln;
writeln;
end
else
begin
writeln('unzul"ssiges Argument!');
writeln;
end;
end;
'D' : begin
d(fkt, dfkt);
diffanz := diffanz + 1;
dsp(fkt);
fkt := dfkt;
vereinf(fkt);
clrscr;
end;
end;
until ch in ['N', 'E'];
dsp(fkt);
until ch = 'E';
end.

This is the module zusatz.pas:
===================
Unit Zusatz;

{
Heinrich Wolf
www.Wolf-Fuerth.de
}

{$F+}
{$I-}

Interface

Type CSet = Set of Char;
SFunc = Function : String;

Var Einfuegen : Boolean; { Inserting }
Alt_Mod_Str : String; { old string in Modify }

GetKey : SFunc;
{ Get Key from Keyboard. If no Key was pressed,
#0 will be returned. If an extended Key was pressed,
the complete Code #0+#... will be returned.
}

Function Modify(Var s : String; MaxLen : Word) : String;
{ Modification of s by Keyboard.
Limiting the length of s to MaxLen.
When an unknown Key was pressed, Modify terminates
and returns that Key.
}

Function GetPos : String;
{ "#0POS" + chr(Editing-Position) }

Function GetKeyUpr : String;
Function GetKeyStd : String;
{ incl #0+Code for e.g. F-Keys / Returns #0 instead of waiting }

Function Choice(Auswahl : CSet) : Char;
{ Menu selection }

Procedure Forget;
{ Keys in Buffer }

Procedure Pause(MaxTime : Integer);
{ MaxTime = 0 : endless }

Implementation

Uses CRT,
Strings,
ZeitMess; { Measuring time }

const Mod_Pos = #0 + 'POS';

Var Position : Integer;

Procedure DoF4(Var Str : String);
Var Spelling,
Position,
WordPos : Integer;
Begin
Spelling := 0;
Position := 1;
WordPos := 0;
While Position <= Length(Str) Do
Begin
If IsLetter(Str[Position]) Then
Inc(WordPos)
Else
WordPos:=0;
If WordPos>0 Then
If IsUpper(Str[Position]) Then
Spelling := Spelling Or WordPos;
If WordPos=2 Then
Position:=Length(Str);
Inc(Position);
End;
WordPos := 0;
Case Spelling Of
0, { ab }
2: { aB }
Begin
{ Umwandeln in AB }
For Position := 1 To Length(Str) Do
Str[Position] := UpCaseX(Str[Position]);
End;
1: { Ab }
Begin
{ Umwandeln in ab }
For Position := 1 To Length(Str) Do
Str[Position] := LowCaseX(Str[Position]);
End;
3: { AB }
Begin
{ Umwandeln in Ab }
For Position := 1 To Length(Str) Do
Begin
If IsLetter(Str[Position]) Then
Inc(WordPos)
Else
WordPos:=0;
If WordPos<=1 Then
Str[Position] := UpCaseX(Str[Position])
Else
Str[Position] := LowCaseX(Str[Position]);
End;
End;
End;
End;

Function Modify;
Const TabStop = 5;
Var x0, y0, x, y : Word;
i : Integer;
OldLen : Integer;
ErwTas : String;
s1, s2, s3 : String;
Begin
x0:=WhereX;
y0:=WhereY;
s:=Copy(s,1,MaxLen);
Alt_Mod_Str:=s;
OldLen:=Length(s);
Position:=Succ(OldLen);
Repeat
If Einfuegen Then
Cursor( 3, 7 )
Else
Cursor( 6, 7 );
GoToXY(x0,y0);
Write(s,Spc(OldLen-Length(s)));
OldLen:=Length(s);
x:=x0 + Position - 2;
y:=y0 + x Div Succ(Lo(WindMax));
x:=Succ(x Mod Succ(Lo(WindMax)));
GoToXY(x,y);
Repeat
ErwTas:=GetKey;
Until ErwTas <> #0;
If ErwTas = A_HT Then
Begin
i:= 5 - Position Mod 5;
If Einfuegen Then
If Length(s)+I <= MaxLen Then
Insert(Spc(I),s,Position);
Inc(Position,I);
s := s + Spc(Position-1-Length(s));
ErwTas := '';
End
Else If ErwTas=f2 Then
Begin
If Position <= Length(s) Then
s[Position]:=Chr((Ord(s[Position])-31) Mod (256-32) + 32);
ErwTas:='';
End
Else If ErwTas=ShIftF2 Then
Begin
If Position <= Length(s) Then
s[Position]:=Chr((Ord(s[Position])+(256-32-33)) Mod (256-32) +
32);
ErwTas:='';
End
Else If ErwTas = F3 Then
Begin
GoToXY(x0,y0);
s:=Alt_Mod_Str;
Position:=Succ(Length(s));
ErwTas := '';
End
Else If ErwTas = F4 Then
Begin
If Position<=Length(s) Then
Begin
s2:=s[Position];
DoF4(s2);
s[Position]:=s2[1];
End;
ErwTas := '';
End
Else If ErwTas = ShiftF4 Then
Begin
If Position <= Length(s) Then
Begin
i:=Pos(' ',Copy(s,Position,$FF));
If i<>1 Then
Begin
If i=0 Then
Begin
s3:='';
s2:=s;
End
Else
Begin
Inc(i,Pred(Position));
s3:=Copy(s,i,$FF);
s2:=Copy(s,1,Pred(i));
End;
s1:='';
Repeat
i:=Pos(' ',S2);
s1:=s1+Copy(s2,1,i);
s2:=Copy(s2,Succ(i),$FF);
Until i=0;
DoF4(s2);
s:=s1+s2+s3;
End;
End;
ErwTas := '';
End
Else If ErwTas=CtrlF4 Then
Begin
DoF4(s);
ErwTas := '';
End
Else If ErwTas = BackTab Then
Begin
Position := ( Pred( Position ) Div 5 ) * 5;
ErwTas := '';
End
Else If ErwTas = ^T Then
Begin
GoToXY(x0,y0);
i:=Position;
If s[i]=' ' Then
While (i<=Length(s)) And (s[i]=' ') Do
Inc(i)
Else
While (i<=Length(s)) And (s[i]<>' ') Do
Inc(i);
Delete(s,Position,I-Position);
ErwTas := '';
End
Else If ErwTas = CtrlEnde Then
Begin
GoToXY(x0,y0);
s := Copy( s, 1, Pred(Position));
ErwTas := '';
End
Else If ErwTas=Links Then
Begin
Dec(Position);
ErwTas := '';
End
Else If ErwTas=Rechts Then
Begin
Inc(Position);
ErwTas := '';
End
Else If ErwTas=CtrlLinks Then
Begin
If Position > 1 Then
Dec(Position);
While (Position>1) And (s[Position]= ' ') Do
Dec(Position);
While (Position>1) And (s[Position]<>' ') Do
Dec(Position);
If (Position<Length(s)) And (s[Position]= ' ') And
(s[Succ(Position)]<>' ') Then
Inc(Position);
ErwTas := '';
End
Else If ErwTas=CtrlRechts Then
Begin
While (Position<=Length(s)) And (s[Position]<>' ') Do
Inc(Position);
While (Position<=Length(s)) And (s[Position]= ' ') Do
Inc(Position);
ErwTas := '';
End
Else If ErwTas=Pos1 Then
Begin
Position:=1;
ErwTas := '';
End
Else If ErwTas=Ende Then
Begin
Position:=Succ(Length(s));
ErwTas := '';
End
Else If ErwTas=entf Then
Begin
delete(s,Position,1);
ErwTas := '';
End
Else If ErwTas=einfg Then
Begin
Einfuegen:=not Einfuegen;
ErwTas := '';
End
Else If ErwTas=^Y Then
Begin
GoToXY(x0,y0);
s:='';
ErwTas := '';
End
Else If ErwTas = A_BS Then
Begin
If Position>1 Then
Begin
Dec(Position);
delete(s,Position,1);
End;
ErwTas := '';
End
Else If Copy(ErwTas, 1, Length(Mod_Pos)) = Mod_Pos Then
Begin
i := Ord(ErwTas[Length(Mod_Pos) + 1]);
If i > Length(s) Then
s := s + Spc(Pred(i) - Length(s));
Position := i;
ErwTas := '';
End
Else If ErwTas[1] in [' '..#$FF] Then
Begin
If Einfuegen Then
Begin
If Length(s)<MaxLen Then
Begin
Insert(ErwTas[1],s,Position);
Inc(Position);
End;
End
Else
If Position <= MaxLen Then
Begin
s := Copy(s,1,Pred(Position)) + ErwTas[1] +
Copy(s,Succ(Position),$FF);
Inc(Position);
End;
ErwTas := '';
End;
If Position < 1 Then Position := 1;
If Position > Length(s) Then Position := Succ(Length(s));
Until ErwTas > '';
GoToXY(x0, y0);
Cursor( 6, 7 );
Modify := ErwTas;
End;

Function GetPos;
Begin
GetPos := Mod_Pos + Chr(Position);
End;

Function GetKeyUpr;
Var S : String;
Begin
S := GetKeyStd;
If S[1]=#0 Then
GetKeyUpr := S
Else
GetKeyUpr := UpCaseX(S[1])
End;

Function GetKeyStd;
Var C : Char;
Begin
If KeyPressed Then
Begin
C := ReadKey;
If C = #0 Then
GetKeyStd := C + ReadKey
Else
GetKeyStd := C
End
Else
GetKeyStd := #0;
End;

Function Choice;
Var c, u : Char;
a : CSet;
s : String;
Begin
a := [];
For c := Succ(' ') To 'Z' Do
If c in Auswahl Then
a := a + [c];
For c := 'a' To 'z' Do
If c in Auswahl Then
a := a +[UpCase(c)];
If A_ESC in Auswahl then
a := a + [A_ESC];
For c := Succ(' ') To 'Z' Do
If c in a Then
Write(c, ' ');
Write('? ');
If a <> [] Then
Repeat
s := GetKey;
c := UpCaseX(s[1]);
Until c in a
Else
c := #0;
If c > ' ' Then
Write(c);
WriteLn;
Choice := c;
End;

Procedure Forget;
Var c : Char;
Begin
While KeyPressed Do
c:=ReadKey;
End;

Procedure Pause;
Var Abbruch: Boolean;
Begin
Forget;
Abbruch := False;
MerkeZeit;
Repeat
If KeyPressed Then
Abbruch := True;
If MaxTime > 0 Then
If Laufzeit > MaxTime Then
Abbruch := True;
Until Abbruch;
Forget;
End;

Begin
Einfuegen := False;
GetKey := GetKeyStd;
Position := 1;
End.

This is the module strings.pas :
====================
Unit Strings;

{
Heinrich Wolf
www.Wolf-Fuerth.de
}

{$F+}
{$I-}
Interface

Const { ASCII Codes }
A_NUL = #$00;
A_SOH = #$01;
A_STX = #$02;
A_ETX = #$03;
A_EOT = #$04;
A_ENQ = #$05;
A_ACK = #$06;
A_BEL = #$07;
A_BS = #$08;
A_HT = #$09;
A_LF = #$0A;
A_VT = #$0B;
A_FF = #$0C;
A_CR = #$0D;
A_SO = #$0E;
A_SI = #$0F;
A_DLE = #$10;
A_DC1 = #$11;
A_XON = #$11;
A_DC2 = #$12;
A_DC3 = #$13;
A_XOF = #$13;
A_DC4 = #$14;
A_NAK = #$15;
A_SYN = #$16;
A_ETB = #$17;
A_CAN = #$18;
A_EM = #$19;
A_SUB = #$1A;
A_ESC = #$1B;
A_FS = #$1C;
A_GS = #$1D;
A_RS = #$1E;
A_US = #$1F;
A_SP = #$20;
A_DEL = #$7F;
{ Tastaturcodes }
BackTab = #0+ #15;
AltQ = #0+ #16;
AltW = #0+ #17;
AltE = #0+ #18;
AltR = #0+ #19;
AltT = #0+ #20;
AltY = #0+ #21;
AltU = #0+ #22;
AltI = #0+ #23;
AltO = #0+ #24;
AltP = #0+ #25;
AltA = #0+ #30;
AltS = #0+ #31;
AltD = #0+ #32;
AltF = #0+ #33;
AltG = #0+ #34;
AltH = #0+ #35;
AltJ = #0+ #36;
AltK = #0+ #37;
AltL = #0+ #38;
AltZ = #0+ #44;
AltX = #0+ #45;
AltC = #0+ #46;
AltV = #0+ #47;
AltB = #0+ #48;
AltN = #0+ #49;
AltM = #0+ #50;
F1 = #0+ #59;
F2 = #0+ #60;
F3 = #0+ #61;
F4 = #0+ #62;
F5 = #0+ #63;
F6 = #0+ #64;
F7 = #0+ #65;
F8 = #0+ #66;
F9 = #0+ #67;
F10 = #0+ #68;
Pos1 = #0+ #71;
Auf = #0+ #72;
BildAuf = #0+ #73;
Links = #0+ #75;
Rechts = #0+ #77;
Ende = #0+ #79;
Ab = #0+ #80;
BildAb = #0+ #81;
Einfg = #0+ #82;
Entf = #0+ #83;
ShiftF1 = #0+ #84;
ShiftF2 = #0+ #85;
ShiftF3 = #0+ #86;
ShiftF4 = #0+ #87;
ShiftF5 = #0+ #88;
ShiftF6 = #0+ #89;
ShiftF7 = #0+ #90;
ShiftF8 = #0+ #91;
ShiftF9 = #0+ #92;
ShiftF10 = #0+ #93;
CtrlF1 = #0+ #94;
CtrlF2 = #0+ #95;
CtrlF3 = #0+ #96;
CtrlF4 = #0+ #97;
CtrlF5 = #0+ #98;
CtrlF6 = #0+ #99;
CtrlF7 = #0+#100;
CtrlF8 = #0+#101;
CtrlF9 = #0+#102;
CtrlF10 = #0+#103;
AltF1 = #0+#104;
AltF2 = #0+#105;
AltF3 = #0+#106;
AltF4 = #0+#107;
AltF5 = #0+#108;
AltF6 = #0+#109;
AltF7 = #0+#110;
AltF8 = #0+#111;
AltF9 = #0+#112;
AltF10 = #0+#113;
CtrlLinks = #0+#115;
CtrlRechts = #0+#116;
CtrlEnde = #0+#117;
CtrlBildAb = #0+#118;
CtrlPos1 = #0+#119;
Alt1 = #0+#120;
Alt2 = #0+#121;
Alt3 = #0+#122;
Alt4 = #0+#123;
Alt5 = #0+#124;
Alt6 = #0+#125;
Alt7 = #0+#126;
Alt8 = #0+#127;
Alt9 = #0+#128;
Alt0 = #0+#129;
CtrlBildAuf = #0+#132;
F11 = #0+#133;
F12 = #0+#134;
ShiftF11 = #0+#135;
ShiftF12 = #0+#136;
CtrlF11 = #0+#137;
CtrlF12 = #0+#138;
AltF11 = #0+#139;
AltF12 = #0+#140;

Procedure Cursor(Start, Ende : Byte);
{ Strich bis Block }

Function UpCaseX (c : Char) : Char;
Function LowCaseX(c : Char) : Char;
{ auch ""? }

Function IsUpper (c : Char) : Boolean;
Function IsLower (c : Char) : Boolean;
Function IsLetter(c : Char) : Boolean;
Function IsDigit (c : Char) : Boolean;
Function IsHex (c : Char) : Boolean;

Procedure SearchDigit(Var S : String);

Procedure LTrim(Var S : String);
Procedure RTrim(Var S : String);
Procedure Trim (Var S : String);

Function UpperCase(S : String) : String;
Function LowerCase(S : String) : String;

Function NormStr(S : String) : String;
{ zum Sortieren nur 0..9, A..Z }

Function StrNull(L : LongInt; Feld : Integer) : String;
{ z.B. 123 -> 000123 }

Procedure LNull(Var S : String; Feld : Integer);
{ Auff?llen }

Function IntStr (Var S : String; Var I : Integer) : String;
Function WordStr(Var S : String; Var W : Word ) : String;
Function LongStr(Var S : String; Var l : LongInt) : String;
Function RealStr(Var S : String; Var R : Real ) : String;
{ ASCII -> Zahl + Reststring }

Function Rpt(c: Char; Anz : Integer) : String;
{ z.B. '0' -> '00000' }

Function Spc(Anz: Integer): String;
{ ' ' }

Function HexZiff(i : Word ) : Char;
Function HexZahl(i : LongInt) : String;

Procedure WrtLnCentr(S : String);
{ Zentriert in 80 Spalten }

Function DosErrorMsg(Error : Integer) : String;

Implementation

Uses Dos;

Procedure Cursor;
Var Regs : RegIsters;
Begin
Regs.AH := $01;
Regs.CH := Start And $1F;
Regs.CL := Ende And $1F;
Intr($10, Regs);
End;

Function UpCaseX;
Begin
Case c Of
'"': UpCaseX := 'Z';
'"': UpCaseX := 'T';
'?': UpCaseX := 's';
else
UpCaseX := UpCase(c);
End;
End;

Function LowCaseX;
Begin
Case c Of
'Z': LowCaseX := '"';
'T': LowCaseX := '"';
's': LowCaseX := '?';
Else
if (c >= 'A') and (c <= 'Z') Then
LowCaseX := Chr(ord('a') - ord('A') + ord(c))
else
LowCaseX := c;
end;
End;

Function IsUpper;
Begin
IsUpper := ((c >= 'A') And (c <= 'Z')) Or
(c = 'Z') Or
(c = 'T') Or
(c = 's');
End;

Function IsLower;
Begin
IsLower := ((c >= 'a') And (c <= 'z')) Or
(c = '"') Or
(c = '"') Or
(c = '?') Or
(c = 'á');
End;

Function IsLetter;
Begin
IsLetter := IsLower(c) Or IsUpper(c);
End;

Function IsDigit;
Begin
IsDigit := (c >= '0') And (c <= '9');
End;

Function IsHex;
Begin
IsHex := IsDigit(c) Or (c >= 'a') And (c <= 'f')
Or (c >= 'A') And (c <= 'F');
End;

Procedure SearchDigit;
Var n : Integer;
l : Word;
f : Boolean;
c : String;
Begin
n := 1;
l := Length(s);
f := False;
Repeat
If n > l Then
f := True
Else
Begin
If Pos(s[n], '0123456789') = 0 Then
Inc(n)
Else
f := True;
End;
Until f;
s := Copy(s, n, $FF);
End;

Procedure LTrim;
Var n : Integer;
l : Word;
f : Boolean;
Begin
n:=1;
l:=Length(S);
f:=False;
Repeat
If n>l Then
f:=True
Else
If S[n]=' ' Then
Inc(n)
Else
f:=True;
Until f;
S:=Copy(S,n,$FF);
End;

Procedure RTrim;
Var n : Word;
f : Boolean;
Begin
n := Length(S);
f := False;
Repeat
If n = 0 Then
f := True
Else
If S[n] = ' ' Then
Dec(n)
Else
f := True;
Until f;
S := Copy(S, 1, n);
End;

Procedure Trim;
Begin
LTrim(S);
RTrim(S);
End;

Function UpperCase;
Var i : Word;
u : String;
Begin
u := '';
For i := 1 To Length(s) Do
u := u + UpCaseX(s[i]);
UpperCase := u;
End;

Function LowerCase;
Var i : Word;
l : String;
Begin
l := '';
For i:=1 To Length(S) Do
l := l + LowCaseX(S[i]);
LowerCase := l;
End;

Function NormStr;
Var n : String;
i : Integer;
Begin
n := '';
For i := 1 To Length(s) Do
If (s[i] >= '0') And (s[i] <= '9') Or
(s[i] >= 'A') And (s[i] <= 'Z') Then
n := n + s[i]
Else If (s[i] >= 'a') And (s[i] <= 'z') Then
n := n + Chr(Ord(s[i]) - Ord('a') + Ord('A'))
Else
Case s[i] Of
'Z', '"': n := n + 'AE';
'T', '"': n := n + 'OE';
's', '?': n := n + 'UE';
'á': n := n + 'SS';
End;
NormStr := n;
End;

Procedure LNull;
Var c : Char;
Begin
LTrim(S);
c := s[1];
If (c = '+') or (c = '-') Then
S := c + Rpt('0', Feld - Length(S)) + Copy(S, 2, $FF)
Else
S := Rpt('0', Feld - Length(S)) + S;
End;

Function StrNull;
var s : String;
begin
str(l, s);
if Length(s) > Feld Then
StrNull := Rpt('#', Feld)
else
begin
LNull(s, Feld);
StrNull := s;
end;
end;

Function IntStr;
Var n : Integer;
t : String;
Begin
Val(S, i, n);
If n = 0 Then
Begin
IntStr := S;
S := '';
End
Else
Begin
t := Copy(S, 1, Pred(n));
S := Copy(S, n, $FF);
Val(t, i, n);
IntStr := t;
End;
End;

Function WordStr;
Var n : Integer;
t : String;
Begin
Val(S, w, n);
If n = 0 Then
Begin
WordStr := S;
S := '';
End
Else
Begin
t := Copy(S, 1, Pred(n));
S := Copy(S, n, $FF);
Val(t, W, n);
WordStr := t;
End;
End;

Function LongStr;
Var n : Integer;
t : String;
Begin
Val(S, l, n);
If n = 0 Then
Begin
LongStr := S;
S := '';
End
Else
Begin
t := Copy(S, 1, Pred(n));
S := Copy(S, n, $FF);
Val(t, l, n);
LongStr := t;
End;
End;

Function RealStr;
Var n : Integer;
t : String;
Begin
Val(S, r, n);
If n = 0 Then
Begin
RealStr := S;
S := '';
End
Else
Begin
t := Copy(S, 1, Pred(n));
S := Copy(S, n, $FF);
Val(t, r, n);
RealStr := t;
End;
End;

Function Rpt;
Var i : Integer;
s : String;
Begin
s := '';
For i:=1 To Anz Do
s := s+c;
Rpt:=s;
End;

Function Spc;
Begin
Spc := Rpt(' ', Anz);
End;

Function HexZiff;
Const OrdNull = Ord('0');
OrdA10 = Ord('A')-10;
Begin
If i<10 Then
HexZiff:=Chr(i+OrdNull)
Else
HexZiff:=Chr(i+OrdA10 );
End;

Function HexZahl;
Var s : String;
Begin
s := '';
While i <> 0 Do
Begin
s := HexZiff(i And $f) + s;
i := (i shr 4) and $FFFFFFF;
End;
If s = '' Then
s := '0';
HexZahl := s;
End;

Procedure WrtLnCentr;
Begin
WriteLn(Spc((80-Length(S)) Div 2), S);
End;

Function DosErrorMsg;
Begin
DosErrorMsg := '';
Case Error of
2: DosErrorMsg := 'Datei nicht gefunden';
3: DosErrorMsg := 'Pfad nicht gefunden';
4: DosErrorMsg := 'Zu viele offene Dateien';
5: DosErrorMsg := 'Zugriff verweigert';
6: DosErrorMsg := 'Dateikennzahl ung?ltig';
8: DosErrorMsg := 'Nicht gen?gend Hauptspeicher';
10: DosErrorMsg := 'Umgebungsvariable ung?ltig';
11: DosErrorMsg := 'Ung?ltiges Befehlsformat';
12: DosErrorMsg := 'Ung?ltiger Dateimodus';
15: DosErrorMsg := 'Ung?ltiges Laufwerk';
16: DosErrorMsg := 'Kann aktuelles Verzeichnis nicht l"schen';
17: DosErrorMsg := 'Kann Datei nicht auf anderes Laufwerk
verschieben';
18: DosErrorMsg := 'Keine weiteren Dateieintr"ge';
End;
End;

Begin
End.

This is the module ZeitMess.pas :
=======================
Unit ZeitMess;

{
Heinrich Wolf
www.Wolf-Fuerth.de
}

{$N+}

Interface

Uses DOS;

Const BesondereTage = 18; { Special days }
MonatLaenge : Array[1 .. 12] Of Word { length of monthes }
= (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
WochenTagName : Array[1 .. 7] of String { names of week days }
= ('Montag',
'Dienstag',
'Mittwoch',
'Donnerstag',
'Freitag',
'Samstag',
'Sonntag');
MonatName : Array[1 .. 12] of String =
('Januar',
'Februar',
'M"rz',
'April',
'Mai',
'Juni',
'Juli',
'August',
'September',
'Oktober',
'November',
'Dezember');
Type GenaueZeit = Record
GrobeZeit : DateTime;
S100 : Word;
End;
DatumUnion = Record Case Integer of
0: (tag : byte;
monat : byte);
1: (w : word);
End;
BesondererTag = Record
fName : String;
Datum : DatumUnion;
End;

JulianTime = Extended;

var Feiertag : Array[1 .. BesondereTage] of
BesondererTag;

Feiertage : Integer;

Function Laufzeit : LongInt; { 1/100 Sekunden }
Procedure HoleZeit (Var Z : GenaueZeit);
Function JulianischeZeit (Z : GenaueZeit) : JulianTime;
Procedure CheckSchaltjahr (Jahr : Word);
Procedure RechneBesondereTage(Jahr : Integer);
Function CorrectDateTime (Zeit : DateTime) : Boolean;
Function Osteroffset (Jahr : Integer) : Integer;
Function Jahresanfang (Jahr : Integer) : Integer;
Procedure MerkeZeit;
Procedure XDelay (MSec : Word);

{ Folgende Funktionen sind realisiert nach
"Astronomical Formulae for Calculators, third edition"
von Jean Meeus.
}
Function JulianischerTag (Jahr : Integer; Monat: Word; Tag :
JulianTime)
: JulianTime;
{ -4712 <= Jahr < 4000
Monat 1 = Januar bis 12 = Dezember
Tag Bruchteil = Zeit seit Mitternacht
JulianischerTag beginnt mittags
Berechnung g?ltig vor und nach gregorianischem Kalender
4.10.1582 + 1 = 15.10.1582
}
Procedure JulianischesDatum (JD : JulianTime;
var Jahr : Integer;
var Monat : Word;
var Tag : JulianTime);

Function Wochentag (JulianischerTag : JulianTime) : Word;

Implementation

Var Startzeit : JulianTime;

Function JulianischeZeit(Z : GenaueZeit) : JulianTime;
begin
With Z, Z.GrobeZeit do
JulianischeZeit :=
JulianischerTag(Year, Month,
Day + ((((S100 / 100) + Sec) / 60
+ Min) / 60
+ Hour) / 24);
end;

Procedure HoleZeit;
Var W : Word;
Begin
With Z, Z.GrobeZeit Do
Begin
GetTime(Hour, Min, Sec, S100);
GetDate(Year, Month, Day, W );
End;
End;

Procedure CheckSchaltjahr;
Begin
if Jahr > 1582 Then
if (Jahr mod 400 = 0) or (jahr mod 4 = 0) and (jahr mod 100 > 0) then
MonatLaenge[2] := 29
else
MonatLaenge[2] := 28
else
if Jahr mod 4 = 0 then
MonatLaenge[2] := 29
else
MonatLaenge[2] := 28
end;

Function CorrectDateTime;
Begin
CorrectDateTime := True;
With Zeit do
Begin
If (Year < -4712) or (4000 <= Year) then
CorrectDateTime := False
else
begin
CheckSchaltjahr(Year);
If (Month < 1) or (Month > 12) then
CorrectDateTime := False
Else
begin
If (Day < 1) or (Day > MonatLaenge[Month]) Then
CorrectDateTime := False
else
begin
If (Hour < 0) or (Hour > 23) then
CorrectDateTime := False
else
begin
If (Min < 0) or (Min > 59) Then
CorrectDateTime := False
else
If (Sec < 0) or (Sec > 59) Then
CorrectDateTime := False;
end;
end;
end;
end;
End;
End;

Function Laufzeit;
Var Z : GenaueZeit;
Begin
HoleZeit(Z);
Laufzeit := Round((JulianischeZeit(Z) - StartZeit)
* (24 * 60 * 60 * 100));
End;

Procedure MerkeZeit;
var Z : GenaueZeit;
Begin
HoleZeit(Z);
StartZeit := JulianischeZeit(Z);
End;

function OsterOffset;
{
Die Formel ist der Zeitschrift 'Funkschau' entnommen.
Sie ist in Heft 5 des Jahrgangs 1980 auf Seite 77 zu finden und wurde
im Zusammenhang mit einem Programm fuer den Taschenrechner TI 59
veroeffentlicht.
}
const m : array[15 .. 22] of integer =
(22, 22, 23, 23, 24, 24, 24, 25);
n : array[15 .. 22] of integer =
(2, 2, 3, 4, 5, 5, 6, 0);
var jh,
f,
g : integer;
begin
jh := jahr div 100;
f := (19 * (jahr mod 19) + m[jh]) mod 30;
g := f + (2 * (jahr mod 4) + 4 * (jahr mod 7) + 6*f + n[jh]) mod 7;
osteroffset := g;
if g = 35 then
osteroffset := 28;
if (g = 34) and (f = 28) and (jahr mod 19 > 10) then
osteroffset := 27;
end;

function Jahresanfang;
var j : integer;
begin
j := pred(jahr);
jahresanfang := (j * 5 div 4 - (j div 100 + 1) * 3 div 4 ) mod 7;
end;

procedure Eintr(Var Anzahl : Integer;
Tag, Monat : Integer;
Rot : Boolean;
FName : String);
var i, j : Integer;
begin
while tag < 1 do
begin
Dec(Monat);
Inc(Tag, MonatLaenge[Monat]);
end;
while tag > monatlaenge[monat] do
begin
dec(tag, monatlaenge[monat]);
inc(monat);
end;
Inc(Anzahl);
If Rot then
Begin
inc(Feiertage);
j := Pred(Anzahl);
for i := Anzahl downto Succ(Feiertage) do
begin
Feiertag[i] := Feiertag[j];
dec(j);
end;
i := Feiertage;
end
else
i := Anzahl;
Feiertag[i].Datum.Tag := Tag;
Feiertag[i].Datum.Monat := Monat;
Feiertag[i].Fname := FName;
end;

procedure RechneBesondereTage;
var offset,
busstagzahl,
N, t, m : Integer;
begin
offset := osteroffset(jahr);
busstagzahl := jahresanfang(succ(jahr));
Feiertage := 0;
N := 0;
{
Eintr(n, Tag, Monat, Feiertag und nicht immer Sonntag,
Name);
}
Eintr(n, 1, 1, True, 'Neujahr');
Eintr(n, 6, 1, True, 'Heilige drei K"nige');
Eintr(n, -26 + offset, 3, False, 'Rosenmontag');
Eintr(n, 20 + offset, 3, True, 'Karfreitag');
Eintr(n, 22 + offset, 3, False, 'Ostersonntag');
Eintr(n, 23 + offset, 3, True, 'Ostermontag');
Eintr(n, 30 + offset, 4, True, 'Christi Himmelfahrt');
Eintr(n, 1, 5, True, 'Tag der Arbeit');
Eintr(n, 14 - BussTagZahl, 5, False, 'Muttertag');
Eintr(n, 10 + Offset, 5, False, 'Pfingstsonntag');
Eintr(n, 11 + offset, 5, True, 'Pfingstmontag');
Eintr(n, 21 + offset, 5, True, 'Fronleichnam');
Eintr(n, 15, 8, jahr <= 1993, 'Mari" Himmelfahrt');
{-------------------------------------------------------------------}
if (jahr <= 1989) then
begin
t := 17;
m := 6;
end
else
begin
t := 3;
m := 10;
end;
Eintr(n, t, m, True, 'Tag d. deutschen
Einheit');
{-------------------------------------------------------------------}
Eintr(n, 1, 11, True, 'Allerheiligen');
Eintr(n, 22 - BussTagZahl, 11, jahr <= 1994, 'Buá- und Bettag');
Eintr(n, 25, 12, True, '1. Weihnachtsfeiertag');
Eintr(n, 26, 12, True, '2. Weihnachtsfeiertag');
end;

procedure XDelay;
var Z : GenaueZeit;
Start : JulianTime;
begin
HoleZeit(Z);
Start := JulianischeZeit(Z);
Repeat
HoleZeit(Z);
until Round((JulianischeZeit(Z) - Start)
* (24 * 60 * 60 * 1000)) > MSec;
end;

function JulianischerTag;
var y, m : LongInt;
a, b : Integer;
jd,
Datum : JulianTime; { Datum YYYY.MMDD }
begin
Datum := Monat / 100 + Tag / 10000;
if Jahr < 0 then
Datum := Jahr - Datum
else
Datum := Jahr + Datum;
if Monat > 2 then
begin
m := Monat;
y := Jahr;
end
else
begin
m := Monat + 12;
y := Jahr - 1;
end;
jd := y * 365 + y div 4 + 30 * (m + 1) + (6001 * (m + 1)) div 10000 +
Tag
+ 1720994.5;
if Datum >= 1582.1015 then
begin
a := y div 100;
b := 2 - a + a div 4;
jd := jd + b;
end;
JulianischerTag := jd;
end;

Procedure JulianischesDatum;
var Z, Alpha,
A, B, C, D, E : LongInt;
F : JulianTime;
begin
F := JD + 0.5;
Z := trunc(F);
F := F - Z;
if Z < 2299161 then
A := Z
else
begin
Alpha := (4 * Z - 7468865) div 146097
{ trunc((Z - 1867216.25) / 36524.25) };
A := Z + 1 + Alpha - Alpha div 4;
end;
B := A + 1524;
C := (20 * B - 2442) div 7305
{ trunc((B - 122.1) / 365.25) };
D := (C * 1461) div 4
{ trunc(365.25 * C) };
E := ((B - D) * 10000) div 306001;
Tag := B - D - (E * 306001) div 10000 + F;
if E <= 13 { < 13.5 } then
Monat := E - 1
else
Monat := E - 13;
If Monat > 2 { > 2.5 } Then
Jahr := C - 4716
else
Jahr := C - 4715;
end;

Function Wochentag;
begin
WochenTag := Trunc(JulianischerTag + 0.5) mod 7 + 1;
end;

Begin
MerkeZeit;
End.


.

Relevant Pages

  • Re: Evaluate constant parts of expressions in Linq
    ... I have column MyCharColumn of type CHAR in database. ... var q = from p in db.Products ... To fix compile error I changed query to ... How to fix without using temporary string variable? ...
    (microsoft.public.dotnet.languages.csharp)
  • Here is the little thing I wrote
    ... function GetConnectionString(Filename, Password: string): string; ... function Connect: boolean; overload ... TL, QSL: TStringList; ...
    (borland.public.delphi.database.ado)
  • Re: Ist das ein Array, oder was ist das?
    ... function CheckForMyStrings(Str: string): boolean; ... var x: integer; ...
    (de.comp.lang.delphi.misc)
  • Re: Bit mapped Set Theory
    ... komma: boolean; ... L,R: string; ... if blah then Writeln; ...
    (sci.math)
  • Two new tests for MM B&V
    ... var RunningThreads: Integer; ... class function TStringThreadTest.GetBenchmarkDescription: string; ... function CheckPattern(const Dest: Pointer; const Size: Integer; const ...
    (borland.public.delphi.language.basm)
Loading