Какие интересные ссылки. То есть и PasLLM уже написали для запуска готовых моделей.
Думаю для тренировки можно и свой Stable Diffusion сделать. Возможно и лучше оригинального получится.
"LLM на Паскале" была бы полезнее
Ну да чатик с ИИ сделать с работой на CPU. PasLLM уже есть готовый. Я покрутил так:
http://soft.self-made-free.ru/II5EXT_107.tar.xz там наброски WordEmbedding, трансформера с контекстом с обучением, самые предварительные наброски рассуждающего ИИ. Что нужно? Кодер NLP, трансформер, декодер NLP для нейросетевого генеративного ИИ. А в рассуждающем всё по другому, но и эта тема там чуть-чуть зацеплена.
Для Stable Diffusion (да и для чата и прочего) возможно будут полезны юниты для работы с простым PPM форматом.
Код: Выделить всё
unit PPMReader;
{
PPM file reader.
For GNU/Linux 64 bit version.
Version: 1.
Written on FreePascal (https://freepascal.org/).
Copyright (C) 2025-2026 Artyomov Alexander
http://self-made-free.ru/
aralni@mail.ru
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
}
{$MODE OBJFPC}{$H+}
{$MODESWITCH ADVANCEDRECORDS}
interface
uses
SysUtils, Classes, BaseUnix, Unix;
type
TNetPBMType = (PBM_P1, PBM_P4, PGM_P2, PGM_P5, PPM_P3, PPM_P6, PPM_Unknown);
TNetPBMImage = record
Width, Height: Integer;
MaxValue: Integer;
ImageType: TNetPBMType;
Data: PByte;
Size: Int64;
FileName: String;
IsMapped: Boolean;
FFileHandle: cint;
DataStart: PByte; // Начало данных изображения
HeaderSize: Int64; // Размер заголовка
end;
TRGBPixel = packed record
R, G, B: Byte;
end;
PRGBPixel = ^TRGBPixel;
TRGBImage = array of array of TRGBPixel;
TGrayscaleImage = array of array of Byte;
TBinaryImage = array of array of Boolean;
function LoadNetPBM(var Image: TNetPBMImage; const FileName: string): Boolean;
procedure FreeNetPBM(var Image: TNetPBMImage);
function NetPBMToRGBMatrix(const Image: TNetPBMImage): TRGBImage;
function NetPBMToGrayscaleMatrix(const Image: TNetPBMImage): TGrayscaleImage;
function NetPBMToBinaryMatrix(const Image: TNetPBMImage): TBinaryImage;
function GetPixel(const Image: TNetPBMImage; X, Y: Integer): TRGBPixel;
function GetGrayscalePixel(const Image: TNetPBMImage; X, Y: Integer): Byte;
function GetBinaryPixel(const Image: TNetPBMImage; X, Y: Integer): Boolean;
function IsValidNetPBM(const Image: TNetPBMImage): Boolean;
procedure PrintNetPBMInfo(const Image: TNetPBMImage);
function GetImageTypeName(ImageType: TNetPBMType): string;
implementation
function GetImageTypeName(ImageType: TNetPBMType): string;
begin
case ImageType of
PBM_P1: Result := 'P1 (ASCII PBM)';
PBM_P4: Result := 'P4 (Binary PBM)';
PGM_P2: Result := 'P2 (ASCII PGM)';
PGM_P5: Result := 'P5 (Binary PGM)';
PPM_P3: Result := 'P3 (ASCII PPM)';
PPM_P6: Result := 'P6 (Binary PPM)';
else Result := 'Unknown';
end;
end;
function SkipCommentsAndWhitespace(var Ptr: PByte; var BytesRead: Int64; MaxSize: Int64): Boolean;
var
C: Char;
InComment: Boolean;
begin
InComment := False;
Result := False;
while BytesRead < MaxSize do
begin
C := Char(Ptr^);
if C = '#' then
InComment := True
else if C = #10 then
InComment := False
else if not InComment and (C in ['0'..'9', 'P']) then
begin
Result := True;
Exit;
end
else if not InComment and not (C in [#9, #10, #13, #32]) then
begin
// Неожиданный символ
Exit;
end;
Inc(Ptr);
Inc(BytesRead);
end;
end;
function ReadNumber(var Ptr: PByte; var BytesRead: Int64; MaxSize: Int64): Integer;
var
C: Char;
NumStr: string;
begin
Result := 0;
NumStr := '';
while BytesRead < MaxSize do
begin
C := Char(Ptr^);
if C in ['0'..'9'] then
begin
NumStr := NumStr + C;
Inc(Ptr);
Inc(BytesRead);
end
else if C in [#9, #10, #13, #32] then
begin
if NumStr <> '' then
begin
Result := StrToIntDef(NumStr, 0);
Exit;
end;
Inc(Ptr);
Inc(BytesRead);
end
else
begin
if NumStr <> '' then
Result := StrToIntDef(NumStr, 0);
Exit;
end;
end;
if NumStr <> '' then
Result := StrToIntDef(NumStr, 0);
end;
function CalculateBinaryPBMDataSize(Width, Height: Integer): Int64;
begin
// PBM binary: каждый ряд выровнен до границы байта
Result := Height * ((Width + 7) div 8);
end;
function LoadNetPBM(var Image: TNetPBMImage; const FileName: string): Boolean;
var
OriginalData: PByte;
Ptr: PByte;
BytesRead: Int64;
begin
Result := False;
FillChar(Image, SizeOf(Image), 0);
Image.FileName := FileName;
Image.IsMapped := False;
// Открываем файл
Image.FFileHandle := FpOpen(FileName, O_RDONLY or O_LARGEFILE);
if Image.FFileHandle = -1 then
begin
WriteLn('Error: Cannot open file ', FileName);
Exit;
end;
try
// Получаем размер файла
Image.Size := FpLSeek(Image.FFileHandle, 0, SEEK_END);
FpLSeek(Image.FFileHandle, 0, SEEK_SET);
if Image.Size < 10 then
begin
WriteLn('Error: File too small to be a valid NetPBM');
Exit;
end;
// Memory map файл
OriginalData := PByte(FpMMap(nil, Image.Size, PROT_READ, MAP_SHARED, Image.FFileHandle, 0));
if OriginalData = Pointer(-1) then
begin
WriteLn('Error: MMap failed for file ', FileName);
Exit;
end;
Image.IsMapped := True;
Image.Data := OriginalData;
// Парсим заголовок NetPBM
Ptr := OriginalData;
BytesRead := 0;
// Читаем magic number
if not SkipCommentsAndWhitespace(Ptr, BytesRead, Image.Size) then
begin
WriteLn('Error: Cannot find NetPBM magic number');
Exit;
end;
// Читаем 'P'
if Char(Ptr^) <> 'P' then
begin
WriteLn('Error: Not a NetPBM file (missing P)');
Exit;
end;
Inc(Ptr);
Inc(BytesRead);
// Читаем тип
if BytesRead >= Image.Size then
begin
WriteLn('Error: Unexpected end of file after P');
Exit;
end;
case Char(Ptr^) of
'1': Image.ImageType := PBM_P1;
'4': Image.ImageType := PBM_P4;
'2': Image.ImageType := PGM_P2;
'5': Image.ImageType := PGM_P5;
'3': Image.ImageType := PPM_P3;
'6': Image.ImageType := PPM_P6;
else
WriteLn('Error: Unknown NetPBM type: P', Char(Ptr^));
Image.ImageType := PPM_Unknown;
Exit;
end;
Inc(Ptr);
Inc(BytesRead);
// Пропускаем до ширины
if not SkipCommentsAndWhitespace(Ptr, BytesRead, Image.Size) then
begin
WriteLn('Error: Cannot find width');
Exit;
end;
// Читаем ширину
Image.Width := ReadNumber(Ptr, BytesRead, Image.Size);
if Image.Width <= 0 then
begin
WriteLn('Error: Invalid width: ', Image.Width);
Exit;
end;
// Пропускаем до высоты
if not SkipCommentsAndWhitespace(Ptr, BytesRead, Image.Size) then
begin
WriteLn('Error: Cannot find height');
Exit;
end;
// Читаем высоту
Image.Height := ReadNumber(Ptr, BytesRead, Image.Size);
if Image.Height <= 0 then
begin
WriteLn('Error: Invalid height: ', Image.Height);
Exit;
end;
// Для PBM нет MaxValue, для PGM/PPM есть
if Image.ImageType in [PGM_P2, PGM_P5, PPM_P3, PPM_P6] then
begin
// Пропускаем до максимального значения
if not SkipCommentsAndWhitespace(Ptr, BytesRead, Image.Size) then
begin
WriteLn('Error: Cannot find max value');
Exit;
end;
// Читаем максимальное значение
Image.MaxValue := ReadNumber(Ptr, BytesRead, Image.Size);
if Image.MaxValue <= 0 then
begin
WriteLn('Error: Invalid max value: ', Image.MaxValue);
Exit;
end;
end
else
begin
// PBM всегда имеет MaxValue = 1
Image.MaxValue := 1;
end;
// Пропускаем один пробельный символ после заголовка
if (BytesRead < Image.Size) and (Char(Ptr^) in [#9, #10, #13, #32]) then
begin
Inc(Ptr);
Inc(BytesRead);
end;
// Сохраняем начало данных и размер заголовка
Image.DataStart := Ptr;
Image.HeaderSize := BytesRead;
// Проверяем размер данных
case Image.ImageType of
PPM_P6:
if (Image.Size - BytesRead) < (Image.Width * Image.Height * 3) then
begin
WriteLn('Error: File too small for PPM image data');
Exit;
end;
PGM_P5:
if (Image.Size - BytesRead) < (Image.Width * Image.Height) then
begin
WriteLn('Error: File too small for PGM image data');
Exit;
end;
PBM_P4:
if (Image.Size - BytesRead) < CalculateBinaryPBMDataSize(Image.Width, Image.Height) then
begin
WriteLn('Error: File too small for PBM image data');
Exit;
end;
end;
Result := True;
WriteLn(Format('Loaded NetPBM: %s, Type: %s, Size: %dx%d, MaxValue: %d',
[FileName, GetImageTypeName(Image.ImageType), Image.Width, Image.Height, Image.MaxValue]));
except
on E: Exception do
begin
WriteLn('Error loading NetPBM: ', E.Message);
FreeNetPBM(Image);
end;
end;
end;
procedure FreeNetPBM(var Image: TNetPBMImage);
begin
if Image.IsMapped and (Image.Data <> nil) then
begin
FpMUnMap(Image.Data, Image.Size);
if Image.FFileHandle <> -1 then
FpClose(Image.FFileHandle);
end;
FillChar(Image, SizeOf(Image), 0);
end;
function NetPBMToRGBMatrix(const Image: TNetPBMImage): TRGBImage;
var
X, Y: Integer;
Ptr: PByte;
Scale: Double;
GrayValue: Byte;
begin
if not IsValidNetPBM(Image) then
Exit(nil);
SetLength(Result, Image.Height, Image.Width);
case Image.ImageType of
PPM_P6:
begin
Ptr := Image.DataStart;
Scale := 255.0 / Image.MaxValue;
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
Result[Y, X].R := Byte(Round(Ptr^ * Scale));
Inc(Ptr);
Result[Y, X].G := Byte(Round(Ptr^ * Scale));
Inc(Ptr);
Result[Y, X].B := Byte(Round(Ptr^ * Scale));
Inc(Ptr);
end;
end;
PGM_P5:
begin
Ptr := Image.DataStart;
Scale := 255.0 / Image.MaxValue;
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
GrayValue := Byte(Round(Ptr^ * Scale));
Result[Y, X].R := GrayValue;
Result[Y, X].G := GrayValue;
Result[Y, X].B := GrayValue;
Inc(Ptr);
end;
end;
PBM_P4:
begin
// PBM: 0 = белый, 1 = черный (в бинарном формате)
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
if GetBinaryPixel(Image, X, Y) then
begin
Result[Y, X].R := 0; // Черный
Result[Y, X].G := 0;
Result[Y, X].B := 0;
end
else
begin
Result[Y, X].R := 255; // Белый
Result[Y, X].G := 255;
Result[Y, X].B := 255;
end;
end;
end;
else
WriteLn('Warning: Only P6, P5, P4 formats fully supported for RGB conversion');
// Заполняем серым цветом
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
Result[Y, X].R := 128;
Result[Y, X].G := 128;
Result[Y, X].B := 128;
end;
end;
end;
function NetPBMToGrayscaleMatrix(const Image: TNetPBMImage): TGrayscaleImage;
var
X, Y: Integer;
Ptr: PByte;
Scale: Double;
begin
if not IsValidNetPBM(Image) then
Exit(nil);
SetLength(Result, Image.Height, Image.Width);
case Image.ImageType of
PPM_P6:
begin
Ptr := Image.DataStart;
Scale := 255.0 / Image.MaxValue;
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
// Конвертируем RGB в grayscale
Result[Y, X] := Byte(Round(
(0.299 * (Ptr^ * Scale) +
0.587 * ((Ptr + 1)^ * Scale) +
0.114 * ((Ptr + 2)^ * Scale))));
Inc(Ptr, 3);
end;
end;
PGM_P5:
begin
Ptr := Image.DataStart;
Scale := 255.0 / Image.MaxValue;
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
Result[Y, X] := Byte(Round(Ptr^ * Scale));
Inc(Ptr);
end;
end;
PBM_P4:
begin
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
if GetBinaryPixel(Image, X, Y) then
Result[Y, X] := 0 // Черный
else
Result[Y, X] := 255; // Белый
end;
end;
end;
end;
function NetPBMToBinaryMatrix(const Image: TNetPBMImage): TBinaryImage;
var
X, Y: Integer;
Ptr: PByte;
Offset: Int64;
BitIndex: Integer;
ByteVal: Byte;
Threshold: Byte;
begin
if not IsValidNetPBM(Image) then
Exit(nil);
SetLength(Result, Image.Height, Image.Width);
case Image.ImageType of
PBM_P4:
begin
// PBM binary format: биты упакованы, 0=белый, 1=черный
for Y := 0 to Image.Height - 1 do
begin
for X := 0 to Image.Width - 1 do
begin
Offset := Y * ((Image.Width + 7) div 8) + (X div 8);
Ptr := Image.DataStart + Offset;
BitIndex := 7 - (X mod 8); // Старший бит первый
if Ptr < (Image.Data + Image.Size) then
begin
ByteVal := Ptr^;
Result[Y, X] := (ByteVal and (1 shl BitIndex)) <> 0;
end
else
begin
Result[Y, X] := False;
end;
end;
end;
end;
PGM_P5, PPM_P6:
begin
// Для grayscale и color изображений используем порог 128
Threshold := 128;
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
begin
Result[Y, X] := GetGrayscalePixel(Image, X, Y) < Threshold;
end;
end;
else
// Для других форматов заполняем False
for Y := 0 to Image.Height - 1 do
for X := 0 to Image.Width - 1 do
Result[Y, X] := False;
end;
end;
function GetPixel(const Image: TNetPBMImage; X, Y: Integer): TRGBPixel;
var
Ptr: PByte;
Offset: Int64;
Scale: Double;
GrayValue: Byte;
BitIndex: Integer;
ByteVal: Byte;
begin
FillChar(Result, SizeOf(Result), 0);
if not IsValidNetPBM(Image) or (X < 0) or (X >= Image.Width) or (Y < 0) or (Y >= Image.Height) then
Exit;
case Image.ImageType of
PPM_P6:
begin
Scale := 255.0 / Image.MaxValue;
Offset := (Y * Image.Width + X) * 3;
Ptr := Image.DataStart + Offset;
if (Ptr + 2) < (Image.Data + Image.Size) then
begin
Result.R := Byte(Round(Ptr^ * Scale));
Result.G := Byte(Round((Ptr + 1)^ * Scale));
Result.B := Byte(Round((Ptr + 2)^ * Scale));
end;
end;
PGM_P5:
begin
Scale := 255.0 / Image.MaxValue;
Offset := Y * Image.Width + X;
Ptr := Image.DataStart + Offset;
if Ptr < (Image.Data + Image.Size) then
begin
GrayValue := Byte(Round(Ptr^ * Scale));
Result.R := GrayValue;
Result.G := GrayValue;
Result.B := GrayValue;
end;
end;
PBM_P4:
begin
// PBM binary format: биты упакованы, 0=белый, 1=черный
Offset := Y * ((Image.Width + 7) div 8) + (X div 8);
Ptr := Image.DataStart + Offset;
BitIndex := 7 - (X mod 8); // Старший бит первый
if Ptr < (Image.Data + Image.Size) then
begin
ByteVal := Ptr^;
if (ByteVal and (1 shl BitIndex)) <> 0 then
begin
Result.R := 0; // Черный
Result.G := 0;
Result.B := 0;
end
else
begin
Result.R := 255; // Белый
Result.G := 255;
Result.B := 255;
end;
end;
end;
end;
end;
function GetGrayscalePixel(const Image: TNetPBMImage; X, Y: Integer): Byte;
var
Pixel: TRGBPixel;
begin
Pixel := GetPixel(Image, X, Y);
Result := Byte(Round(0.299 * Pixel.R + 0.587 * Pixel.G + 0.114 * Pixel.B));
end;
function GetBinaryPixel(const Image: TNetPBMImage; X, Y: Integer): Boolean;
var
Ptr: PByte;
Offset: Int64;
BitIndex: Integer;
ByteVal: Byte;
begin
Result := False;
if not IsValidNetPBM(Image) or (X < 0) or (X >= Image.Width) or (Y < 0) or (Y >= Image.Height) then
Exit;
if Image.ImageType = PBM_P4 then
begin
Offset := Y * ((Image.Width + 7) div 8) + (X div 8);
Ptr := Image.DataStart + Offset;
BitIndex := 7 - (X mod 8);
if Ptr < (Image.Data + Image.Size) then
begin
ByteVal := Ptr^;
Result := (ByteVal and (1 shl BitIndex)) <> 0;
end;
end
else
begin
// Для других форматов считаем черным если значение < 128
Result := GetGrayscalePixel(Image, X, Y) < 128;
end;
end;
function IsValidNetPBM(const Image: TNetPBMImage): Boolean;
begin
Result := (Image.IsMapped) and (Image.Data <> nil) and
(Image.ImageType <> PPM_Unknown) and
(Image.Width > 0) and (Image.Height > 0) and
(Image.MaxValue > 0) and (Image.MaxValue <= 65535) and
(Image.DataStart <> nil) and (Image.HeaderSize > 0);
end;
procedure PrintNetPBMInfo(const Image: TNetPBMImage);
var
ExpectedDataSize: Int64;
ActualDataSize: Int64;
begin
if not Image.IsMapped then
begin
WriteLn('NetPBM image not loaded');
Exit;
end;
WriteLn('NetPBM File: ', Image.FileName);
WriteLn('Type: ', GetImageTypeName(Image.ImageType));
WriteLn('Size: ', Image.Width, ' x ', Image.Height);
WriteLn('Max Value: ', Image.MaxValue);
WriteLn('Total File Size: ', Image.Size, ' bytes');
WriteLn('Header Size: ', Image.HeaderSize, ' bytes');
case Image.ImageType of
PPM_P6: ExpectedDataSize := Image.Width * Image.Height * 3;
PGM_P5: ExpectedDataSize := Image.Width * Image.Height;
PBM_P4: ExpectedDataSize := CalculateBinaryPBMDataSize(Image.Width, Image.Height);
else
ExpectedDataSize := 0;
end;
if ExpectedDataSize > 0 then
begin
ActualDataSize := Image.Size - Image.HeaderSize;
WriteLn('Expected Data Size: ', ExpectedDataSize, ' bytes');
WriteLn('Actual Data Size: ', ActualDataSize, ' bytes');
WriteLn('Data Size Match: ', ExpectedDataSize = ActualDataSize);
end;
WriteLn('Mapped: ', Image.IsMapped);
WriteLn('Valid: ', IsValidNetPBM(Image));
end;
end.
Код: Выделить всё
unit PPMWriter;
{
PPM file writer.
For GNU/Linux 64 bit version.
Version: 1.
Written on FreePascal (https://freepascal.org/).
Copyright (C) 2025-2026 Artyomov Alexander
http://self-made-free.ru/
aralni@mail.ru
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
}
{$MODE OBJFPC}{$H+}
{$MODESWITCH ADVANCEDRECORDS}
{$MODESWITCH UNICODESTRINGS}
interface
uses
SysUtils, Classes, Math, PPMReader, MatrixOps, DataUtils;
type
TPPMFormat = (pfPBM, pfPGM, pfPPM, pfAuto);
TBinaryFormat = (bfASCII, bfBinary);
TPPMWriter = record
class function SavePBM(const Image: TBinaryImage; const FileName: string;
BinaryFormat: TBinaryFormat = bfBinary): Boolean; static;
class function SavePGM(const Image: TGrayscaleImage; const FileName: string;
MaxValue: Integer = 255;
BinaryFormat: TBinaryFormat = bfBinary): Boolean; static;
class function SavePPM(const Image: TRGBImage; const FileName: string;
MaxValue: Integer = 255;
BinaryFormat: TBinaryFormat = bfBinary): Boolean; static;
// Универсальные функции
class function SaveImage(const Image: TRGBImage; const FileName: string;
Format: TPPMFormat = pfAuto;
MaxValue: Integer = 255): Boolean; static;
class function SaveMatrixAsPGM(const Matrix: TDoubleMatrix;
const FileName: string;
Normalize: Boolean = True;
MaxValue: Integer = 255): Boolean; static;
// Вспомогательные функции
class function ConvertToPBMFormat(const Image: TBinaryImage): string; static;
class function ConvertToPGMFormat(const Image: TGrayscaleImage;
MaxValue: Integer): string; static;
class function ConvertToPPMFormat(const Image: TRGBImage;
MaxValue: Integer): string; static;
end;
TNetPBMSaver = class
private
class procedure WritePBMHeader(Stream: TStream; Width, Height: Integer;
Binary: Boolean); static;
class procedure WritePGMHeader(Stream: TStream; Width, Height, MaxValue: Integer;
Binary: Boolean); static;
class procedure WritePPMHeader(Stream: TStream; Width, Height, MaxValue: Integer;
Binary: Boolean); static;
public
class function SaveBinaryPBM(const Image: TBinaryImage; Stream: TStream): Boolean; static;
class function SaveAsciiPBM(const Image: TBinaryImage; Stream: TStream): Boolean; static;
class function SaveBinaryPGM(const Image: TGrayscaleImage; Stream: TStream;
MaxValue: Integer): Boolean; static;
class function SaveAsciiPGM(const Image: TGrayscaleImage; Stream: TStream;
MaxValue: Integer): Boolean; static;
class function SaveBinaryPPM(const Image: TRGBImage; Stream: TStream;
MaxValue: Integer): Boolean; static;
class function SaveAsciiPPM(const Image: TRGBImage; Stream: TStream;
MaxValue: Integer): Boolean; static;
end;
implementation
{ TPPMWriter }
class function TPPMWriter.SavePBM(const Image: TBinaryImage; const FileName: string;
BinaryFormat: TBinaryFormat): Boolean;
var
Stream: TFileStream;
begin
Result := False;
try
Stream := TFileStream.Create(FileName, fmCreate);
try
if BinaryFormat = bfBinary then
Result := TNetPBMSaver.SaveBinaryPBM(Image, Stream)
else
Result := TNetPBMSaver.SaveAsciiPBM(Image, Stream);
finally
Stream.Free;
end;
except
on E: Exception do
WriteLn('Error saving PBM: ', E.Message);
end;
end;
class function TPPMWriter.SavePGM(const Image: TGrayscaleImage; const FileName: string;
MaxValue: Integer; BinaryFormat: TBinaryFormat): Boolean;
var
Stream: TFileStream;
begin
Result := False;
try
Stream := TFileStream.Create(FileName, fmCreate);
try
if BinaryFormat = bfBinary then
Result := TNetPBMSaver.SaveBinaryPGM(Image, Stream, MaxValue)
else
Result := TNetPBMSaver.SaveAsciiPGM(Image, Stream, MaxValue);
finally
Stream.Free;
end;
except
on E: Exception do
WriteLn('Error saving PGM: ', E.Message);
end;
end;
class function TPPMWriter.SavePPM(const Image: TRGBImage; const FileName: string;
MaxValue: Integer; BinaryFormat: TBinaryFormat): Boolean;
var
Stream: TFileStream;
begin
Result := False;
try
Stream := TFileStream.Create(FileName, fmCreate);
try
if BinaryFormat = bfBinary then
Result := TNetPBMSaver.SaveBinaryPPM(Image, Stream, MaxValue)
else
Result := TNetPBMSaver.SaveAsciiPPM(Image, Stream, MaxValue);
finally
Stream.Free;
end;
except
on E: Exception do
WriteLn('Error saving PPM: ', E.Message);
end;
end;
class function TPPMWriter.SaveImage(const Image: TRGBImage; const FileName: string;
Format: TPPMFormat; MaxValue: Integer): Boolean;
var
Ext: string;
GrayscaleImage: TGrayscaleImage;
BinaryImage: TBinaryImage;
X, Y: Integer;
begin
Result := False;
// Автоопределение формата по расширению
if Format = pfAuto then
begin
Ext := LowerCase(ExtractFileExt(FileName));
if Ext = '.pbm' then Format := pfPBM
else if Ext = '.pgm' then Format := pfPGM
else Format := pfPPM; // .ppm или любое другое
end;
try
case Format of
pfPBM:
begin
// Конвертируем RGB в бинарное (порог 128)
SetLength(BinaryImage, Length(Image), Length(Image[0]));
for Y := 0 to High(Image) do
for X := 0 to High(Image[0]) do
BinaryImage[Y, X] :=
(0.299 * Image[Y, X].R +
0.587 * Image[Y, X].G +
0.114 * Image[Y, X].B) < 128;
Result := SavePBM(BinaryImage, FileName, bfBinary);
SetLength(BinaryImage, 0);
end;
pfPGM:
begin
// Конвертируем RGB в grayscale
SetLength(GrayscaleImage, Length(Image), Length(Image[0]));
for Y := 0 to High(Image) do
for X := 0 to High(Image[0]) do
GrayscaleImage[Y, X] := Byte(Round(
0.299 * Image[Y, X].R +
0.587 * Image[Y, X].G +
0.114 * Image[Y, X].B));
Result := SavePGM(GrayscaleImage, FileName, MaxValue, bfBinary);
SetLength(GrayscaleImage, 0);
end;
pfPPM:
begin
Result := SavePPM(Image, FileName, MaxValue, bfBinary);
end;
end;
except
on E: Exception do
WriteLn('Error saving image: ', E.Message);
end;
end;
class function TPPMWriter.SaveMatrixAsPGM(const Matrix: TDoubleMatrix;
const FileName: string;
Normalize: Boolean;
MaxValue: Integer): Boolean;
var
GrayscaleImage: TGrayscaleImage;
X, Y: Integer;
MinVal, MaxVal, Range, Scale: Double;
Value: Double;
begin
Result := False;
if Length(Matrix) = 0 then Exit;
try
SetLength(GrayscaleImage, Length(Matrix), Length(Matrix[0]));
if Normalize then
begin
// Находим диапазон значений
MinVal := Matrix[0, 0];
MaxVal := Matrix[0, 0];
for Y := 0 to High(Matrix) do
for X := 0 to High(Matrix[0]) do
begin
if Matrix[Y, X] < MinVal then MinVal := Matrix[Y, X];
if Matrix[Y, X] > MaxVal then MaxVal := Matrix[Y, X];
end;
Range := MaxVal - MinVal;
if Range = 0 then Range := 1;
// Нормализуем к [0, MaxValue]
Scale := MaxValue / Range;
for Y := 0 to High(Matrix) do
for X := 0 to High(Matrix[0]) do
begin
Value := (Matrix[Y, X] - MinVal) * Scale;
GrayscaleImage[Y, X] := Byte(Max(0, Min(MaxValue, Round(Value))));
end;
end
else
begin
// Прямое преобразование (клиппинг)
for Y := 0 to High(Matrix) do
for X := 0 to High(Matrix[0]) do
begin
Value := Matrix[Y, X];
if Value < 0 then Value := 0;
if Value > MaxValue then Value := MaxValue;
GrayscaleImage[Y, X] := Byte(Round(Value));
end;
end;
Result := SavePGM(GrayscaleImage, FileName, MaxValue, bfBinary);
SetLength(GrayscaleImage, 0);
except
on E: Exception do
WriteLn('Error saving matrix as PGM: ', E.Message);
end;
end;
class function TPPMWriter.ConvertToPBMFormat(const Image: TBinaryImage): string;
var
Y, X: Integer;
Line: string;
begin
Result := 'P1' + LineEnding +
IntToStr(Length(Image[0])) + ' ' + IntToStr(Length(Image)) + LineEnding;
for Y := 0 to High(Image) do
begin
Line := '';
for X := 0 to High(Image[0]) do
begin
if Image[Y, X] then
Line := Line + '1 '
else
Line := Line + '0 ';
end;
Result := Result + Trim(Line) + LineEnding;
end;
end;
class function TPPMWriter.ConvertToPGMFormat(const Image: TGrayscaleImage;
MaxValue: Integer): string;
var
Y, X: Integer;
Line: string;
begin
Result := 'P2' + LineEnding +
IntToStr(Length(Image[0])) + ' ' + IntToStr(Length(Image)) + LineEnding +
IntToStr(MaxValue) + LineEnding;
for Y := 0 to High(Image) do
begin
Line := '';
for X := 0 to High(Image[0]) do
begin
Line := Line + IntToStr(Image[Y, X]) + ' ';
end;
Result := Result + Trim(Line) + LineEnding;
end;
end;
class function TPPMWriter.ConvertToPPMFormat(const Image: TRGBImage;
MaxValue: Integer): string;
var
Y, X: Integer;
Line: string;
begin
Result := 'P3' + LineEnding +
IntToStr(Length(Image[0])) + ' ' + IntToStr(Length(Image)) + LineEnding +
IntToStr(MaxValue) + LineEnding;
for Y := 0 to High(Image) do
begin
Line := '';
for X := 0 to High(Image[0]) do
begin
Line := Line + IntToStr(Image[Y, X].R) + ' ' +
IntToStr(Image[Y, X].G) + ' ' +
IntToStr(Image[Y, X].B) + ' ';
end;
Result := Result + Trim(Line) + LineEnding;
end;
end;
{ TNetPBMSaver }
class procedure TNetPBMSaver.WritePBMHeader(Stream: TStream; Width, Height: Integer;
Binary: Boolean);
var
Header: AnsiString;
begin
if Binary then
Header := 'P4' + #10
else
Header := 'P1' + #10;
Header := Header + IntToStr(Width) + ' ' + IntToStr(Height) + #10;
Stream.WriteBuffer(Header[1], Length(Header));
end;
class procedure TNetPBMSaver.WritePGMHeader(Stream: TStream; Width, Height, MaxValue: Integer;
Binary: Boolean);
var
Header: AnsiString;
begin
if Binary then
Header := 'P5' + #10
else
Header := 'P2' + #10;
Header := Header + IntToStr(Width) + ' ' + IntToStr(Height) + #10 +
IntToStr(MaxValue) + #10;
Stream.WriteBuffer(Header[1], Length(Header));
end;
class procedure TNetPBMSaver.WritePPMHeader(Stream: TStream; Width, Height, MaxValue: Integer;
Binary: Boolean);
var
Header: AnsiString;
begin
if Binary then
Header := 'P6' + #10
else
Header := 'P3' + #10;
Header := Header + IntToStr(Width) + ' ' + IntToStr(Height) + #10 +
IntToStr(MaxValue) + #10;
Stream.WriteBuffer(Header[1], Length(Header));
end;
class function TNetPBMSaver.SaveBinaryPBM(const Image: TBinaryImage; Stream: TStream): Boolean;
var
X, Y, ByteIdx, BitIdx: Integer;
ScanlineBytes: Integer;
Scanline: array of Byte;
ByteVal: Byte;
begin
Result := False;
if Length(Image) = 0 then Exit;
try
// Записываем заголовок
WritePBMHeader(Stream, Length(Image[0]), Length(Image), True);
// Вычисляем количество байт на строку (выровнено по границе байта)
ScanlineBytes := (Length(Image[0]) + 7) div 8;
SetLength(Scanline, ScanlineBytes);
for Y := 0 to High(Image) do
begin
// Обнуляем строку
FillChar(Scanline[0], ScanlineBytes, 0);
// Упаковываем биты
for X := 0 to High(Image[0]) do
begin
ByteIdx := X div 8;
BitIdx := 7 - (X mod 8); // Старший бит первый
if Image[Y, X] then
Scanline[ByteIdx] := Scanline[ByteIdx] or (1 shl BitIdx);
end;
// Записываем строку
Stream.WriteBuffer(Scanline[0], ScanlineBytes);
end;
Result := True;
except
on E: Exception do
WriteLn('Error in SaveBinaryPBM: ', E.Message);
end;
end;
class function TNetPBMSaver.SaveAsciiPBM(const Image: TBinaryImage; Stream: TStream): Boolean;
var
X, Y: Integer;
Line: AnsiString;
Value: Byte;
begin
Result := False;
if Length(Image) = 0 then Exit;
try
// Записываем заголовок
WritePBMHeader(Stream, Length(Image[0]), Length(Image), False);
for Y := 0 to High(Image) do
begin
Line := '';
for X := 0 to High(Image[0]) do
begin
if Image[Y, X] then
Line := Line + '1 '
else
Line := Line + '0 ';
// Для ASCII формата ограничиваем длину строки
if Length(Line) > 70 then
begin
Stream.WriteBuffer(Line[1], Length(Line));
Line := LineEnding;
end;
end;
if Line <> '' then
begin
Line := Trim(Line) + LineEnding;
Stream.WriteBuffer(Line[1], Length(Line));
end;
end;
Result := True;
except
on E: Exception do
WriteLn('Error in SaveAsciiPBM: ', E.Message);
end;
end;
class function TNetPBMSaver.SaveBinaryPGM(const Image: TGrayscaleImage; Stream: TStream;
MaxValue: Integer): Boolean;
var
X, Y: Integer;
Scanline: array of Byte;
Value: Byte;
begin
Result := False;
if Length(Image) = 0 then Exit;
try
// Записываем заголовок
WritePGMHeader(Stream, Length(Image[0]), Length(Image), MaxValue, True);
// Подготавливаем строку для записи
SetLength(Scanline, Length(Image[0]));
for Y := 0 to High(Image) do
begin
for X := 0 to High(Image[0]) do
begin
// Масштабируем значение если нужно
if MaxValue = 255 then
Value := Image[Y, X]
else
Value := Byte(Round(Image[Y, X] * 255.0 / MaxValue));
Scanline[X] := Value;
end;
// Записываем строку
Stream.WriteBuffer(Scanline[0], Length(Scanline));
end;
Result := True;
except
on E: Exception do
WriteLn('Error in SaveBinaryPGM: ', E.Message);
end;
end;
class function TNetPBMSaver.SaveAsciiPGM(const Image: TGrayscaleImage; Stream: TStream;
MaxValue: Integer): Boolean;
var
X, Y: Integer;
Line: AnsiString;
Value: Byte;
begin
Result := False;
if Length(Image) = 0 then Exit;
try
// Записываем заголовок
WritePGMHeader(Stream, Length(Image[0]), Length(Image), MaxValue, False);
for Y := 0 to High(Image) do
begin
Line := '';
for X := 0 to High(Image[0]) do
begin
// Масштабируем значение если нужно
if MaxValue = 255 then
Value := Image[Y, X]
else
Value := Byte(Round(Image[Y, X] * 255.0 / MaxValue));
Line := Line + IntToStr(Value) + ' ';
// Для ASCII формата ограничиваем длину строки
if Length(Line) > 70 then
begin
Stream.WriteBuffer(Line[1], Length(Line));
Line := LineEnding;
end;
end;
if Line <> '' then
begin
Line := Trim(Line) + LineEnding;
Stream.WriteBuffer(Line[1], Length(Line));
end;
end;
Result := True;
except
on E: Exception do
WriteLn('Error in SaveAsciiPGM: ', E.Message);
end;
end;
class function TNetPBMSaver.SaveBinaryPPM(const Image: TRGBImage; Stream: TStream;
MaxValue: Integer): Boolean;
var
X, Y: Integer;
Scanline: array of Byte;
R, G, B: Byte;
Scale: Double;
begin
Result := False;
if Length(Image) = 0 then Exit;
try
// Записываем заголовок
WritePPMHeader(Stream, Length(Image[0]), Length(Image), MaxValue, True);
// Подготавливаем строку для записи (3 канала на пиксель)
SetLength(Scanline, Length(Image[0]) * 3);
// Коэффициент масштабирования
Scale := 255.0 / MaxValue;
for Y := 0 to High(Image) do
begin
for X := 0 to High(Image[0]) do
begin
// Масштабируем значения если нужно
R := Byte(Round(Image[Y, X].R * Scale));
G := Byte(Round(Image[Y, X].G * Scale));
B := Byte(Round(Image[Y, X].B * Scale));
// Записываем в формате RGB
Scanline[X * 3] := R;
Scanline[X * 3 + 1] := G;
Scanline[X * 3 + 2] := B;
end;
// Записываем строку
Stream.WriteBuffer(Scanline[0], Length(Scanline));
end;
Result := True;
except
on E: Exception do
WriteLn('Error in SaveBinaryPPM: ', E.Message);
end;
end;
class function TNetPBMSaver.SaveAsciiPPM(const Image: TRGBImage; Stream: TStream;
MaxValue: Integer): Boolean;
var
X, Y: Integer;
Line: AnsiString;
R, G, B: Byte;
Scale: Double;
begin
Result := False;
if Length(Image) = 0 then Exit;
try
// Записываем заголовок
WritePPMHeader(Stream, Length(Image[0]), Length(Image), MaxValue, False);
// Коэффициент масштабирования
Scale := 255.0 / MaxValue;
for Y := 0 to High(Image) do
begin
Line := '';
for X := 0 to High(Image[0]) do
begin
// Масштабируем значения если нужно
R := Byte(Round(Image[Y, X].R * Scale));
G := Byte(Round(Image[Y, X].G * Scale));
B := Byte(Round(Image[Y, X].B * Scale));
Line := Line + IntToStr(R) + ' ' +
IntToStr(G) + ' ' +
IntToStr(B) + ' ';
// Для ASCII формата ограничиваем длину строки
if Length(Line) > 70 then
begin
Stream.WriteBuffer(Line[1], Length(Line));
Line := LineEnding;
end;
end;
if Line <> '' then
begin
Line := Trim(Line) + LineEnding;
Stream.WriteBuffer(Line[1], Length(Line));
end;
end;
Result := True;
except
on E: Exception do
WriteLn('Error in SaveAsciiPPM: ', E.Message);
end;
end;
end.
Код: Выделить всё
unit MatrixOps;
{
MatrixOps.
For GNU/Linux 64 bit version.
Written on FreePascal (https://freepascal.org/).
Copyright (C) 2026 Artyomov Alexander
http://self-made-free.ru/
aralni@mail.ru
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU Affero General Public License as
published by the Free Software Foundation, either version 3 of the
License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Affero General Public License for more details.
You should have received a copy of the GNU Affero General Public License
along with this program. If not, see <https://www.gnu.org/licenses/>.
}
{$MODE OBJFPC}{$H+}
{$RANGECHECKS ON}
{$ASMMODE INTEL}
interface
uses
SysUtils, DataUtils, Math;
function RandomMatrix(rows, cols: Integer; minVal: Double = -0.5; maxVal: Double = 0.5): TDoubleMatrix;
function RandomArray(size: Integer; minVal: Double = -0.5; maxVal: Double = 0.5): TDoubleArray;
function AddVectors(const a, b: TDoubleArray): TDoubleArray;
function CreateZeroMatrix(rows, cols: Integer): TDoubleMatrix;
function MatrixNorm(const matrix: TDoubleMatrix): Double;
// Новые функции для Transformer
function LayerNorm(const m: TDoubleMatrix; const gamma, beta: TDoubleArray): TDoubleMatrix;
function AddMatrices(const a, b: TDoubleMatrix): TDoubleMatrix;
function ReLU(const m: TDoubleMatrix): TDoubleMatrix;
// Для Attention
function Softmax(const m: TDoubleMatrix): TDoubleMatrix;
function ConcatMatrices(const matrices: array of TDoubleMatrix): TDoubleMatrix;
function MatrixMultiply(const A, B: TDoubleMatrix): TDoubleMatrix;
function TransposeMatrix(const m: TDoubleMatrix): TDoubleMatrix;
function MatrixAdd(const A, B: TDoubleMatrix): TDoubleMatrix;
function ScaleMatrixCreate(const m: TDoubleMatrix; factor: Double): TDoubleMatrix;
procedure ScaleMatrix(var m: TDoubleMatrix; factor: Double);
function CopyMatrix(const m: TDoubleMatrix): TDoubleMatrix;
function CreateRandomMatrix(rows, cols: Integer; minVal: Double = -0.5; maxVal: Double = 0.5): TDoubleMatrix;
function Dropout(const m: TDoubleMatrix; rate: Double): TDoubleMatrix;
procedure AddNoise(var Matrix: TDoubleMatrix; NoiseLevel: Double);
procedure FillMatrix(var matrix: TDoubleMatrix; value: Double);
procedure FillArray(var arr: TDoubleArray; value: Double);
procedure UpdateMatrixAdam(var params, grads: TDoubleMatrix; var state: TAdamState; learningRate: Double);
// функции для работы с накопленными градиентами
function ScaleMatrixToSize(const m: TDoubleMatrix; newRows, newCols: Integer): TDoubleMatrix;
procedure PrintMatrix(const matrix: TDoubleMatrix; maxRows: Integer = 10; maxCols: Integer = 10; precision: Integer = 4);
procedure MatrixAddInPlace(var A: TDoubleMatrix; const B: TDoubleMatrix);
procedure ScaleMatrixInPlace(var A: TDoubleMatrix; factor: Double);
function MatrixMultiplyFast(const A, B: TDoubleMatrix): TDoubleMatrix;
// Новые функции для ImageDeblur
procedure NormalizeMatrix(var Matrix: TDoubleMatrix);
function ConvolveMatrix(const Image, Kernel: TDoubleMatrix): TDoubleMatrix;
function FlattenMatrix(const Matrix: TDoubleMatrix): TDoubleArray;
function ReshapeArrayToMatrix(const Arr: TDoubleArray; Rows, Cols: Integer): TDoubleMatrix;
function ApplyGaussianKernel(const Matrix: TDoubleMatrix; KernelSize: Integer; Sigma: Double): TDoubleMatrix;
function MatrixSubtract(const A, B: TDoubleMatrix): TDoubleMatrix;
function MatrixMean(const Matrix: TDoubleMatrix): Double;
function MatrixStdDev(const Matrix: TDoubleMatrix): Double;
function ComputeOptimalFFTSize(ImageRows, ImageCols: Integer; out OptimalRows, OptimalCols: Integer): Boolean;
implementation
{$I asmf.inc}
function RandomMatrix(rows, cols: Integer; minVal: Double; maxVal: Double): TDoubleMatrix;
var i,j: Integer;
begin Result:=nil;
SetLength(Result, rows);
for i := 0 to rows - 1 do begin
SetLength(Result[i], cols);
for j := 0 to cols - 1 do
Result[i][j] := minVal + (maxVal - minVal) * Random;
end;
end;
function RandomArray(size: Integer; minVal: Double; maxVal: Double): TDoubleArray;
var i: Integer;
begin Result:=nil;
SetLength(Result, size);
for i := 0 to size - 1 do Result[i] := minVal + (maxVal - minVal) * Random;
end;
function AddVectors(const a, b: TDoubleArray): TDoubleArray;
var i: Integer;
begin Result:=nil;
if Length(a) <> Length(b) then
raise Exception.Create('Vector lengths mismatch');
SetLength(Result, Length(a));
for i := 0 to High(a) do
Result[i] := a[i] + b[i];
end;
function CreateZeroMatrix(rows, cols: Integer): TDoubleMatrix;
var i: Integer;
begin Result:=nil;
SetLength(Result, rows);
for i := 0 to rows - 1 do SetLength(Result[i], cols);
end;
function MatrixNorm(const matrix: TDoubleMatrix): Double;
var i,j: Integer;
begin Result := 0;
for i := 0 to High(matrix) do
for j := 0 to High(matrix[i]) do
Result := Result + Sqr(matrix[i][j]);
Result := Sqrt(Result);
end;
function LayerNorm(const m: TDoubleMatrix; const gamma, beta: TDoubleArray): TDoubleMatrix;
var
i, j, size: Integer;
mean, variance, sum_val, stddev: Double;
begin Result:=nil;
if Length(m) = 0 then begin
SetLength(Result, 0, 0);
Exit;
end;
size := Length(m[0]);
if (Length(gamma) <> size) or (Length(beta) <> size) then begin
WriteLn('Ошибка LayerNorm: Несовпадение размеров. Matrix:', size,
' gamma:', Length(gamma), ' beta:', Length(beta));
Result := CopyMatrix(m);
Exit;
end;
SetLength(Result, Length(m), size);
for i := 0 to High(m) do begin
// Вычисляем среднее для текущей строки
sum_val := 0.0;
for j := 0 to size - 1 do
sum_val := sum_val + m[i][j];
mean := sum_val / size;
// Вычисляем дисперсию для текущей строки
sum_val := 0.0;
for j := 0 to size - 1 do
sum_val := sum_val + Sqr(m[i][j] - mean);
variance := sum_val / size;
stddev := Sqrt(variance + 1e-8);
// Нормализуем и применяем масштаб и смещение
for j := 0 to size - 1 do
Result[i][j] := gamma[j] * ((m[i][j] - mean) / stddev) + beta[j];
end;
end;
function AddMatrices(const a, b: TDoubleMatrix): TDoubleMatrix;
var i,j: Integer;
begin Result:=nil;
if (Length(a) <> Length(b)) or (Length(a[0]) <> Length(b[0])) then
raise Exception.Create('Matrix dimensions mismatch in AddMatrices');
SetLength(Result, Length(a), Length(a[0]));
for i := 0 to High(a) do
for j := 0 to High(a[i]) do
Result[i][j] := a[i][j] + b[i][j];
end;
function ReLU(const m: TDoubleMatrix): TDoubleMatrix;
var i,j: Integer;
begin Result:=nil;
SetLength(Result, Length(m), Length(m[0]));
for i := 0 to High(m) do
for j := 0 to High(m[i]) do
Result[i][j] := Max(0, m[i][j]);
end;
function Softmax(const m: TDoubleMatrix): TDoubleMatrix;
var
i, j: Integer;
maxVal, sum: Double;
expValues: TDoubleMatrix;
begin Result:=nil;
SetLength(expValues, Length(m), Length(m[0]));
SetLength(Result, Length(m), Length(m[0]));
for i := 0 to High(m) do begin
maxVal := MaxValue(m[i]);
sum := 0;
// Вычисляем экспоненты и сумму
for j := 0 to High(m[i]) do begin
expValues[i][j] := Exp(m[i][j] - maxVal);
sum := sum + expValues[i][j];
end;
// Нормализуем
for j := 0 to High(m[i]) do
Result[i][j] := expValues[i][j] / sum;
end;
end;
function ConcatMatrices(const matrices: array of TDoubleMatrix): TDoubleMatrix;
var
i, j, k, totalCols, offset: Integer;
begin
if Length(matrices) = 0 then
Exit(nil);
// Проверяем согласованность размеров
for i := 1 to High(matrices) do
if Length(matrices[i]) <> Length(matrices[0]) then
raise Exception.Create('All matrices must have same number of rows');
// Вычисляем общее количество столбцов
totalCols := 0;
for i := 0 to High(matrices) do
begin
if Length(matrices[i]) > 0 then
Inc(totalCols, Length(matrices[i][0]));
end;
WriteLn(' ConcatMatrices: объединяем ', Length(matrices), ' матриц в ', totalCols, ' столбцов');
// Создаем результирующую матрицу
SetLength(Result, Length(matrices[0]), totalCols);
// Заполняем результат
for i := 0 to High(matrices[0]) do
begin
offset := 0;
for j := 0 to High(matrices) do
begin
if Length(matrices[j]) > 0 then
begin
for k := 0 to High(matrices[j][0]) do
begin
Result[i][offset + k] := matrices[j][i][k];
end;
Inc(offset, Length(matrices[j][0]));
end;
end;
end;
end;
function MatrixMultiply(const A, B: TDoubleMatrix): TDoubleMatrix;
var
i, j, k: Integer;
sum: Double;
begin
// Блочное умножение для лучшей кэш-локальности
SetLength(Result, Length(A), Length(B[0]));
for i := 0 to High(A) do
begin
for k := 0 to High(B) do
begin
if A[i][k] <> 0 then // Пропускаем нулевые значения
begin
for j := 0 to High(B[0]) do
begin
Result[i][j] := Result[i][j] + A[i][k] * B[k][j];
end;
end;
end;
end;
end;
function TransposeMatrix(const m: TDoubleMatrix): TDoubleMatrix;
var i,j: Integer;
begin Result:=nil;
SetLength(Result, Length(m[0]), Length(m));
for i := 0 to High(m) do
for j := 0 to High(m[0]) do
Result[j][i] := m[i][j];
end;
function MatrixAdd(const A, B: TDoubleMatrix): TDoubleMatrix;
var i,j,rows,cols: Integer;
begin
// Проверка размеров (из предыдущих версий)
if (Length(A) <> Length(B)) or (Length(A[0]) <> Length(B[0])) then begin
WriteLn('ОШИБКА MatrixAdd: Несовпадение размеров ');
WriteLn(' A: ', Length(A), 'x', Length(A[0]));
WriteLn(' B: ', Length(B), 'x', Length(B[0]));
Halt;
end;
// Если одна из матриц пустая, возвращаем другую
if (Length(A) = 0) or (Length(A[0]) = 0) then begin
WriteLn('MatrixAdd: Матрица A пустая, возвращаем B');
Halt;
Exit(CopyMatrix(B));
end;
if (Length(B) = 0) or (Length(B[0]) = 0) then
begin
WriteLn('MatrixAdd: Матрица B пустая, возвращаем A');
Halt;
Exit(CopyMatrix(A));
end;
// Выбираем минимальные размеры
rows := Min(Length(A), Length(B));
cols := Min(Length(A[0]), Length(B[0]));
SetLength(Result, rows, cols);
for i := 0 to rows - 1 do
begin
for j := 0 to cols - 1 do
begin
Result[i][j] := A[i][j] + B[i][j];
end;
end;
end;
// Масштабирование матрицы (создаёт новую матрицу)
function ScaleMatrixCreate(const m: TDoubleMatrix; factor: Double): TDoubleMatrix;
var i,j: Integer;
begin Result:=nil;
SetLength(Result, Length(m), Length(m[0]));
for i := 0 to High(m) do
for j := 0 to High(m[0]) do
Result[i][j] := m[i][j] * factor;
end;
// Масштабирование матрицы (in-place модификация)
procedure ScaleMatrix(var m: TDoubleMatrix; factor: Double);
var i,j: Integer;
begin
for i := 0 to High(m) do
for j := 0 to High(m[0]) do
m[i][j] := m[i][j] * factor;
end;
function CopyMatrix(const m: TDoubleMatrix): TDoubleMatrix;
var
i: Integer;
begin
// ✅ ЗАЩИТА: Проверяем входные данные
if (Length(m) = 0) then
begin
SetLength(Result, 0, 0);
Exit;
end;
SetLength(Result, Length(m));
for i := 0 to High(m) do
begin
// ✅ ЗАЩИТА: Проверяем каждую строку
if Length(m[i]) > 0 then
Result[i] := Copy(m[i])
else
SetLength(Result[i], 0);
end;
end;
function Dropout(const m: TDoubleMatrix; rate: Double): TDoubleMatrix;
var i,j: Integer;
begin
Result := CopyMatrix(m);
if rate > 0 then
begin
for i := 0 to High(m) do
for j := 0 to High(m[0]) do
if Random < rate then
Result[i][j] := 0
else
Result[i][j] := m[i][j] / (1 - rate);
end;
end;
function CreateRandomMatrix(rows, cols: Integer; minVal: Double; maxVal: Double): TDoubleMatrix;
var i,j: Integer;
begin Result:=nil;
SetLength(Result, rows, cols);
for i := 0 to rows - 1 do begin
for j := 0 to cols - 1 do begin
Result[i][j] := minVal + (maxVal - minVal) * Random;
end;
end;
end;
procedure AddNoise(var Matrix: TDoubleMatrix; NoiseLevel: Double);
var i,j: Integer;
begin
for i := 0 to High(Matrix) do
for j := 0 to High(Matrix[i]) do
Matrix[i][j] := Matrix[i][j] + (Random * 2 - 1) * NoiseLevel;
end;
procedure FillMatrix(var matrix: TDoubleMatrix; value: Double);
var i,j: Integer;
begin
for i := 0 to High(matrix) do
for j := 0 to High(matrix[i]) do
matrix[i][j] := value;
end;
procedure FillArray(var arr: TDoubleArray; value: Double);
var i: Integer;
begin
for i := 0 to High(arr) do arr[i] := value;
end;
procedure UpdateMatrixAdam(var params, grads: TDoubleMatrix;
var state: TAdamState; learningRate: Double);
var
i,j: Integer;
mHat, vHat: Double;
begin
Inc(state.Timestep);
for i := 0 to High(params) do
for j := 0 to High(params[0]) do begin
state.M[i][j] := state.Beta1 * state.M[i][j] + (1 - state.Beta1) * grads[i][j];
state.V[i][j] := state.Beta2 * state.V[i][j] + (1 - state.Beta2) * Sqr(grads[i][j]);
mHat := state.M[i][j] / (1 - Power(state.Beta1, state.Timestep));
vHat := state.V[i][j] / (1 - Power(state.Beta2, state.Timestep));
params[i][j] := params[i][j] - learningRate * mHat / (Sqrt(vHat) + 1e-8);
end;
end;
function ScaleMatrixToSize(const m: TDoubleMatrix; newRows, newCols: Integer): TDoubleMatrix;
var
i, j: Integer;
begin
if (newRows <= 0) or (newCols <= 0) then
begin
SetLength(Result, 0, 0);
Exit;
end;
SetLength(Result, newRows, newCols);
FillMatrix(Result, 0.0);
// Копируем данные с обрезкой или дополнением нулями
for i := 0 to Min(newRows - 1, High(m)) do
begin
for j := 0 to Min(newCols - 1, High(m[i])) do
begin
Result[i][j] := m[i][j];
end;
end;
end;
procedure PrintMatrix(const matrix: TDoubleMatrix; maxRows: Integer = 10; maxCols: Integer = 10; precision: Integer = 4);
var
i, j, displayedRows, displayedCols: Integer;
rowStr: string;
begin
if Length(matrix) = 0 then begin
WriteLn('Matrix is empty');
Exit;
end;
// Определяем сколько строк и столбцов будем выводить
displayedRows := Min(maxRows, Length(matrix));
displayedCols := Min(maxCols, Length(matrix[0]));
WriteLn('Matrix [', Length(matrix), 'x', Length(matrix[0]), ']:');
for i := 0 to displayedRows - 1 do begin
rowStr := '';
for j := 0 to displayedCols - 1 do begin
// Форматируем число с заданной точностью
rowStr := rowStr + Format('%.' + IntToStr(precision) + 'f', [matrix[i][j]]) + ' ';
end;
// Добавляем многоточие, если не все столбцы показаны
if displayedCols < Length(matrix[0]) then rowStr := rowStr + '...';
WriteLn(rowStr);
end;
// Добавляем многоточие, если не все строки показаны
if displayedRows < Length(matrix) then
WriteLn('... (', Length(matrix) - displayedRows, ' more rows)');
end;
procedure MatrixAddInPlace(var A: TDoubleMatrix; const B: TDoubleMatrix);
var
i, j: Integer;
begin
for i := 0 to High(A) do
for j := 0 to High(A[i]) do
A[i][j] := A[i][j] + B[i][j];
end;
procedure ScaleMatrixInPlace(var A: TDoubleMatrix; factor: Double);
var
i, j: Integer;
begin
for i := 0 to High(A) do
for j := 0 to High(A[i]) do
A[i][j] := A[i][j] * factor;
end;
function MatrixMultiplyFast(const A, B: TDoubleMatrix): TDoubleMatrix;
var
i, j, k: Integer;
sum: Double;
begin
// Оптимизированная версия умножения с лучшей кэш-локальностью
SetLength(Result, Length(A), Length(B[0]));
// Заранее заполняем нулями
for i := 0 to High(Result) do
for j := 0 to High(Result[0]) do
Result[i][j] := 0.0;
for i := 0 to High(A) do
begin
for k := 0 to High(B) do
begin
if A[i][k] <> 0 then // Пропускаем нулевые значения
begin
for j := 0 to High(B[0]) do
begin
Result[i][j] := Result[i][j] + A[i][k] * B[k][j];
end;
end;
end;
end;
end;
// НОВЫЕ ФУНКЦИИ ДЛЯ IMAGEDEBLUR
procedure NormalizeMatrix(var Matrix: TDoubleMatrix);
var
Sum: Double;
I, J: Integer;
begin
if Length(Matrix) = 0 then Exit;
Sum := 0;
for I := 0 to High(Matrix) do
for J := 0 to High(Matrix[0]) do
Sum := Sum + Matrix[I, J];
if Abs(Sum) > 1e-10 then
for I := 0 to High(Matrix) do
for J := 0 to High(Matrix[0]) do
Matrix[I, J] := Matrix[I, J] / Sum;
end;
function ConvolveMatrix(const Image, Kernel: TDoubleMatrix): TDoubleMatrix;
var
Y, X, KY, KX, I, J: Integer;
Sum: Double;
KernelCenterY, KernelCenterX: Integer;
begin
if (Length(Image) = 0) or (Length(Kernel) = 0) then
begin
SetLength(Result, 0, 0);
Exit;
end;
SetLength(Result, Length(Image), Length(Image[0]));
KernelCenterY := Length(Kernel) div 2;
KernelCenterX := Length(Kernel[0]) div 2;
for Y := 0 to High(Image) do
begin
for X := 0 to High(Image[0]) do
begin
Sum := 0;
for I := -KernelCenterY to KernelCenterY do
begin
for J := -KernelCenterX to KernelCenterX do
begin
if (Y + I >= 0) and (Y + I <= High(Image)) and
(X + J >= 0) and (X + J <= High(Image[0])) then
begin
Sum := Sum + Image[Y + I, X + J] *
Kernel[I + KernelCenterY, J + KernelCenterX];
end;
end;
end;
Result[Y, X] := Sum;
end;
end;
end;
function FlattenMatrix(const Matrix: TDoubleMatrix): TDoubleArray;
var
I, J, K: Integer;
begin
if (Length(Matrix) = 0) or (Length(Matrix[0]) = 0) then
begin
SetLength(Result, 0);
Exit;
end;
SetLength(Result, Length(Matrix) * Length(Matrix[0]));
K := 0;
for I := 0 to High(Matrix) do
for J := 0 to High(Matrix[0]) do
begin
Result[K] := Matrix[I, J];
Inc(K);
end;
end;
function ReshapeArrayToMatrix(const Arr: TDoubleArray; Rows, Cols: Integer): TDoubleMatrix;
var
I, J, K: Integer;
begin
if (Length(Arr) = 0) or (Rows * Cols <> Length(Arr)) then
begin
SetLength(Result, 0, 0);
Exit;
end;
SetLength(Result, Rows, Cols);
K := 0;
for I := 0 to Rows - 1 do
for J := 0 to Cols - 1 do
begin
Result[I, J] := Arr[K];
Inc(K);
end;
end;
function ApplyGaussianKernel(const Matrix: TDoubleMatrix; KernelSize: Integer; Sigma: Double): TDoubleMatrix;
var
Kernel: TDoubleMatrix;
I, J, Center: Integer;
Sum, Value: Double;
begin
if Length(Matrix) = 0 then
Exit(CopyMatrix(Matrix));
// Создаем гауссовское ядро
SetLength(Kernel, KernelSize, KernelSize);
Center := KernelSize div 2;
Sum := 0;
for I := 0 to KernelSize - 1 do
begin
for J := 0 to KernelSize - 1 do
begin
Value := Exp(-((I - Center)*(I - Center) + (J - Center)*(J - Center)) / (2 * Sigma * Sigma));
Kernel[I, J] := Value;
Sum := Sum + Value;
end;
end;
// Нормализуем ядро
for I := 0 to KernelSize - 1 do
for J := 0 to KernelSize - 1 do
Kernel[I, J] := Kernel[I, J] / Sum;
// Применяем свертку
Result := ConvolveMatrix(Matrix, Kernel);
SetLength(Kernel, 0);
end;
function MatrixSubtract(const A, B: TDoubleMatrix): TDoubleMatrix;
var
I, J, Rows, Cols: Integer;
begin
if (Length(A) <> Length(B)) or (Length(A[0]) <> Length(B[0])) then
begin
WriteLn('MatrixSubtract: Размеры матриц не совпадают');
Halt;
end;
Rows := Length(A);
Cols := Length(A[0]);
SetLength(Result, Rows, Cols);
for I := 0 to Rows - 1 do
for J := 0 to Cols - 1 do
Result[I, J] := A[I, J] - B[I, J];
end;
function MatrixMean(const Matrix: TDoubleMatrix): Double;
var
I, J: Integer;
Sum: Double;
begin
if Length(Matrix) = 0 then
Exit(0);
Sum := 0;
for I := 0 to High(Matrix) do
for J := 0 to High(Matrix[0]) do
Sum := Sum + Matrix[I, J];
Result := Sum / (Length(Matrix) * Length(Matrix[0]));
end;
function MatrixStdDev(const Matrix: TDoubleMatrix): Double;
var
I, J: Integer;
Mean, SumSquares: Double;
begin
if Length(Matrix) = 0 then
Exit(0);
Mean := MatrixMean(Matrix);
SumSquares := 0;
for I := 0 to High(Matrix) do
for J := 0 to High(Matrix[0]) do
SumSquares := SumSquares + Sqr(Matrix[I, J] - Mean);
Result := Sqrt(SumSquares / (Length(Matrix) * Length(Matrix[0])));
end;
function ComputeOptimalFFTSize(ImageRows, ImageCols: Integer; out OptimalRows, OptimalCols: Integer): Boolean;
begin
if (ImageRows <= 0) or (ImageCols <= 0) then
begin
OptimalRows := 0;
OptimalCols := 0;
Result := False;
Exit;
end;
// Находим ближайшую степень двойки
OptimalRows := 1;
while OptimalRows < ImageRows do
OptimalRows := OptimalRows shl 1;
OptimalCols := 1;
while OptimalCols < ImageCols do
OptimalCols := OptimalCols shl 1;
Result := True;
end;
initialization
Randomize;
end.
