Паскаль / do11 / tmtp390d / SOURCE / compmath

(****************************************************************)
(* *)
(* TMT Pascal 3.90 Runtime Library *)
(* Complex Mathematics Unit *)
(* Targets: OS/2, MS-DOS, Win32 *)
(* *)
(* Copyright (c) 1995, 2002 TMT Development Corporation *)
(* Authors: Anton Moscal, Vadim Bodrov, David Ebin *)
(* *)
(****************************************************************)

{$i-,r-,a+,p+,t-,x+,b-,cc+,q-,v+,s-}

unit CompMath;

interface

type
CReal = Extended;

type Complex = record
re, im: CReal
end;
TComplex = Complex;

function Compl_RR(const re, im: CReal): Complex;
overload Complex = Compl_RR;
function Compl_R(const re: CReal): Complex;
overload Complex = Compl_R;

function add_cc(const a: Complex; const b: Complex): Complex;
overload + = add_cc;
function add_cr(const a: Complex; const b: CReal): Complex;
overload + = add_cr;
function add_rc(const a: CReal; const b: Complex): Complex;
overload + = add_rc;
function sub_cc(const a: Complex; const b: Complex): Complex;
overload - = sub_cc;
function sub_cr(const a: Complex; const b: CReal): Complex;
overload - = sub_cr;
function sub_rc(const a: CReal; const b: Complex): Complex;
overload - = sub_rc;
function mul_cc(const a: Complex; const b: Complex): Complex;
overload * = mul_cc;
function mul_cr(const a: Complex; const b: CReal): Complex;
overload * = mul_cr;
function mul_rc(const a: CReal; const b: Complex): Complex;
overload * = mul_rc;
function div_cc(const a: Complex; const b: Complex): Complex;
overload / = div_cc;
function div_cr(const a: Complex; const b: CReal): Complex;
overload / = div_cr;
function div_rc(const a: CReal; const b: Complex): Complex;
overload / = div_rc;

procedure addab_cc(var a: Complex; const b: Complex);
overload +:= = addab_cc;
procedure addab_cr(var a: Complex; const b: CReal);
overload +:= = addab_cr;
procedure subab_cc(var a: Complex; const b: Complex);
overload -:= = subab_cc;
procedure subab_cr(var a: Complex; const b: CReal);
overload -:= = subab_cr;
procedure mulab_cc(var a: Complex; const b: Complex);
overload *:= = mulab_cc;
procedure mulab_cr(var a: Complex; const b: CReal);
overload *:= = mulab_cr;
procedure divab_cc(var a: Complex; const b: Complex);
overload /:= = divab_cc;
procedure divab_cr(var a: Complex; const b: CReal);
overload /:= = divab_cr;

function eq_cc(const a: Complex; const b: Complex): Boolean;
overload = = eq_cc;
function eq_cr(const a: Complex; const b: CReal): Boolean;
overload = = eq_cr;
function eq_rc(const a: CReal; const b: Complex): Boolean;
overload = = eq_rc;
function ne_cc(const a: Complex; const b: Complex): Boolean;
overload <> = ne_cc;
function ne_cr(const a: Complex; const b: CReal): Boolean;
overload <> = ne_cr;
function ne_rc(const a: CReal; const b: Complex): Boolean;
overload <> = ne_rc;

function Conj(const z: Complex): Complex;
function Arg(const a: Complex): CReal;
function Polar(const rho: CReal; const theta: CReal): Complex;

function abs_cc(const a: Complex): CReal;
overload Abs = abs_cc;
function sqr_cc(const a: Complex): Complex;
overload Sqr = sqr_cc;
function sqrt_cc(const a: Complex): Complex;
overload Sqrt = sqrt_cc;
function ln_cc(const a: Complex): Complex;
overload Ln = ln_cc;
function exp_cc(const a: Complex): Complex;
overload Exp = exp_cc;

function power_cc(const a: Complex; const b: Complex): Complex;
overload Power = power_cc;
function power_cr(const a: Complex; const b: CReal): Complex;
overload Power = power_cr;
function power_rc(const a: CREal; const b: Complex): Complex;
overload Power = power_rc;

