Форум программистов и сисадминов Киберфорум - Блоги - Библиотека матвычислений на Delphi.. Автор Massaraksh7

Рефакторинг программы уравнивания.

Massaraksh7 — Tue, 26 May 2026 15:20:34 GMT

Пример по предыдущей записи в блоге. Но, надо заметить, что, во-первых, там оптимизация не только математики, но и работы с базой данных, и с графами, а во-вторых, это ещё не всё.

Вложения

CompareEqual.zip (4.51 Мб, 70 просмотров)

Использование TThread в Lazarus для математических вычислений.

Massaraksh7 — Mon, 25 May 2026 20:48:51 GMT

Производя рефакторинг своих программ на предмет ускорения их работы, обратил внимание на такой аспект, как сокращение времени матвычислений. Дело в том, что приходится работать с большими матрицами (1000 x 1000, 2000 x 2000 и больше), и алгоритмические возможности уже исчерпаны. При этом если делать вычисления в лоб, то используется только часть процессорного времени, так как работает это на одном ядре. Но в современных компьютерах число ядер неуклонно растёт.
Хотя и не все операции возможно запараллелить, но такие, как умножение матриц, обращение матриц, решение систем линейных уравнений удалось разделить на независимые части, которые могут обрабатываться разными потоками. На моём компьютере 4 ядра, и, применяя 4 потока, удалось сократить время выполнения умножения примерно в 3.8 раза. На более "продвинутых" компьютерах результат будет ещё лучше. И вынес, конечно, число потоков в настройки программы.
Ниже приведу пример кода из библиотеки для умножения матриц.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
unit threadlib;
 
{$mode ObjFPC}{$H+}
 
interface
 
uses
  Classes, SysUtils, Common, Math;
 
procedure MultMatrixThreads(const X,Y:TMatrix;var Z:TMatrix;N,M,P:integer;nth:integer=1);
 
implementation
 
type TMultThread=class(TThread)
   private
     { Private declarations }
   protected
   procedure Execute; override;
   public
   startrow:integer;
   stoprow:integer;
   end;
 
var Th:array [0..100] of TMultThread;
AX,AY,AZ:TMatrix;
SX,SY,SZ:TMatrix;
start:array [0..100] of integer;
stop :array [0..100] of integer;
GP,GM:integer;
 
//
// Умножение матриц X(N,M)*Y(M,P)=Z(N,P)
// nth - число потоков, на которые разбиваются вычисления
//
procedure MultMatrixThreads(const X,Y:TMatrix;var Z:TMatrix;N,M,P:integer;nth:integer=1);
var i,j,k,np,si:integer;
begin
if 3*nth>N then begin MultMatrix(X,Y,Z,N,M,P);exit; end; //---Если матрица небольшая, то обычным способом
GM:=M;GP:=P;
//----Вычисляем шаг разбиения
np:=n div nth;si:=0;
for i:=0 to nth-2 do
   begin
   start[i]:=si;stop[i]:=si+np;
   si:=si+np+1;
   end;
start[nth-1]:=si;stop[nth-1]:=N-1;
//----Создаём и заполняем копии матриц
SetLength(AX,N,M);for i:=0 to N-1 do for j:=0 to M-1 do AX[i,j]:=X[i,j];
SetLength(AY,M,P);for i:=0 to M-1 do for j:=0 to P-1 do AY[i,j]:=Y[i,j];
SetLength(AZ,N,P);
//---Создаём потоки по заданному числу и назначаем им строки матрицы
for i:=0 to nth-1 do
   begin
   Th[i]:=TMultThread.Create(False);
   Th[i].startrow:=start[i];
   Th[i].stoprow:=stop[i];
   end;
for i:=0 to nth-1 do Th[i].Start;
//---Ждём завершения работы всех потоков
repeat
  begin
  k:=0;
  for i:=0 to nth-1 do if Th[i].Finished=True then inc(k);
  end;
until (k=nth);
//---Освобождаем потоки
for i:=0 to nth-1 do Th[i].Free;
//---Перезаписываем результат в Z
for i:=0 to N-1 do for j:=0 to P-1 do Z[i,j]:=AZ[i,j];
//---Освобождаем память
Finalize(AX);
Finalize(AY);
Finalize(AZ);
end;
 
