Type
complex = record
re:double;
im:double;
end;
type aoc=array of complex;
var decplaces:integer=7;
Function ccos(x:complex):complex;Cdecl external 'ucrtbase.dll' name 'ccos'; //cosine
Function csin(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'csin'; //sine
Function ctan(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'ctan'; //tan
Function clog(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'clog'; //log bese e
Function clog10(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'clog10'; //log base 10
Function carccos(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'cacos'; //arc cosine
Function carcsin(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'casin'; //arc sine
Function carctan(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'catan'; //arc tan
Function cexp(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'cexp'; //exp
Function cabs(x:complex):double; Cdecl external 'ucrtbase.dll' name 'cabs'; // absolute (modulus)
Function cpow(x:complex;p:complex):complex; Cdecl external 'ucrtbase.dll' name 'cpow'; //power
Function csqrt(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'csqrt'; //square root
Function conj(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'conj'; // conjugate
Function carg(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'carg'; // argument (phase angle)
Function cimag(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'cimag'; // imaginary part
Function creal(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'creal'; // real part
Function cproj(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'cproj'; // projection onto the Riemann sphere
Function ccosh(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'ccosh'; // hyperbolic cosine
Function csinh(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'csinh'; // hyperbolic sine
Function ctanh(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'ctanh'; // hyperbolic tan
Function carccosh(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'cacosh'; // inverse hyperbolic cosine
Function carcsinh(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'casinh'; // inverse hyperbolic sine
Function carctanh(x:complex):complex; Cdecl external 'ucrtbase.dll' name 'catanh'; // inverse hyperbolic tan
function sprintf(s:pchar;mask:pchar):integer; cdecl; varargs; external 'msvcrt.dll' name 'sprintf';
function pow(x:double;p:double):double;Cdecl external 'ucrtbase.dll' name 'pow'; //power(doubles)
function atan2(x:double;y:double):double;Cdecl external 'ucrtbase.dll' name 'atan2';
operator + (n1:complex;n2:complex) t :complex;
begin
t.re:= n1.re+n2.re;
t.im:= n1.im+n2.im;
exit(t);
end ;
operator -(n1:complex;n2:complex) t:complex;
begin
t.re:= n1.re-n2.re;
t.im:= n1.im-n2.im;
exit(t);
end;
operator *(n1:complex;n2:complex) t:complex;
begin
t.re:= n1.re*n2.re - n1.im*n2.im;
t.im:= n1.im*n2.re + n1.re*n2.im;
exit(t);
end;
operator /(n1:complex;n2:complex) t:complex;
var
d:double;
begin
d:= n2.re*n2.re+n2.im*n2.im;
t.re:= (n1.re*n2.re+n1.im*n2.im)/d;
t.im:= (n1.im*n2.re - n1.re*n2.im)/d;
exit(t);
end;
operator ** (n1:complex;n2:complex) t:complex;
begin
exit (cpow(n1,n2));
end;
operator **(n1:double;n2:double) t:double;
begin
exit(pow(n1,n2));
end;
function CX(const x,y:double):complex;
var
c:complex;
begin
c.re:=x;c.im:=y;
exit(c)
end;
function GetRoots(N:complex;numroots:Integer;var a:aoc):boolean;
Function Root(Z:Complex;N:Integer;k :Integer):Complex;
var
p:complex;
begin
If ((N <= 0) Or (K < 0) Or (K >= N)) Then exit (CX(0,0));
If ((cabs(Z)**(1/N))=0) Or ((cabs(Z)**(1/N))<0) Then exit (CX(0,0));
p.re:=(cabs(Z)**(1/N))*cos(((atan2(Z.im,z.re)+K*6.283185307179586)/N));
p.im:=(cabs(Z)**(1/N))*sin(((atan2(Z.im,z.re)+K*6.283185307179586)/N));
exit(p);
End;
var
check:complex;
counter:integer;
tolerance:double;
begin
tolerance:=cabs(n)/100;
if (numroots mod 2=0) then check:=CX(-1,0);
if (numroots mod 2=1) then check:=CX(1,0);
setlength(a,numroots);
For counter:=0 To numroots-1 do
begin
a[counter]:=root(n,numroots,counter);
check:=check*a[counter];
end;
if abs(cabs(check)-cabs(N))<tolerance then exit(true);
exit(false);
End;
Function CRound(x:Double;precision:Integer):String;
var
z:string[40];
s,ab:ansistring;
ss:pchar;
t:word=0;
d:double;
begin
str(precision,ab);
s:='%.'+ab+'f';
ss:=@z[1];
If (precision>30) Then precision:=30;
sprintf(ss,pchar(s),x);
val(ss,d,t);
if(d=0) or (ss='') then ss:='0';
exit(ss);
End;
procedure print(c:complex);
var
gap,sr:string;
begin
sr:=cround(c.re,decplaces);
gap:=StringOfChar(' ',(decplaces+15)-length(sr));
writeln(cround(c.re,decplaces),gap,cround(c.im,decplaces),'*i');
end;
var
pi:double=3.141592653589793;
ac:aoc=nil;
bool:boolean;
c1,c2:complex;
j:integer;
begin
randomize;
decplaces:=5;
writeln('Euler''s formula -- e^(i*pi) + 1 =0 ');
print(cexp(CX(0,1)*CX(pi,0))+CX(1,0));
writeln;
writeln('cos(x)^2 +sin(x)^2 = 1');
print((ccos(cx(-7,5))**cx(2,0))+(csin(cx(-7,5))**cx(2,0)));
writeln;
writeln('cosh(x)^2 -sinh(x)^2 = 1');
print((ccosh(cx(-7,5))**cx(2,0))-(csinh(cx(-7,5))**cx(2,0)));
writeln;
bool:=GetRoots(CX(1,0),3,ac);
writeln('cube roots of unity');
if bool then
begin
for j:=0 to high(ac) do
begin
write('root ',j+1,' = ');
print(ac[j]);
end;
end;
writeln;
write('i^i = ');
print(CX(0,1)**CX(0,1));
c1:=CX(random*10-random*10,random*10-random*10);
c2:=c1**CX(7,0);
write('Random number = ');
print(c1);
write('Random number^7 = ');
print(c2);
write('Seven roots of ');print(c2);
bool:=GetRoots(c2,7,ac);
if bool then
begin
for j:=0 to high(ac) do
begin
write('root ',j+1,' = ');
print(ac[j]);
end;
end;
writeln('Press return to finish . . .');
readln;
end.
Recent