function sin_cc(const a: Complex): Complex;
overload Sin = sin_cc;
function sinh_cc(const a: Complex): Complex;
overload SinH = sinh_cc;
function cos_cc(const a: Complex): Complex;
overload Cos = cos_cc;
function cosh_cc(const a: Complex): Complex;
overload CosH = cosh_cc;
function tan_cc(const a: Complex): Complex;
overload Tan = tan_cc;
function tanh_cc(const a: Complex): Complex;
overload TanH = tanh_cc;
function cotan_cc(const a: Complex): Complex;
overload Cotan = cotan_cc;
function cotanh_cc(const a: Complex): Complex;
overload CotanH = cotanh_cc;
function arcsin_cc(const a: Complex): Complex;
overload ArcSin = arcsin_cc;
function arcsinh_cc(const a: Complex): Complex;
overload ArcSinH = arcsinh_cc;
function arccos_cc(const a: Complex): Complex;
overload ArcCos = arccos_cc;
function arccosh_cc(const a: Complex): Complex;
overload ArcCosH = arccosh_cc;
function arctan_cc(const a: Complex): Complex;
overload ArcTan = arctan_cc;
function arctanh_cc(const a: Complex): Complex;
overload ArcTanH = arctanh_cc;

procedure __writer(var f: Text; const value: Complex; w: Integer);
procedure __reader(var f: text; var result: Complex);

implementation

uses Math, ErrCodes, Strings;

function Compl_RR;
begin
Result.re := re;
Result.im := im
end;

function Compl_R;
begin
Result.re := re;
Result.im := 0
end;

function add_cc;
with Result do
begin
re := b.re + a.re;
im := a.im + b.im
end;

function add_cr;
with Result do
begin
re := b + a.re;
im := a.im;
end;

function add_rc;
with Result do
begin
re := a + b.re;
im := b.im;
end;

function sub_cc;
with Result do
begin
re := a.re - b.re;
im := a.im - b.im
end;

function sub_cr;
with Result do
begin
re := a.re - b;
im := a.im;
end;

function sub_rc;
with Result do
begin
re := a - b.re;
im := - b.im;
end;

function mul_cc;
with Result do
begin
re := a.re * b.re - a.im * b.im;
im := a.re * b.im + a.im * b.re
end;

function mul_cr;
with Result do
begin
re := b * a.re;
im := b * a.im;
end;

function mul_rc;
with Result do
begin
re := a * b.re;
im := a * b.im;
end;

function div_cc;
var
x: CReal;
begin
x := sqr(b.re) + sqr(b.im);
with Result do begin
re := (a.re * b.re + a.im * b.im) / x;
im := (a.im * b.re - a.re * b.im) / x;
end;
end;

function div_cr;
with Result do
begin
re := b / a.re;
im := b / a.im;
end;

function div_rc;
with Result do
begin
re := a / b.re;
im := a / b.im;
end;

procedure addab_cc;
with a do begin
re +:= b.re;
im +:= b.im
end;

procedure addab_cr;
begin
a.re +:= b;
end;

procedure subab_cc;
with a do begin
re -:= b.re;
im -:= b.im
end;

procedure subab_cr;
begin
a.re -:= b;
end;

procedure mulab_cc;
var
c: Complex;
with c do
begin
re := a.re * b.re - a.im * b.im;
im := a.re * b.im + a.im * b.re;
a := c
end;

procedure mulab_cr;
with a do
begin
re *:= b;
im *:= b;
end;

procedure divab_cc;
var
c: Complex;
x: CReal;
begin
x := sqr(b.re) + sqr(b.im);
with c do
begin
re := (a.re * b.re + a.im * b.im) / x;
im := (a.im * b.re - a.re * b.im) / x;
end;
a := c
end;

procedure divab_cr;
with a do
begin
re /:= b;
im /:= b;
end;

function eq_cc;
begin
Result := (a.re = b.re) and (a.im = b.im);
end;

function eq_cr;
begin
Result := (a.re = b) and (a.im = 0);
end;

function eq_rc;
begin
Result := (a = b.re) and (b.im = 0);
end;

function ne_cc;
begin
Result := (a.re <> b.re) or (a.im <> b.im);
end;

function ne_cr;
begin
Result := (a.re <> b) OR (a.im <> 0);
end;

function ne_rc;
begin
Result := (a <> b.re) or (b.im <> 0);
end;

function Conj;
with Result do
begin
re := z.re;
im :=-z.im
end;

function Arg(const a: Complex): CReal;
begin
Result := ArcTan2(a.im, a.re);
end;

function Polar(const rho: CReal; const theta: CReal): Complex;
begin
Result := Complex(rho * cos(theta), rho * sin(theta));
end;

function abs_cc(const a: Complex): CReal;
begin
Result := Hypot(a.re, a.im);
end;