procedure TMultThread.Execute;
var i,j,k:integer;
a:Extended;
begin
//---Умножение интервала строк
for i:=startrow to stoprow do
   begin
   for j:=0 to GP-1 do
      begin
      a:=0.0;
      for k:=0 to GM-1 do a:=a+AX[i,k]*AY[k,j];
      AZ[i,j]:=a;
      end;
   end;
end;
 
end.

При этом важно, чтобы разные потоки не записывали в одну переменную (элемент массива), а читать они могут как угодно.

Lazarus. Таблица с объединением ячеек.

Massaraksh7 — Fri, 21 Mar 2025 12:54:58 GMT

Понадобилась представление на экране таблицы с объединёнными ячейками. И не одной, а штук триста, и все разные. На Delphi я использовал для этих целей TStringGrid, и то, кривовато получалось. А в Lazarus - не получается вообще. Тут при установленном свойстве DefaultDrawing всё равно рисует то, что не надо. Искал в и-нете причину, но не нашёл. Сторонними компонентами принципиально не пользуюсь - во-первых, не всегда их функционал устраивает, во-вторых, не хотелось бы, чтобы мог подвести в самый неподходящий момент. Ну, и, в третьих, если кто-то написал, то могу и я написать, и именно то, что мне нужно. В результате сделал компонент TTableGrid (во вложении, с демо-примером). В качестве родителя выбрал TCustomControl. Отладил. И уже использую в разработке (скриншот). Если кому надо - пользуйтесь.

Миниатюры

Вложения

DemoGrid.zip (143.0 Кб, 542 просмотров)

Окончание

Massaraksh7 — Sun, 09 Mar 2025 08:32:52 GMT

Анимация динамики просадки фундамента за несколько лет.
Видео

Продолжение.

Massaraksh7 — Fri, 03 Jan 2025 04:59:36 GMT

Всё получилось в Opengl на Lazarus , то, что было сделано в glScene на Delphi.
А именно, интерполяция поверхности по нескольким точкам методом Кригинга, с построением изолиний, и просмотр её с помощью управления камерой из предыдущей записи блога. Результат - на видео:

Миниатюры

Вложения

Перемещение камеры по сцене для Opengl на Lazarus.

Massaraksh7 — Tue, 31 Dec 2024 00:05:28 GMT

Потребовалось отображать трёхмерные графики. Для этого выбрал OpenGl, благо, в Lazarus он есть. С Opengl раньше немного работал (простейшие вещи), но, аналогичную задачу в Delphi решал с помощью GlScene. В Lazarus GlScene до ума, видимо, пока не доведена, какие-то ошибки при компиляции, поэтому не стал заморачиваться, и решил полностью сделать на Opengl.
Первостепенная задача, естественно, управление камерой, чем, для начала и занялся. Приведён код, который позволяет:
1. Приближать/отдалять камеру к цели.
2. Осуществлять поворот камеры вокруг цели в плоскости, параллельной XY.
3. Осуществлять поворот камеры вокруг прямой Ax+Bx+C=0 (подъём/опускание)
4. Проводить смещение камеры (и цели) влево или вправо вдоль прямой, перпендикулярной "линии взгляда" камеры на цель.
Код и демо-видео прилагаются.

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
unit main;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, ExtCtrls, 
  OpenGLContext, gl, glu, LCLType, ComCtrls, Types, Math;
 
type
 
  { TOGLForm }
 
  TOGLForm = class(TForm)
    GLBox: TOpenGLControl;
    procedure FormCreate(Sender: TObject);
    procedure GLBoxMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure GLBoxMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
    procedure GLBoxMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
    procedure GLBoxMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
    procedure GLBoxPaint(Sender: TObject);
  private
  procedure CreateBase;
  procedure CreateNet;
  procedure Draw;
  public
  down,XS,YS,dx,dy,dz:integer;
  end;
 
var
  OGLForm: TOGLForm;
 
implementation
 
{$R *.lfm}
 
{ TOGLForm }
var xf,yf,zf,x0,y0,z0:double;
 
 
procedure TOGLForm.FormCreate(Sender: TObject);
begin
  zf:=200;xf:=-200;yf:=0;  //--Камера
  x0:=0;y0:=0;z0:=0;       //--Цель
end;
 
