{
DISCLAIMER
--
-- This software ( or any part of it ) is neither
-- commercial nor distributed product of any kind.
It is strictly self - educational and subject to
change/modification/canceling at any time.
-- Therefore the author doesn't guarantee anything and is
-- not responsible for anything in any situation involving it
-- unauthorised use .
--
}
Program MGX;
{$MODE OBJFPC}
(*)
{$if FPC_FULLVERSION < 30101}
{$ERROR this demo needs version 3.1.1}
{$endif}
(*)
{$I+} // exceptions
{$M+}
{$I+} // exceptions
{$goto on}
{$define FLAG_EXT_1}
{$define LAST_TEST_ONLY}
//{$define FLAG_TSTX_ON}
//{$define FLAG_TH2_ON}
USES
{$ifdef unix} cthreads,{#else} Classes, {$endif}
crt, math,sysutils,ucomplex,dateUtils, fgl, process;
// familiarize the compiler with symbols
// that are meant as 'goto' targets
// {$define test_1}
const n_sz = 4;
const el = #10;
const tab = #9;
threadvar xthv : Integer;
type
Ex = Extended; IT = Integer;
Cx = complex; LI = LongInt;
DB = double; ST = string;
Cxp = ^Cx;
MF = array of array of cx;
MFp= ^MF;
IX = 1..n_sz;
VTc = array [IX] of CX;
MTc = array [IX] of VTc;
PVc = ^VTc; PMc = ^MTc;
type
TMyThread = class(TThread)
procedure Execute; override;
end;
type
TMyThread2 = class(TMyThread)
procedure Execute; override;
end;
type
TMyThread3 = class(TMyThread)
procedure Execute; override;
end;
var cs : TRTLCRITICALSECTION;
cs2 : TRTLCRITICALSECTION;
{--------------------------------------------------------------------}
type
iobject = interface
['{912AC5B9-4595-46D5-B871-AFB840763116}']
procedure change(i:longint);
procedure show();
function fx() : longint;
procedure px(k : longint; l : longint; j : longint);
end;
tobject = class(tinterfacedobject,iobject)
public
procedure change(i:longint);inline; // never inlined
procedure show();
function fx() : longint;
private
procedure px(k : longint; l : Longint; j : longint);
private
data: longint;
end;
procedure tobject.change(i:longint);
begin
data:= i;
end;
procedure tobject.show();
begin
writeln(' interface data = ',data);
writeln();
end;
Function tobject.fx() : longint;
begin
fx :=data;
end;
type
IFS = class
class procedure run();
end;
procedure tobject.px(k : longint; l : Longint; j : longint);
begin
write('( ',k:2,' => ',l:2,' ) ');
if j mod 6 = 0 then
writeln();
end;
class procedure IFS.run();
var
iobj: iobject;
tobj: tobject;
k : longint = 16;
i : longint;
type
UX = 1..24;
var
j : UX;
begin
tobj:= tobject.create;
iobj:= tobj as iobject;
writeln(' running interface test...');
writeln(' ...setting iobj to k = ',k);
iobj.change(16);
writeln(' ...retrieving the k value from tobj... = ',tobj.fx);
tobj.show();
for j in UX do
begin
k:=Random(100);
iobj.change(k);
iobj.px(k,tobj.fx,j);
end;
writeln();
for j in UX do
begin
k:=Random(100);
tobj.change(k);
tobj.px(k,iobj.fx,j);
end;
writeln;
end;
{--------------------------------------------------------------------}
type
TSS = class (TObject)
private
const sz = 128;
public
class var arr : array[1..sz] of String ;
Value : IT;
public
class var s : LI;
private
class var csn : TRTLCRITICALSECTION;
public
class constructor Create();
class destructor Destroy();
class procedure ads(h : String);
class procedure lst();
private
class procedure fs(E : exception);
end;
class procedure TSS.fs(E : exception);
begin
writeln('det >>> ', E.ClassName, '/', E.Message);
end;
class constructor TSS.Create();
begin
s := 0;
arr[0]:=el+' Initial "Create() ';
writeln('Thred pool size = '+IntToStr(sz));
end;
class destructor TSS.Destroy();
const s1 = ' Total number spawned threads s = ';
s2 = ' The string list now has Length = ';
begin
lst();
writeln(s1,s);
try
writeln(s2, Length(Arr));
except
on E: exception do fs(E);
end;
end;
class procedure TSS.lst();
var i : IT; t : AnsiString='';
begin
InitCriticalSection(csn);
EnterCriticalSection(csn);
for i:=0 to s do
t+=arr[i]+el;
LeaveCriticalSection(csn);
DoneCriticalSection(csn);
writeln(t);
end;
class procedure TSS.ads(h : String);
begin
try
if s>=sz then
begin
writeln('size error.');
exit;
end;
s:=s+1;
InitCriticalSection(csn);
EnterCriticalSection(csn);
arr[s]:=h;
LeaveCriticalSection(csn);
DoneCriticalSection(csn);
except
on E: exception do fs(E);
end;
end;
type
THCL = class
public
class function hd(k : byte; id : TThreadID) : string;
end;
class function THCL.hd(k : byte; id : TThreadID) : string;
var p : ^string; s : string;
begin
TSS.ads(format(tab+'%d',[id]));
hd := 'Hi!, I am MyThread'+format('%d:',[k]);
end;
type
IO_X = class
public
class procedure scr(s : string);
class procedure scr(s : AnsiString);
end;
class procedure IO_X.scr(s : string);
begin
InitCriticalSection(cs2);
EnterCriticalSection(cs2);
writeln(s);
LeaveCriticalSection(cs2);
DoneCriticalSection(cs2);
end;
class procedure IO_X.scr(s : AnsiString);
begin
InitCriticalSection(cs2);
EnterCriticalSection(cs2);
writeln(s);
LeaveCriticalSection(cs2);
DoneCriticalSection(cs2);
end;
procedure wl();
begin writeln(); end;
procedure hdr( s : string);
var i : IT;
begin
for i:=1 to 72 do
write('-');
writeln();
writeln(' >>>>>> '+s);
for i:=1 to 72 do
write('-');
writeln();
end;
procedure mulc(x,y,z:PMc);
var i,j,k : IX;
begin
for i in IX do
for j in IX do
begin
z^[i][j]:=0.0+0.0*i;
for k in IX do
z^[i][j]+=x^[i][k]*y^[k][j];
end
end;
function trns(p : PMc) : MTc;
var i,j : IX; c : Cx; r : MTc;
begin
r := p^;
for i in IX do
for j in IX do
if(j<i) then
begin
c:=r[i][j];
r[i][j] := r[j][i];
r[j][i]:=c;
end;
trns := r;
end;
operator + (x : MTc; y : MTc) z : MTc;
var i,j : IX;
begin
for i in IX do
for j in IX do
z[i][j]:=x[i][j]+y[i][j];
end;
operator - (x : MTc; y : MTc) z : MTc;
var i,j : IX;
begin
for i in IX do
for j in IX do
z[i][j]:=x[i][j]-y[i][j];
end;
operator * (x : MTc; y : MTc) z : MTc;
var i,j,k : IX;
begin
for i in IX do
for j in IX do
begin
z[i][j]:=0.0+0.0*i;
for k in IX do
z[i][j]+=x[i][k]*y[k][j];
end
end;
procedure TDM();
var
year, month, day, hr, min, sec, ms: Word;
begin
DecodeDate(Date,year,month,day);
writeln();
write(' Today is ',LongDayNames[DayOfWeek(Date)]);
DecodeTime(Time,hr, min, sec, ms);
hr-=8;
writeln(Format(' %d-%d-%d %d:%d:%d.%d',
[day,month,year,hr,min,sec,ms]));
end;
type
WRT = class
private
const fx = '%4s [%10.5g %10.5g]'; fy = '[%4.1f %4.1 ]';
fr = '%4s [ %10.5g %10.5g ] ';
fs = '%4s [%12.5g %12.5g]';
public
class procedure wr(s : ST; c : CX);
class procedure wrd(s,t : ST; c,d : CX);
class procedure wr2(s,t: ST; c,d : CX);
end;
class procedure WRT.wr(s : ST; c : CX);
begin writeln(format(fr,[s,c.re,c.im])); end;
class procedure WRT.wrd(s,t : ST; c,d : CX);
begin
write(format(fs,[s,c.re,c.im]));
write(format(fs,[t,c.re,c.im]));
writeln();
end;
class procedure WRT.wr2(s,t : ST; c,d : CX);
var r : CX;
begin
r:=c+d;
writeln(format(fx,[s,c.re,c.im])+
format(fx,[t,d.re,d.im])+
format(fy,[r.re,r.im]));
end;
type
DTS = class
public
type EN = (EN_RND, EN_RND_05, EN_RND_05_SYM);
class function crx() : Cx;
class procedure load_rnd_05(p : PMc);
class procedure load_rnd_05_sym(p : PMc);
class procedure load_rnd(p : PMc);
class procedure load(p : PMc; r : EN);
class procedure load_q(p : PMc);
class procedure load_0(p : PMc);
class procedure load_1(p : PMc);
class procedure load_i(p : PMc);
class procedure load_j(p : PMc);
class procedure load_k(p : PMc);
end;
class function DTS.crx() : Cx;
begin crx:=Random() + Random()*I; end;
class procedure DTS.load_rnd(p : PMc);
var i,j : IX;
begin
for i in IX do for j in IX do
p^[i][j]:=crx();
end;
class procedure DTS.load_rnd_05(p : PMc);
var i,j : IX; q : CXp;
begin
for i in IX do for j in IX do
begin
q:=@p^[i][j];
q^:=crx();
q^.re-=0.5;
q^.im-=0.5;
end;
end;
class procedure DTS.load_q(p : PMc);
var i,j : IX; q : CXp; c : Cx; il,ih : IX;
begin
il :=Low(IX); ih := High(IX);
c := crx();
for i in IX do
p^[i][i]:=c;
c := crx();
p^[1][2] := c;
p^[3][4] := c;
p^[2][1] := -c;
p^[4][3] := -c;
c := crx();
p^[1][3] := c;
p^[2][4] := c;
p^[3][1] := -c;
p^[4][2] := -c;
c := crx();
p^[1][4] := c;
p^[4][1] := c;
p^[2][3] := -c;
p^[3][2] := -c;
end;
class procedure DTS.load_0(p : PMc);
var i,j : IX;
begin
for i in IX do
for j in IX do
p^[i][j]:=0.0;
end;
class procedure DTS.load_1(p : PMc);
var i : IX;
begin
load_0(p);
for i in IX do
p^[i][i]:=1.0;
end;
class procedure DTS.load_i(p : PMc);
const
c = 1.0;
begin
load_0(p);
p^[2][1] := c;
p^[4][3] := c;
p^[1][2] := -c;
p^[3][4] := -c;
end;
class procedure DTS.load_j(p : PMc);
const
c = 1.0;
begin
load_0(p);
p^[3][1] := c;
p^[4][2] := c;
p^[1][3] := -c;
p^[2][4] := -c;
end;
class procedure DTS.load_k(p : PMc);
const
c = 1.0;
begin
load_0(p);
p^[4][1] := c;
p^[1][4] := c;
p^[3][2] := -c;
p^[2][3] := -c;
end;
class procedure DTS.load_rnd_05_sym(p : PMc);
var i,j : IX; q : CXp;
begin
for i in IX do for j in IX do
begin
q:=@p^[i][j];
if i<=j then
begin
q^:=crx();
q^.re-=0.5;
q^.im-=0.5;
end
else
begin
q^.re:=-p^[j][i].re;
q^.im:=-p^[j][i].im;
end;
end;
end;
class procedure DTS.load(p : PMc; r : EN);
begin
case r of
EN_RND : load_rnd(p);
EN_RND_05 : load_rnd_05(p);
EN_RND_05_SYM : load_rnd_05_sym(p);
end;
end;
Type
PRT = class(TObject)
public
type T_FM = (FMT_F,FMT_G,FMT_E);
class procedure prc(t : string; p : PMc) virtual abstract;
class procedure prc(t : string; p : PMc; f : T_FM);
class function prc(p : PMc; f : T_FM) : AnsiString;
class function prcx(p : PMc; f : PRT.T_FM) : AnsiString;
class function prcx(p : PMc) : AnsiString;
class function prcx(p : PMc; v : PMc) : AnsiString;
class function prcx(h1 : string; p : PMc; h2 : string; v : PMc) : AnsiString;
class function fn1(q : PVc; f1 : AnsiString) : AnsiString;
class procedure prc2(x,y : Cx);
class var prcx_fm : string;
class constructor Create();
end;
class Constructor PRT.Create();
begin
PRT.prcx_fm := '[ %2.0f, %2.0f ]';
IO_X.scr('PRT.prcx initialized with [ %2.0f, %2.0f ] ');
end;
class procedure PRT.prc2(x,y : Cx);
const
fm = ' deter re,im = [ %15.9g, %15.9g ] ';
fm2 = ' trace re,im = [ %15.9g, %15.9g ] ';
begin
writeln(format(fm,[x.re,x.im]));
writeln(format(fm2,[y.re,y.im]));
write(#10);
end;
class function PRT.prc(p : PMc; f : PRT.T_FM) : AnsiString;
var
f1 : AnsiString =' [ %15.10g, %15.10g ] ';
f2 : AnsiString =' [ %15.6e, %15.6e ] ';
f3 : AnsiString =' [ %15.10f, %15.10f ] ';
var i,j,k : LongInt; s:AnsiString =''; c : CX;
z : ^AnsiString; l : Integer;
t : AnsiString = '';
begin
case f of FMT_F: z:=@f3; FMT_G: z:=@f1; FMT_E: z:=@f2; end;
t := '';
for i in IX do
begin
l:=0; s:='';
for j in IX do
begin
c:= p^[i][j];
s:=s + format(z^,[c.re,c.im]);
l:=l+1;
if (l=2) then
begin
t:=t+s+#10; l:=0; s:='';
end
end;
end;
prc:=t;
end;
class function PRT.prcx(p : PMc; f : PRT.T_FM) : AnsiString;
const c1 = ' 1 ='; c2 = ' i =';
c3 = ' J ='; c4 = ' K =';
var
f1 : AnsiString =' [ %15.10g, %15.10g ] ';
f2 : AnsiString =' [ %15.6e, %15.6e ] ';
f3 : AnsiString =' [ %15.10f, %15.10f ] ';
f4 : Ansistring =' [ %6.3f, %6.3f ][ %6.3f, %6.3f ][ %6.3f, %6.3f ][ %6.3f, %6.3f ] ';
i,j,k : LongInt; s:AnsiString =''; c : CX;
z : ^AnsiString; l : Integer;
t : AnsiString = '';
begin
k := Length(p^);
// writeln(format(' matrix: %4d X%2d, printing 5 only ',[k,k]));
// writeln(t);
case f of FMT_F: z:=@f3; FMT_G: z:=@f1; FMT_E: z:=@f2; end;
t := '';
t := c1+format(f4,[p^[1][1].re, p^[1][1].im,
p^[2][2].re, p^[2][2].im,
p^[3][3].re, p^[3][3].im,
p^[4][4].re, p^[4][4].im]) + el +
c2+format(f4,[p^[1][2].re, p^[1][2].im,
p^[3][4].re, p^[3][4].im,
p^[2][1].re, p^[2][1].im,
p^[4][3].re, p^[4][3].im])+ el+
C3+ format(f4,[p^[1][3].re, p^[1][3].im,
p^[2][4].re, p^[2][4].im,
p^[3][1].re, p^[3][1].im,
p^[4][2].re, p^[4][2].im]) + el+
C4+format(f4,[p^[1][4].re, p^[1][4].im,
p^[4][1].re, p^[4][1].im,
p^[2][3].re, p^[2][3].im,
p^[3][2].re, p^[3][2].im]) + el;
prcx:=t;
end;
class function PRT.fn1(q : PVc; f1 : AnsiString)
: AnsiString;
var c,d : CXp;
t : AnsiString = '';
begin
c := @q[low(VTc)-1];
d := c + high(VTc);
while (c<d) do
begin
t+=format(f1,[c^.re,c^.im]);
inc(c);
end;
fn1:=t;
end;
class function PRT.prcx(p : PMc) : AnsiString;
var
f1 : AnsiString;
var
t : AnsiString = ''; i,j : IX;
q : PVc; c,d : CXp;
begin
f1:=prcx_fm;
t := '';
for i in IX do
t+=PRT.fn1( @p^[i],f1)+el;
prcx:=t;
end;
class function PRT.prcx(p : PMc; v : PMc) : AnsiString;
var
f1 : AnsiString;
var
t : AnsiString = ''; i,j : IX;
q : PVc; c,d : CXp;
begin
f1:=prcx_fm;
t := '';
for i in IX do
t+=PRT.fn1( @p^[i],f1)+' '
+PRT.fn1( @v^[i],f1)+el;
prcx:=t;
end;
class function PRT.prcx(h1 : string; p : PMc;
h2 : string; v : PMc) : AnsiString;
begin
prcx := h1+', '+h2+el+PRT.prcx(p,v);
end;
class procedure PRT.prc(t : string; p : PMc; f : PRT.T_FM);
var
f1 : AnsiString =' [ %15.10g, %15.10g ] ';
f2 : AnsiString =' [ %15.6e, %15.6e ] ';
f3 : AnsiString =' [ %15.10f, %15.10f ] ';
var i,j,k : LongInt; s : AnsiString=''; c : CX;
z : ^AnsiString; l : Integer;
begin
k := Length(p^);
writeln(format(' matrix: %4d X %4d, printing 5 only ',[k,k]));
writeln(t);
case f of FMT_F: z:=@f3; FMT_G: z:=@f1; FMT_E: z:=@f2; end;
for i in IX do
begin
l:=0; s:='';
for j in IX do
begin
c:= p^[i][j];
s:=s + format(z^,[c.re,c.im]);
l:=l+1;
if (l=2) then
begin
writeln(s); l:=0; s:='';
end
end;
end;
writeln(s);
end;
type
PRT2 = class(PRT)
public
class procedure prc(t : string; p : PMc) override;
class procedure prc(t : string; p : PMc; f : T_FM);
end;
class procedure PRT2.prc(t : string; p : PMc; f : T_FM);
begin inherited prc(t,p,f); end;
class procedure PRT2.prc(t : string; p : PMc);
begin inherited prc(t,p,T_FM.FMT_E); end;
type
TST = class
public
class procedure tst_rnd();
end;
class procedure TST.tst_rnd();
var m : MTc;
begin
DTS.load(@m,DTS.EN.EN_RND);
PRT.prc('test: FMT_G',@m,PRT.T_FM.FMT_G);
PRT.prc('test: FMT_E',@m,PRT.T_FM.FMT_E);
PRT.prc('test: FMT_F',@m,PRT.T_FM.FMT_F);
PRT2.prc('test: FMT_G',@m,PRT.T_FM.FMT_G);
PRT2.prc('test: FMT_E',@m,PRT.T_FM.FMT_E);
PRT2.prc('test: FMT_F',@m,PRT.T_FM.FMT_F);
PRT2.prc('test: FMT_E',@m);
DTS.load(@m,DTS.EN.EN_RND_05);
PRT2.prc('test: FMT_E RND_05',@m);
end;
type
MTH = class
private
class procedure imx(m : PMc);
class procedure sub1(x,m: MTc; q1,q2 : CX);
public
class Function detc(m : PMc) : cx;
class function infc(p : PMc) : MTc;
class function rfr(p : PMc) : MTc;
class function trc(p : PMc) : CX;
class procedure test();
class procedure test2();
class procedure test3();
class procedure test4();
class procedure test5(); { rfr, symmeteic}
class procedure test6(); { chain}
class procedure test7(); { drive thru}
class procedure test8(); { rfr, detailed }
class procedure test9(); { rfr, detailed, concise }
end;
class procedure MTH.sub1(x,m: MTc; q1,q2 : CX);
var i,j : IX; q3,q4 : CX;
begin
{$IFDEF FLAG_EXT_1}
for i in IX do for j in IX do
WRT.wr2(format('%3d %3d',[i,j]),
format('%3d %3d',[j,i]),m[i][j],m[j][i]);
PRT2.prc('test: x = ',@x);
for i in IX do for j in IX do
WRT.wr2(format('%3d %3d',[i,j]),
format('%3d %3d',[j,i]),x[i][j],x[j][i]);
writeln();
{$endif}
q3:=trc(@x);
q4:=detc(@x);
WRT.wrd(' det 1 = ',' det 2 = ',q2,q4);
WRT.wrd(' trc 1 = ',' trc 2 = ',q1,q3);
write(#10);
{$IFDEF FLAG_EXT_1}
writeln();
writeln(' trc 1,2');
write(' ');
writeln(q1.re,' ',q1.im);
write(' ');
writeln(q3.re,' ',q3.im);
writeln(' det 1.2');
write(' ');
writeln(q2.re,' ',q2.im);
write(' ');
writeln(q4.re,' ',q4.im);
{$endif}
end;
class function MTH.trc(p : PMc) : CX;
var i : IX;
begin
trc.re:=0;
trc.im:=0;
for i in IX Do
trc+=p^[i][i];
end;
class function MTH.rfr(p : PMc) : MTc;
var x : MTc;
begin
DTS.load(@x,DTS.EN.EN_RND_05);
rfr:=infc(@x)*p^*x;
end;
class procedure MTH.imx(m : PMc);
var i,j,k,SZ : IT;
x,y : complex;
begin
sz:=high(IX);
for k:=1 to sz do
for i:=1 to sz-k do
begin
y:=m^[i][k]/m^[i+1][k];
x:=y;
for j in IX do
m^[i][j]:=m^[i][j]-m^[i+1][j]*x;
end;
end;
class Function MTH.detc(m : PMc) : complex;
var x,y : CX; i : IT; sz : IT;
begin
sz:=high(IX);
imx(m);
x:=1.0;
try
for i in IX do
begin
y:=m^[i][sz-i+1];
x:=x*y;
end;
except
on E: exception do
writeln('det >>> ', E.ClassName, '/', E.Message);
end;
if (sz mod 2 <> 0) then
x:=-x;
detc := -x;
end;
class procedure MTH.test();
type I2 = 1..2;
var m : array[I2] of PMc;
d : array[I2] of CX;
i : I2; g : MTc; d1,d2 : CX;
begin
hdr('MTH.test()');
for i in I2 do
begin
new(m[i]);
DTS.load(m[i],DTS.EN.EN_RND_05);
PRT2.prc('test: FMT_E RND_05',m[i]);
d[i]:=detc(m[i]);
end;
g:=m[1]^*m[2]^;
d1:=detc(@g);
d2:=d[1]*d[2];
WRT.wr(' det(c1) = ',d[1]);
WRT.wr(' det(c2) = ',d[2]);
WRT.wr(' det(c1*c2) = ',d1);
WRT.wr(' det1 * det 2 = ',d2);
WRT.wr(' the difference = ',d2-d2);
for i in I2 do dispose(m[i]);
end;
class procedure MTH.test2();
type I2 = 1..2;
var m : array[I2] of PMc;
i : I2; g : MTc;
begin
hdr('MTH.test2()');
for i in I2 do new(m[i]);
DTS.load(m[1],DTS.EN.EN_RND_05);
PRT2.prc('test: g',m[1]);
g:=infc(m[1])*m[1]^;
PRT2.prc('test: g',@g);
PRT2.prc('test: FMT_G',@g,PRT.T_FM.FMT_F);
for i in I2 do dispose(m[i]);
end;
class function MTH.infc(p : PMc) : MTc;
{
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
! Alex G. December 2009
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
}
var
n : IT;
a,c,L,U : MTc;
b,d,x : VTc;
//double precision a(n,n), c(n,n)
//double precision L(n,n), U(n,n), b(n), d(n), x(n)
coeff : complex;
i,j,k : IT;
begin
n := High(IX);
a:= p^; //m^;
//-----------------------------------------------------------
//-----------------------------------------------------------
for i in IX do
begin
b[i]:=0.0;
for j in IX do
begin
L[i][j]:=0.0;
U[i][j]:=0.0;
end;
end;
// pr(@U);
// step 1: forward elimination
//do k=1, n-1
for k:=1 to n-1 do
begin
for i:=k+1 to n do
begin
coeff:=a[i][k]/a[k][k];
L[i][k] := coeff;
for j:=k+1 to n do
a[i][j] -= coeff*a[k][j];
end;
end;
// Step 2: prepare L and U matrices
// L matrix is a matrix of the elimination coefficient
// + the diagonal elements are 1.0
for i:=1 to n do
L[i][i] := 1.0;
// U matrix is the upper triangular part of A
for j:=1 to n do
for i:=1 to j do
U[i][j] := a[i][j];
// Step 3: compute columns of the inverse matrix C
for k:=1 to n do
begin
b[k]:=1.0;
d[1] := b[1];
// Step 3a: Solve Ld=b using the forward substitution
for i:=2 to n do
begin
d[i]:=b[i];
for j:=1 to i-1 do
// d[i] := d[i] - L[i][j]*d[j];
d[i] -= L[i][j]*d[j];
end;
// Step 3b: Solve Ux=d using the back substitution
x[n]:=d[n]/U[n][n];
for i:=n-1 downto 1 do
begin
x[i] := d[i];
for j:=n downto i+1 do
x[i]:=x[i]-U[i][j]*x[j];
x[i]:=x[i]/u[i][i];
end;
// Step 3c: fill the solutions x(n) into column k of C
for i:=1 to n do
c[i][k] := x[i];
b[k]:=0.0;
end;
// if DF.D_INV.rs1
// then its();
infc:=c;
end;
operator / (x : MTc; y : MTc) z : MTc;
var t : MTc;
begin
t:=MTH.infc(@y);
z:=x * t;
end;
class procedure MTH.test3();
var m,l,g,v : MTc;
begin
hdr('MTH.test3() div non-commutative !');
DTS.load(@m,DTS.EN.EN_RND_05);
PRT2.prc('test: m = ',@m);
DTS.load(@l,DTS.EN.EN_RND_05);
PRT2.prc('test: l = ',@l);
g:=m/l;
v:=g*l - m;
PRT2.prc('test: g',@v);
PRT2.prc('test: FMT_G',@v,PRT.T_FM.FMT_F);
end;
class procedure MTH.test4();
var m : MTc; i,j : IX;
begin
hdr('MTH.test4() SYM !');
DTS.load(@m,DTS.EN.EN_RND_05_SYM);
PRT2.prc('test: m = ',@m);
for i in IX do for j in IX do
WRT.wr2(format('%3d %3d',[i,j]),
format('%3d %3d',[j,i]),m[i][j],m[j][i]);
end;
class procedure MTH.test6();
var m,x,m2 : MTc; q1,q2 : CX;
begin
hdr('MTH.test6() chain');
{$ifndef FLAG_EXT_1}
writeln(' Attention! FLAG_EXT_1 undefined...');
{$endif}
DTS.load(@m, DTS.EN.EN_RND_05_SYM);
PRT2.prc('test: m = ',@m);
m2:=m;
q1:=trc(@m);
q2:=detc(@m);
m:=m2;
x:=rfr(@m);
m:=m2;
sub1(x,m,q1,q2);
end;
class procedure MTH.test5();
var m,m2,x : MTc; q1,q2 : CX;
begin
hdr('MTH.test5() non - symmeric transfer');
{$ifndef FLAG_EXT_1}
writeln(' Attention! FLAG_EXT_1 undefined...');
{$endif}
DTS.load(@m,DTS.EN.EN_RND_05_SYM);
PRT2.prc('test: m = ',@m);
m2:=m;
q1:=trc(@m);
q2:=detc(@m);
m:=m2;
x:=rfr(@m);
m:=x;
sub1(x,m,q1,q2);
end;
class procedure MTH.test7();
const jx = 8;
var m,x,m2 : MTc; q1,q2 : CX; l : IT;
begin
hdr('MTH.test7() drive thru...');
{$ifndef FLAG_EXT_1}
writeln(' Attention! FLAG_EXT_1 undefined...');
{$endif}
DTS.load(@m,DTS.EN.EN_RND_05);
PRT2.prc('test: m = ',@m);
m2:=m;
q1:=trc(@m);
q2:=detc(@m);
m:=m2;
for l:=1 to jx do
begin
x:=rfr(@m);
m:=x;
sub1(x,m,q1,q2);
end;
end;
class procedure MTH.test8();
const jx = 64;
var m,x,y,m2 : MTc; q1,q2 : CX; l : IT;
begin
hdr('MTH.test8() rfr, detailed...');
{$ifndef FLAG_EXT_1}
writeln(' Attention! FLAG_EXT_1 undefined...');
{$endif}
DTS.load(@m,DTS.EN.EN_RND_05);
PRT2.prc('test: m = ',@m);
m2:=m;
PRT2.prc('test: m2= ',@m2);
q1:=trc(@m);
q2:=detc(@m);
PRT.prc2(q2,q1);
m:=m2;
PRT2.prc('test: m = ',@m);
for l:=1 to jx do
begin
x:=rfr(@m);
m:=x;
PRT2.prc('test: m = ',@m);
sub1(x,m,q1,q2);
end;
end;
class procedure MTH.test9();
const jx = 64;
var m,x,y,m2 : MTc; q1,q2 : CX; l : IT;
begin
hdr('MTH.test9() rfr, detailed, concise...');
{$ifndef FLAG_EXT_1}
writeln(' Attention! FLAG_EXT_1 undefined...');
{$endif}
DTS.load(@m,DTS.EN.EN_RND_05);
{ PRT2.prc('test: m = ',@m); }
m2:=m;
{ PRT2.prc('test: m2= ',@m2);}
q1:=trc(@m);
q2:=detc(@m);
PRT.prc2(q2,q1);
m:=m2;
{ PRT2.prc('test: m = ',@m);}
for l:=1 to jx do
begin
x:=rfr(@m);
m:=x;
{ PRT2.prc('test: m = ',@m); }
sub1(x,m,q1,q2);
y:=x-m2;
PRT2.prc('test: (difference) y = ',@y);
q1:=trc(@y);
q2:=detc(@y);
writeln('the difference:');
PRT.prc2(q2,q1);
end;
end;
type
MTH2 = class(MTH)
class function dst2(x,y : MTc) : CX;
class procedure test1();
class procedure test1m();
class procedure all();
end;
class procedure MTH2.all();
begin
{$ifndef LAST_TEST_ONLY}
MTH.test();
MTH.test2();
MTH.test3();
MTH.test4();
MTH.test5();
MTH.test6();
MTH.test7();
MTH2.test1();
MTH.test8();
MTH.test9();
{$ifend}
end;
class function MTH2.dst2(x,y : MTc) : CX;
var p,q: MTc;
begin
p:=x-y;
q:=rfr(@p);
dst2 := trc(@p);
end;
class procedure MTH2.test1();
var x,y,t : MTc; r,c : CX; i : IT;
begin
DTS.load(@x,DTS.EN.EN_RND_05);
DTS.load(@y,DTS.EN.EN_RND_05);
r:=dst2(x,y);
writeln();
for i:=0 to 10 do
begin
WRT.wr(' dst2 = ',r);
r:=dst2(x,y);
end;
t:=x-y;
c:=trc(@t);
writeln();
WRT.wr(' trc(x-y) = ',c);
end;
class procedure MTH2.test1m();
var x,y,t : MTc; r,c : CX; i : IT;
begin
DTS.load(@x,DTS.EN.EN_RND_05);
DTS.load(@y,DTS.EN.EN_RND_05);
r:=dst2(x,y);
{ writeln(); }
InitCriticalSection(cs2);
for i:=0 to 10 do
begin
EnterCriticalSection(cs2);
WRT.wr(' dst2 = ',r);
LeaveCriticalSection(cs2);
r:=dst2(x,y);
end;
t:=x-y;
c:=trc(@t);
{ writeln(); }
EnterCriticalSection(cs2);
writeln();
WRT.wr(' trc(x-y) = ',c);
LeaveCriticalSection(cs2);
DoneCriticalSection(cs2);
end;
var AThen : TDateTime;
procedure TMyThread.Execute;
const f1 : string = 'tr.re = %8.3g, tr.im = %8.3g';
f2 : string = 'det.re = %8.3g, det.im = %8.3g';
var i : IT; s,t,s1: String;
var m : MTc; q1,q2 : CX;
var q : IFS;
st : TThread.TSystemTimes;
w: string ='';
g : TThread;
begin
DTS.load(@m,DTS.EN.EN_RND_05);
q1:=MTH.trc(@m);
q2:=MTH.detc(@m);
s:=format(f1,[q1.re,q1.im]);
s1:=format(f2,[q2.re,q2.im]);
t:=THCL.hd(1,ThreadID) +el+tab+s+el+tab+s1+el;
IO_X.scr(t);
IFS.run();
g:=CurrentThread;
writeln(' thread ID = ',ThreadID);
CurrentThread.GetSystemTimes(st);
w:=format('Priority = %u, CPU IdleTime = %u, UserTime = %u, '+
' KernelTime = %u, NiceTime = %u',
[g.Priority, st.IdleTime, st.UserTime, st.KernelTime, st.NiceTime]);
writeln(w+el);
end;
type
TC2 = class(TObject)
class constructor Create();
class procedure p1();
end;
class constructor TC2.Create();
begin
end;
class procedure TC2.p1();
var x,y,z : MTc; t : AnsiString = '';
begin
DTS.load_i(@x);
t:=PRT.prcx(@x);
y:=trns(@x);
t+=el+PRT.prcx(' original - i ',@x,'trnsposed - i',@y);
z:=x*y;
t+=el+PRT.prcx(@z)+el;
DTS.load_j(@x);
t+=PRT.prcx(@x);
y:=trns(@x);
t+=el+PRT.prcx(' original - j ',@x,'trnsposed - j',@y);
z:=x*y;
t+=el+PRT.prcx(@z)+el;
DTS.load_k(@x);
t+=PRT.prcx(@x);
y:=trns(@x);
t+=el+PRT.prcx(' original - k ',@x,'trnsposed - k',@y);
z:=x*y;
t+=el+PRT.prcx(@z);
IO_X.scr(t);
end;
procedure TMyThread2.Execute;
var i : IT; s,t : String;
begin
IO_X.scr(THCL.hd(2,ThreadID)+el);
{$ifdef FLAG_TH2_ON}
TC2.p1();
{$endif}
end;
type
QTS = class(TObject)
class procedure tst1();
class procedure tst2();
class procedure tst3();
private
class function pr(x : PMc) : AnsiString;
class function t2s(x : PMc): AnsiString;
class function t2r(s : AnsiString; x : PMc) : AnsiString;
class function t2rs(s : AnsiString; x : PMc) : AnsiString;
class constructor Create();
class var sh, no_sc : Boolean;
end;
class constructor QTS.Create();
begin
sh := true;
no_sc := true;
IO_X.scr('QTS.sh - initialized with true'+el+
'QT5.no_sc - initialized with true'+el);
end;
class function QTS.pr(x : PMc) : Ansistring;
begin
pr:=PRT.prc(x,FMT_F);
end;
class procedure QTS.tst1();
var x,y,z : MTc; t : AnsiString = '';
const
c1 : AnsiString = 'Original x - matrix:';
c2 : AnsiString = 'Transpsed x - matrix:';
c3 : AnsiString = 'Transpsed(Transposed(x)) - x = 0';
c4 : AnsiString = ' Q - check';
begin
wl();
DTS.load_q(@x);
t:=c1+el+pr(@x);
y:=trns(@x);
t+=c2+el+pr(@y)+el+c4+el+PRT.prcx(@y,FMT_F)+el;
z := x - trns(@y);
t+=c3+el+pr(@z);
IO_X.scr(t);
end;
class function QTS.t2s(x : PMc) : AnsiString;
begin
t2s:=el+pr(x)+el+PRT.prcx(x,FMT_F)+el;
end;
class function QTS.t2r(s : AnsiString; x : PMc) : AnsiString;
begin
t2r:=el+s+el+t2s(x)+PRT.prcx(x);
end;
class function QTS.t2rs(s : AnsiString; x : PMc) : AnsiString;
begin
t2rs:=el+s+el+PRT.prcx(x);
end;
class procedure QTS.tst2();
const
sz = 9;
type
rx = 1..sz;
var x,y,z : MTc; p : PMc; t : AnsiString = '';
i,j,k,q : MTc; r : rx; { sh : Boolean = true;}
w : AnsiString = '';
const
c1 : AnsiString = 'Transposed basis test:';
c2 : AnsiString = ' load_0()'+el;
c3 : AnsiString = ' load_1()'+el;
c4 : AnsiString = ' load_i()'+el;
c5 : AnsiString = ' load_j()'+el;
c6 : AnsiString = ' load_k()'+el;
ar : array [rx] of string = (
' i * i = - 1 ',' j * j = - 1 ',' k * k = 1 ',
' i * j = k ',' j * i = k ',' i * k = -j ',
' k * i = -j ',' j * k = -i ',' k * j = -i '
);
var
q1,q2,q3,q4,q5,q6,q7,q8,q9 : MTc;
begin
p := @x;
wl();
DTS.load_0(p);
t:=c1+el+c2+t2s(p);
DTS.load_1(p);
if sh then
t+=c3+PRT.prcx(p)
else
t+=c3+t2s(p)+PRT.prcx(p);
DTS.load_i(p); i:=p^;
if sh then
t+=el+c4+PRT.prcx(p)
else
t+=el+c4+t2s(p)+PRT.prcx(p);
DTS.load_j(p); j:=p^;
if SH then
t+=el+c5+PRT.prcx(p)
else
t+=el+c5+t2s(p)+PRT.prcx(p);
DTS.load_k(p); k:=p^;
if sh then
t+=el+c6+PRT.prcx(p)
else
t+=el+c6+t2s(p)+PRT.prcx(p);
t+=el+'Multiplication table: '+el;
for r in rx do
begin
case r of
1 : begin q:=i*i; q1:=q; end;
2 : begin q:=j*j; q2:=q; end;
3 : begin q:=k*k; q3:=q; end;
4 : begin q:=i*j; q4:=q; end;
5 : begin q:=j*i; q5:=q; end;
6 : begin q:=i*k; q6:=q; end;
7 : begin q:=k*i; q7:=q; end;
8 : begin q:=j*k; q8:=q; end;
9 : begin q:=k*j; q9:=q; end;
end;
if not no_sc then
begin
if sh then
t+=t2rs(ar[r],@q)
else
t+=t2r(ar[r],@q);
end
else
if r = low(ar) then
t+=' skipped...';
end;
t+=el+'The algebra( one extra )'+el;
// t+=el+PRT.prcx(@q1,@q2);
t+=
PRT.prcx(ar[1],@q1,ar[2],@q2)
+PRT.prcx(ar[3],@q3,ar[4],@q4)
+PRT.prcx(ar[5],@q5,ar[6],@q6)
+PRT.prcx(ar[7],@q7,ar[8],@q8)
+PRT.prcx(ar[9],@q9,ar[9],@q9);
IO_X.scr(t);
end;
class procedure QTS.tst3();
const c1 : AnsiString = 'Transposed basis test II:';
var x,y,z,u : MTc; p : PMc;
t : AnsiString;
begin
p := @x;
wl();
DTS.load_q(p);
t:=c1+el+t2s(p);
y:=trns(@x);
t+=el+'Trans: '+el+QTS.pr(@y);
z:=x*y;
t+=el+'Original * Trans :'+el+
t2s(@z)+el+QTS.pr(@z);
IO_X.scr(t);
end;
procedure TMyThread3.Execute;
var i : IT; s : String; p : PMc;
t : AnsiString;
begin
new(p);
DTS.load(p,DTS.EN.EN_RND_05);
t:=THCL.hd(3,ThreadID)+el+PRT.prc(p,FMT_F);
DTS.load_q(p);
t+=el+PRT.prc(p,FMT_F)+
el+PRT.prcx(p,FMT_F);
t+=el+el+' Transposition test, shoild be zero.'+el;
t+=' In other words, if it is so, Q-structure is' +el
+ ' closed in regards to transposition';
IO_X.scr(t);
{$ifdef FLAG_TSTX_ON}
QTS.tst1();
QTS.tst2();
QTS.tst3();
{$endif}
dispose(p);
end;
type
BGN = class(TObject)
class constructor Create();
class destructor Destroy();
end;
class constructor BGN.Create();
const def = 'defined ';
ndf = 'not defined';
nf = 22; ns = 16;
begin
writeln(' BGN - started...');
AThen := now;
TDM();
randomize();
writeln(' Complex matrix size = ',High(IX),' X ',High(IX));
writeln(' >>>> FLAGs: ');
write( 'FLAG_EXT_1 : ':nf);
{$ifdef FLAG_EXT_1} writeln(def:ns); {$else} writeln(ndf:ns); {$endif}
write( 'LAST_TEST_ONLY : ':nf);
{$ifdef LAST_TEST_ONLY} writeln(def:ns); {$else} writeln(ndf:ns); {$endif}
write( 'FLAG_TSTX_ON : ':nf);
{$ifdef FLAG_TSTX_ON} writeln(def:ns); {$else} writeln(ndf:ns); {$endif}
write( 'FLAG_TH2_ON : ':nf);
{$ifdef FLAG_TH2_ON} writeln(def:ns); {$else} writeln(ndf:ns); {$endif}
writeln;
end;
class destructor BGN.Destroy();
begin
writeln();
writeln('BGN - ended...');
TDM();
writeln(' TimeSpan = ',MilliSecondSpan(now,AThen),' ms');
end;
type
TRD = class(TObject)
type JX = 1..4;
public
class var
t1,t2,t3,t4: TThread;
s1,s2,s3,s4: TThread;
public
class constructor Create();
class destructor Destroy();
class procedure wait();
class procedure sb(t : TThread);
end;
class procedure TRD.sb(t : TThread);
var st : TThread.TSystemTimes;
w: string ='';
begin
t.GetSystemTimes(st);
w:=format('Priority = %u, CPU IdleTime = %u, UserTime = %u, '+
' KernelTime = %u, NiceTime = %u',
[t.Priority, st.IdleTime, st.UserTime, st.KernelTime, st.NiceTime]);
writeln(w);
end;
class constructor TRD.Create();
function f1() : TThread;
var t : TThread;
begin
t := TMyThread.Create(true); t.FreeOnTerminate := true;
f1:=t;
sb(t);
end;
var
at : array[JX] of ^TThread = (@t1,@t2,@t3,@t4);
ax : array[JX] of ^TThread = (@s1,@s2,@s3,@s4);
var j : JX;
begin
writeln(' TRD - started...'+el);
writeln(' Interface check - up...');
IFS.run();
writeln(el+' Creating Group 1 threads: '+el);
for j in JX do at[j]^ := f1();
writeln();
for j in JX do
begin
if j<High(ax) then
ax[j]^ := TMyThread2.Create(true)
else
ax[j]^ := TMyThread3.Create(true);
sb(ax[j]^);
ax[j]^.FreeOnTerminate := true;
end;
writeln();
writeln(' Starting threads: '+el);
for j in JX do
begin
at[j]^.Start; Sleep(5);
ax[j]^.Start; Sleep(5);
end;
end;
class procedure TRD.wait();
var
at : array[JX] of ^TThread = (@t1,@t2,@t3,@t4);
ax : array[JX] of ^TThread = (@s1,@s2,@s3,@s4);
var j : JX;
begin
for j in JX do
begin
at[j]^.WaitFor;
ax[j]^.WaitFor;
end;
end;
class destructor TRD.Destroy();
var
at : array[JX] of ^TThread = (@t1,@t2,@t3,@t4);
ax : array[JX] of ^TThread = (@s1,@s2,@s3,@s4);
j : JX;
p1,p2,p3 : ^TThread;
n : Integer;
begin
wait();
writeln(' Terminating Threads...'+el);
n:=Low(IX);
p1 :=@at[n];
p2 :=@ax[n];
p3 :=@at[High(IX)];
while p1<=p3 do
begin
sb(p1^); sb(p2^);
p1^.Terminate;
p2^.Terminate;
inc(p1);
inc(p2);
end;
writeln();
writeln('TRD - ended...');
end;
var
b : BGN; b2 : TRD;
i : IT;
p : TPROCESS;
begin
// create all threads in suspended state
{ TST.tst_rnd(); }
TRD.wait();
{ MTH.test9();}
writeln();
p:= TProcess.Create(nil);
p.Executable:= 'ls';
p.Parameters.Add('-h');
p.Options := p.Options + [poWaitOnExit];
p.Execute;
// p.free;
// p:= TProcess.Create(nil);
p.Executable:= 'ls';
p.Options := p.Options + [poWaitOnExit];
p.Parameters.Add('-l');
p.Execute;
// p.free;
// p:= TProcess.Create(nil);
p.Executable:= 'ls';
p.Options := p.Options + [poWaitOnExit];
p.Parameters.Add('-a');
p.Execute;
p.free;
end.
Write, Run & Share Pascal code online using OneCompiler’s Pascal online compiler for free. It’s a straightforward, accessible way to learn and experiment with Pascal programming right from your browser. OneCompiler supports modern Pascal syntax and provides a ready-to-use editor for immediate execution.
Pascal is a procedural programming language developed in the 1970s by Niklaus Wirth. It was designed to encourage good programming practices and structured programming. Pascal is widely used in teaching computer science fundamentals and has influenced many modern languages.
The following is a simple Pascal program that prints a greeting:
program HelloWorld;
begin
writeln('Hello, OneCompiler!');
end.
OneCompiler’s Pascal editor supports stdin through the I/O tab. Here’s an example that reads a user's name and prints a greeting:
program GreetUser;
var
name: string;
begin
readln(name);
writeln('Hello, ', name, '!');
end.
var
age: integer;
name: string;
score: real;
flag: boolean;
| Type | Description |
|---|---|
| integer | Whole numbers |
| real | Floating-point numbers |
| char | Single character |
| string | Sequence of characters |
| boolean | True or False |
if score >= 50 then
writeln('Pass')
else
writeln('Fail');
for i := 1 to 5 do
writeln(i);
i := 1;
while i <= 5 do
begin
writeln(i);
i := i + 1;
end;
i := 1;
repeat
writeln(i);
i := i + 1;
until i > 5;
procedure SayHello;
begin
writeln('Hello!');
end;
function Add(a, b: integer): integer;
begin
Add := a + b;
end;
This guide provides a quick reference to Pascal programming syntax and features. Start coding in Pascal using OneCompiler’s Pascal online compiler today!