function sqr_cc;
with Result do
begin
re := sqr(a.re) - sqr(a.im);
im := 2 * a.re * a.im;
end;

function sqrt_cc;
var
r: CReal := abs_cc(a);
begin
if r = 0.0 then
begin
Result.re := r;
Result.im := r;
end else
if a.re > 0 then
begin
Result.re := Sqrt(0.5 * (r + a.re));
Result.im := a.im / Result.re / 2;
end else
begin
Result.im := Sqrt(0.5 * (r - a.re));
if a.im < 0 then
Result.im := - Result.im;
Result.re := a.im / Result.im / 2;
end;
end;

function ln_cc;
with Result do
begin
im := ArcTan2(a.im, a.re);
re := Ln(Hypot(a.re, a.im));
end;

function exp_cc;
begin
Result := Polar((Exp(a.re)), a.im);
end;

function power_cc;
var
lnr: CReal := Ln(Abs(a));
t: CReal := ArcTan2(a.im, a.re);
begin
Result := Polar(Exp(lnr * b.re - b.im * t), b.im * lnr + b.re * t);
end;

function power_cr;
begin
Result := Exp(b * Ln(a));
end;

function power_rc;
begin
Result := Exp(b * Ln(a));
end;

function sin_cc;
begin
Result := Complex(Sin(a.re) * CosH(a.im), Cos(a.re) * SinH(a.im));
end;

function sinh_cc;
begin
Result := Complex(SinH(a.re) * Cos(a.im), CosH(a.re) * Sin(a.im));
end;

function cos_cc;
begin
Result := Complex(Cos(a.re) * CosH(a.im), - Sin(a.re) * SinH(a.im));
end;

function cosh_cc;
begin
Result := Complex(CosH(a.re) * Cos(a.im), SinH(a.re) * Sin(a.im));
end;

function tan_cc;
begin
Result := Sin(a) / Cos(a);
end;

function tanh_cc;
begin
Result := SinH(a) / CosH(a);
end;

function cotan_cc;
begin
Result := Cos(a) / Sin(a);
end;

function cotanh_cc;
begin
Result := CosH(a) / SinH(a);
end;

function alphabeta(a: Complex): Complex;
begin
Result.re := Sqrt(Sqr(a.re + 1) + Sqr(a.im)) / 2 + Sqrt(Sqr(a.re - 1) + Sqr(a.im)) / 2;
Result.im := Sqrt(Sqr(a.re + 1) + Sqr(a.im)) / 2 - Sqrt(Sqr(a.re - 1) + Sqr(a.im)) / 2;
end;

function arccos_cc;
var
ab: Complex := alphabeta(a);
begin
Result := Complex(ArcCos(ab.im), -Ln(ab.re + Sqrt(Sqr(ab.re) - 1)));
end;

function arccosh_cc;
begin
Result := Ln(a + Sqrt(Sqr(a) - 1));
end;

function arcsin_cc;
var
ab: Complex := alphabeta(a);
begin
Result := Complex(ArcSin(ab.im), Ln(ab.re + Sqrt(Sqr(ab.re) - 1)));
end;

function arcsinh_cc;
begin
Result := Ln(a + Sqrt(Sqr(a) + 1));
end;

function arctan_cc;
begin
Result := Complex(ArcTan(2 * a.re / (1 - Sqr(a.re) - Sqr(a.im))) / 2, Ln((Sqr(a.re) + Sqr(a.im + 1)) / (Sqr(a.re) + Sqr(a.im - 1))) / 4);
end;

function arctanh_cc;
begin
Result := Ln((a + 1) / (1 - a));
end;

procedure __writer(var f: Text; const value: Complex; w: Integer);
begin
Write(f, '(', FloatToStr(value.re), ',', FloatToStr(value.im), ')');
end;

procedure __reader(var f: text; var result: Complex);
var
l, i: Integer;
im, re: String := '';
s: String;
flg: Boolean := FALSE;
begin
Read(f, s);
s := LowerCase(Trim(s));
l := Length(s);
if (l > 2) and (s[1] = '(') then
begin
for i := 2 to l do
begin
if not flg and (s[i] = ',') then
flg := TRUE
else
if s[i] in ['+', '-', '.', '0'..'9', 'e'] then
begin
if flg then
im := im + s[i]
else
re := re + s[i]
end else
if s[i] <> ' ' then
Break;
end;
end;
Val(re, Result.re, i);
if i <> 0 then RunError(invalid_numeric_format);
Val(im, Result.im, i);
end;

end.