//--Нахождение угла (+-180° по x,y)
function Angle(x,y:double):double;
begin
if (Abs(x)<0.00000001) and (y>0) then begin Result:=90;exit;end;
if (Abs(x)<0.00000001) and (y<0) then begin Result:=-90;exit;end;
if (Abs(y)<0.00000001) and (x>0) then begin Result:=0;exit;end;
if (Abs(y)<0.00000001) and (x<0) then begin Result:=180;exit;end;
if (x>0) and (y>0) then begin Result:=arctan(y/x)*180/PI;exit;end;
if (x>0) and (y<0) then begin Result:=arctan(y/x)*180/PI;exit;end;
if (x<0) and (y>0) then begin Result:=180+arctan(y/x)*180/PI;exit;end;
if (x<0) and (y<0) then begin Result:=-180+arctan(y/x)*180/PI;exit;end;
end;
 
//--Нажатие кнопки мыши
procedure TOGLForm.GLBoxMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
XS:=X;YS:=Y;
if Button = mbLeft  then down:=1;
if Button = mbRight then down:=2;
if (Button = mbRight) and (ssCtrl in Shift) then down:=3;
end;
 
//--Колесо мыши - приближение/удаление
procedure TOGLForm.GLBoxMouseWheel(Sender: TObject; Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
var r,r2,rp,rp2,xa,ya,za:double;
begin
r:=Sqrt((xf-x0)*(xf-x0)+(yf-y0)*(yf-y0)+zf*zf);
if WheelDelta<0 then rp:=r+5 else rp:=r-5;
r2:=r*r;
rp2:=rp*rp;
xa:=Sqrt((xf-x0)*(xf-x0)*rp2/r2);
ya:=Sqrt((yf-y0)*(yf-y0)*rp2/r2);
za:=Sqrt(zf*zf*rp2/r2);
xf:=xa*sign(xf-x0)+x0;
yf:=ya*sign(yf-y0)+y0;
zf:=za*sign(zf);
Draw;
end;
 
//--Движение мыши
procedure TOGLForm.GLBoxMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var teta,dt,dtx,dty,x1,y1,r,fi,fiz:Extended;
//label 1;
begin
//---Поворот вокруг прямой Ax+By+C=0 (подъём, фи,тэта)
if down=1 then
   begin
   dt:=YS-Y;
   fiz:=Angle(xf-x0,yf-y0);
   r:=Sqrt((xf-x0)*(xf-x0)+(yf-y0)*(yf-y0)+zf*zf);
   teta:=arccos(zf/r)*180/PI;
   teta:=teta+dt/2;
   if (teta<0) or (teta>90) then exit;
   xf:=r*cos(fiz*PI/180)*sin(teta*PI/180)+x0;
   yf:=r*sin(fiz*PI/180)*sin(teta*PI/180)+y0;
   zf:=r*cos(teta*PI/180);
   YS:=Y;
   Draw;exit;
   end;
//---Поворот вокруг оси Z (фи)
if down=2 then
   begin
   dt:=XS-X;dt:=dt/5;
   fiz:=dt*PI/180;
   x1:=(xf-x0)*cos(fiz)-(yf-y0)*sin(fiz);
   y1:=(xf-x0)*sin(fiz)+(yf-y0)*cos(fiz);
   xf:=x1+x0;
   yf:=y1+y0;
   Draw;
   XS:=X;
   exit;
   end;
//---Смещение
if down=3 then
   begin
   dt:=XS-X;dt:=dt/5;
   fi:=Angle(xf-x0,yf-y0);
   dtx:=-cos((fi-90)*PI/180)*dt;dty:=-sin((fi-90)*PI/180)*dt;
   xf:=xf+dtx;
   yf:=yf+dty;
   x0:=x0+dtx;
   y0:=y0+dty;
   Draw;
   XS:=X;
   exit;
   end;
end;
 
//--Отжатие мыши
procedure TOGLForm.GLBoxMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
down:=0;
end;
 
//--Рисовать
procedure TOGLForm.GLBoxPaint(Sender: TObject);
begin
Draw;
end;
 
//--Задать параметры рисования, нарисовать "пол"
procedure TOGLForm.CreateBase;
begin
glClearColor(0.8,0.9,1.0,1);
 
glCullFace(GL_FRONT_AND_BACK);
glEnable(GL_BLEND);
glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA);
glShadeModel(GL_SMOOTH);
glHint(GL_POLYGON_SMOOTH_HINT, GL_FASTEST);
glEnable(GL_POLYGON_SMOOTH);
glHint(GL_POINT_SMOOTH_HINT, GL_FASTEST);
glEnable(GL_POINT_SMOOTH);
glHint(GL_LINE_SMOOTH_HINT, GL_FASTEST);
glEnable(GL_LINE_SMOOTH);
glDisable( GL_DEPTH_TEST );
glEnable( GL_ALPHA_TEST );
glClear(GL_COLOR_BUFFER_BIT);
 
glMatrixMode(gl_Projection);
glLoadIdentity;
 
gluPerspective(45,Width/Height, 0.1, 1000);
glViewport(0,0,Width,Height);
gluLookAt(xf,yf,zf,x0,y0,z0,0,0,1);
 
glBegin(gl_Quads);
glColor3f(0.3,0.5,0);
glVertex3f(200,200,0);
glVertex3f(200,-200,0);
glVertex3f(-200,-200,0);
glVertex3f(-200,200,0);
glEnd;
end;
 
//--Рисовать сетку
procedure TOGLForm.CreateNet;
var i,j:integer;
begin
glColor3f(1,1,0);
glLineWidth(1.0);
glBegin(gl_Lines);
for i:=0 to 10 do
   begin
   glVertex3f(-50,i*10-50,0);glVertex3f(50,i*10-50,0);
   glVertex3f(i*10-50,-50,0);glVertex3f(i*10-50,50,0);
   end;
glEnd;
end;
 
//--Рисовать
procedure TOGLForm.Draw;
begin
CreateBase;
CreateNet;
 
GLBox.SwapBuffers;
end;
 
end.

Миниатюры

Вложения

Интересная функция

Massaraksh7 — Tue, 19 Mar 2024 21:14:46 GMT

Нашёл забавную функцию, график которой при изменении параметра причудливо меняет форму, напоминая то ли сокращающееся сердце, то ли ещё что. Функция в декартовых координатах неявная, поэтому график строится через преобразование в полярные координаты, и решение кубического уравнения.
(x²+y²)²-A*x*y²=850*y

Pascal
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
unit Unit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ComCtrls,
  ExtCtrls, TAGraph, TASeries, Math;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Chart1: TChart;
    Chart1LineSeries1: TLineSeries;
    Image1: TImage;
    Label1: TLabel;
    TrackBar1: TTrackBar;
    procedure FormShow(Sender: TObject);
    procedure TrackBar1Change(Sender: TObject);
  private
  ak:integer;
  procedure DoGraph;
  public
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
//-------Решение куб. уравнения по формуле Кардано
function Kardano(a,b,c,d:Extended):Extended;
var p,q,qq,alfa,beta:Extended;
begin
p:=(3*a*c-b*b)/(3*a*a);
q:=(2*b*b*b-9*a*b*c+27*a*a*d)/(27*a*a*a);
qq:=p*p*p/27+q*q/4;
if qq>0 then
   begin
   alfa:=power(-q/2+Sqrt(qq),1/3);
   beta:=power(-q/2-Sqrt(qq),1/3);
   Result:=alfa+beta;
   end;
if qq=0 then Result:=0;
if qq<0 then Result:=0;
end;
 
//------Функция в полярных коррдинатах сводится к решению куб. уравнения
function MyFunc(ap,fi:Extended):Extended;
var cf,sf,x:Extended;
a,b,c,d:Extended;
begin
a:=1;
cf:=cos(fi*PI/180);sf:=sin(fi*PI/180);
b:=ap*cf*sf*sf;
c:=0;
d:=-850*sf;
Result:=Kardano(a,b,c,d);
end;
 
//-----------График функции (x^2+y^2)^2+-a*x*y^2=850y    -43<=a<=43
//-----------Полярн.коорд r^3+-a*cos(ф)*sin^2(ф)*r^2-850*sin(ф)=0;     r=f(ф)
procedure TForm1.DoGraph;
var i:integer;
r,x,y:Extended;
begin
Chart1LineSeries1.Clear;
if ak<0 then Chart1LineSeries1.LinePen.Color:=clRed else Chart1LineSeries1.LinePen.Color:=clBlue;
for i:=0 to 180 do
   begin
   r:=MyFunc(Form1.ak,i);
   x:=r*cos(i*PI/180);
   y:=r*sin(i*PI/180);
   if i=0 then begin x:=0;y:=0;r:=0;end;
   Chart1LineSeries1.AddXY(x,y);
   end;
end;
 
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
ak:=TrackBar1.Position;
Label1.Caption:='a='+IntToStr(ak);
DoGraph;
end;
 
procedure TForm1.FormShow(Sender: TObject);
begin
ak:=0;DoGraph;
end;
 
end.

Миниатюры

Вложения