Developing.ru

Код: Выделить всё

unit ProcessingImages;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Chart, Buttons, BmpChart, Jpeg, Math, Series, BmpChart, GraphicsManager;

type
TProcessingImages = class(TForm)
PictureOpen: TOpenPicture;
PictureSave: TSavePicture;
procedure GraphicsGetBmpInfoExecute(Sender: TObject);
procedure Transfer_Function(Sender: TObject);
procedure Automatic_Mode(Sender: TObject);
procedure Operational_Mode(Sender: TObject);

public
procedure OpenBitmap(const FileName: string; Bitmap: TBitmap);
procedure SaveBitmap(const FileName: string; Bitmap: TBitmap);
procedure CopyBitmap(Bitmap: TBitmap; Image: TImage; ScrollBox: TScrollBox);
function CopyBitmap(SourceBitmap, TargetBitmap: TBitmap;
BmpSize: TSize): Boolean;
function ComputeBmpSize(SourceBmpSize: TSize;
var TargetBmpSize: TSize): Boolean;
function GetBmpInfo(Bitmap: TBitmap; out BmpInfo: TBmpInfo;
BmpInfoType: TBmpInfoType; IntensityType: TIntensityType): Boolean;

function ScaleBitmap(var Bitmap: TBitmap; BmpSize: TSize): Boolean;
function ScanBitmap(Bitmap: TBitmap; Data: Pointer = nil;
Mask: TBitmap = nil): Boolean;
end;

var
ProcessingImages: TProcessingImages;

implementation

{Загрузка изображения для обработки}
procedure OpenBitmap(const FileName: string; Bitmap: TBitmap);
var
JpegImage: TJpegImage;
Ext: string;
begin
Ext := LowerCase(ExtractFileExt(FileName));
if Ext = '.bmp' then
Bitmap.LoadFromFile(FileName)
else if Ext = '.jpg' then begin
JpegImage := TJpegImage.Create;
JpegImage.LoadFromFile(FileName);
Bitmap.Assign(JpegImage);
JpegImage.Free;
end;
end;
if Bitmap.PixelFormat < pf8bit then
Bitmap.PixelFormat := pf8bit;
end;

{Сохранение изображения после обработки}
procedure SaveBitmap(const FileName: string; Bitmap: TBitmap);
var
JpegImage: TJpegImage;
Ext: string;
begin
Ext := LowerCase(ExtractFileExt(FileName));
if Ext = '.bmp' then
Bitmap.SaveToFile(FileName)
else begin
JpegImage := TJpegImage.Create;
with JpegImage do
begin
Assign(Bitmap);
SaveToFile(FileName);
end;
JpegImage.Free;
end;
end;
end;

procedure CopyBitmap(Bitmap: TBitmap; Image: TImage;
ScrollBox: TScrollBox);
begin
with ScrollBox do
begin
with HorzScrollBar do
begin
Range := Bitmap.Width;
Position := IfThen(Range > Width, (Range - Width) div 2, 0);
end;
with VertScrollBar do
begin
Range := Bitmap.Height;
Position := IfThen(Range > Width, (Range - Width) div 2, 0);
end;
end; 
with Image, Canvas do
begin
Brush.Color := RGB(FR, FG, FB);
FillRect(Rect(0, 0, Width, Height));
CopyBitmap(Bitmap, Picture.Bitmap, Size(Width, Height));
end;
end;

procedure GraphicsGetBmpInfoExecute(Sender: TObject);
var
BmpInfo_: TBmpInfo;
begin
with BmpChart do GetBmpInfo(FSource, BmpInfo_,
bitPercent, Intensities(itRed in ITypes));
with BmpChart do
begin
DeleteSeries;
BottomAxis.Maximum := FSource.Width;
if itRed in ITypes then
UpdateSeries(CreateSeries(clRed), BmpInfo_[itRed]);
end;
ReleaseBmpInfo(BmpInfo_);
end;
end;
end;

function CopyBitmap(SourceBitmap, TargetBitmap: TBitmap;
BmpSize: TSize): Boolean;
var
SourceBmpSize: TSize;
begin
Result := not SourceBitmap.Empty;
if not Result then Exit;
SourceBmpSize := Size(SourceBitmap.Width, SourceBitmap.Height);
Result := ComputeBmpSize(SourceBmpSize, BmpSize);
with TargetBitmap do
begin
PixelFormat := SourceBitmap.PixelFormat;
Width := BmpSize.cx;
Height := BmpSize.cy;
Canvas.StretchDraw(Rect(0, 0, BmpSize.cx, BmpSize.cy), SourceBitmap);
end;
end;

function ComputeBmpSize(SourceBmpSize: TSize;
var TargetBmpSize: TSize): Boolean;
begin
Result := (TargetBmpSize.cx > 0) and (TargetBmpSize.cy > 0);
if not Result then Exit;
if SourceBmpSize.cx / TargetBmpSize.cx < SourceBmpSize.cy / TargetBmpSize.cy then
TargetBmpSize.cx := SourceBmpSize.cx * TargetBmpSize.cy div SourceBmpSize.cy
else TargetBmpSize.cy := SourceBmpSize.cy * TargetBmpSize.cx div SourceBmpSize.cx;
Result := (TargetBmpSize.cx > 0) and (TargetBmpSize.cy > 0);
end;

function GetBmpInfo(Bitmap: TBitmap; out BmpInfo: TBmpInfo;
BmpInfoType: TBmpInfoType; IntensityType: TIntensityType): Boolean;
var
Intensities: TIntensities;
begin
Intensities := NegativeIntensities;
Intensities[IntensityType] := True;
Result := GetBmpInfo(Bitmap, BmpInfo, BmpInfoType, Intensities);
end;
function TMain.GetBmpInfo(Bitmap: TBitmap; out BmpInfo: TBmpInfo;
BmpInfoType: TBmpInfoType; Intensities: TIntensities): Boolean;
var
I: TIntensityType;
J, K: Integer;
GetBmpInfoData: TGetBmpInfoData;
begin
Result := Intensities[itRed];
if not Result then Exit;
J := Bitmap.Width;
NewBmpInfo(BmpInfo, J, Intensities);
GetBmpInfoData.Intensities := Intensities;
GetBmpInfoData.BmpInfo := BmpInfo;
Result := ScanBitmap(Bitmap, GetBmpInfoData);
end;
begin
K := Bitmap.Height;
for I := Low(TIntensityType) to High(TIntensityType) do 
if Intensities[I] then
for J := Low(BmpInfo[I]) to High(BmpInfo[I]) do 
BmpInfo[I][J] := BmpInfo[I][J] div K;
end;
end;

{Масштабирование изображения}
function ScaleBitmap(var Bitmap: TBitmap;
BmpSize: TSize): Boolean;
var
NewBitmap: TBitmap;
begin
Result := not Bitmap.Empty and
(BmpSize.cx > 0) and (BmpSize.cy > 0);
if not Result then Exit;
if (Bitmap.Width = BmpSize.cx) and
(Bitmap.Height = BmpSize.cy) then Exit;
NewBitmap := TBitmap.Create;
try
CopyBitmap(Bitmap, NewBitmap, BmpSize);
Bitmap.Free;
Bitmap := NewBitmap;
except
NewBitmap.Free;
end;
end;

function ScanBitmap(Bitmap: TBitmap; Data: Pointer;
Mask: TBitmap): Boolean;
var
I, J, Count: Integer;
K: TIntensityType;
Masked_, Positive, Changed, Continue: Boolean;
IntensityRec: PIntensityRec_;
P1, P2: Pointer;
begin
Result := not Bitmap.Empty;
if not Result then Exit;
with Bitmap do
begin
PixelFormat := DefPixelFormat;
Count := Width * DefByteCount;
end;
Masked_ := FMasked;
if Masked_ then
begin
if (Mask = nil) and not FMaskBitmap.Empty then 
Mask := FMaskBitmap;
Masked_ := Assigned(Mask);
if Masked_ and ((Mask.Width < Bitmap.Width) or 
(Mask.Height < Bitmap.Height)) then
if Mask = FMaskBitmap then Masked_ := False
else ComputeMask(Mask, Size(Bitmap.Width, Bitmap.Height));
end;
if Masked_ then Mask.PixelFormat := DefPixelFormat;
P2 := nil;
I := 0;
while I < Bitmap.Height do begin
P1 := Bitmap.ScanLine[I];
if Masked_ then P2 := Mask.ScanLine[I];
J := 0;
while J < Count do begin
for K := Low(TIntensityType) to High(TIntensityType) do
IntensityRec[K] := PByte(Integer(P1) + J + Ord(K));
Continue := True;
if Masked_ then
begin
for K := Low(TIntensityType) to High(TIntensityType) do
begin
Positive := FPositiveColor[K] = PByte(Integer(P2) + J + Ord(K));
if not Positive then Break;
end;
if Positive then DoScanData(IntensityRec, DefPixelFormat, 
J, I, Data, Continue, Changed)
else Changed := False;
end else DoScanData(IntensityRec, DefPixelFormat, J, I, Data, Continue, Changed);
if not Continue then Exit
else if not Changed then Inc(J, DefByteCount)
else if I >= Bitmap.Height then Exit;
end;
if not Changed then Inc(I);
end;
end;

{Метод, основанный на изменении ширины передаточной функции - начало}
procedure Transfer_Function(Sender: TObject);
var
bmp:TBitmap;
b,e,w:integer;
i,j:integer;
p:PByteArray;
v:array of byte;
begin
bmp := TBitmap.Create;
try
Caption := 'Подождите идет обработка...';
Application.ProcessMessages;
bmp.Assign(bmp0);
b := StrToInt(BeginEdit.text);
e := b + StrToInt(WidthEdit.Text);
w := e - b;
SetLength(v, bmp.Width);
for i:=0 to bmp.Height-1 do begin
p := bmp.ScanLine[i];
for j:=0 to bmp.Width-1 do
if p[j*4] < b then v[j] := 0
else if p[j*4] > e then v[j] := 255
else v[j] := round((p[j*4] - b) * 255 / w);
for j:=0 to bmp.Width-1 do
bmp.Canvas.Pixels[j,i] := (v[j] shl 16) + (v[j] shl 8) + (v[j]);
end;
Main.FSource.Canvas.CopyRect(r, bmp.Canvas, r0);
Main.FormResize(Sender);
finally
bmp.Free;
Caption := 'Обработка изображения завершена';
end;
end;

procedure FormShow(Sender: TObject);
var
x,y,i,vl:integer;
intenses,nintenses:TIntArray;
p:PByteArray;
begin
if Main.MFAll.Checked then begin
r.Left := 0; r.Top :=0;
r.Right := Main.FSource.Width;
r.Bottom := Main.FSource.Height;
end
else begin
r.Left := round(area.Left * kx);
r.Right := round(area.Right * kx);
r.Top := round(area.Top * ky);
r.Bottom := round(area.Bottom * ky);
end;
r0 := Rect(0, 0, r.Right - r.Left, r.Bottom - r.Top);

bmp0.Width := r0.Right;
bmp0.Height := r0.Bottom;
bmp0.PixelFormat := pf32bit;
bmp0.Canvas.CopyRect(r0, Main.FSource.Canvas, r);

bmp0.PixelFormat := pf32bit;
SetLength(intenses, 256);
for i:=0 to 255 do
intenses[i] := 0;
for y:=0 to bmp0.Height-1 do begin
p := bmp0.ScanLine[y];
for x:=0 to bmp0.Width-1 do
inc(intenses[p[4*x]]);
end;
for i:=0 to 255 do
if intenses[i] > 0 then begin
x := i;
break;
end;
for i:=255 downto 0 do
if intenses[i] > 0 then begin
y := i;
break;
end;
SetLength(nintenses, 256);
for i:=0 to 255 do
nintenses[i] := 0;
for i:=x to y do begin
vl := round(255 * (i - x) / (y - x));
nintenses[vl] := nintenses[vl] + intenses[i];
end;
with BmpChart do begin
DeleteSeries;
BottomAxis.Maximum := 255;
UpdateSeries(CreateSeries(clBlack), nintenses);
end;

procedure BeginEditChange(Sender: TObject);
var
v:integer;
begin
if BeginEdit.Text = '' then exit;
v := StrToInt(BeginEdit.Text);
if v < 0 then BeginEdit.Text := '0';
if v > 255 then BeginEdit.Text := '255';
BeginScroll.Position := StrToInt(BeginEdit.Text);
if CheckBox1.Checked then ApplyBtnClick(Sender);
end;

procedure WidthEditChange(Sender: TObject);
var
v:integer;
begin
if WidthEdit.Text = '' then exit;
v := StrToInt(WidthEdit.Text);
if v < 0 then WidthEdit.Text := '0';
if v > 255 then WidthEdit.Text := '255';
end;
{Метод, основанный на изменении ширины передаточной функции - конец}

{Автоматический режим (метод выравнивания гистограммы) - начало}
procedure Automatic_Mode(Sender: TObject);
const
dq = 32;
var
r,r0:TRect;
bmp:TBitmap;
hist,histn:array[0..2, 0..255] of integer;
k,i,j,l,m:integer;
s1,s2:array[0..2]of integer;
p:PByteArray;
h:array[0..2, 0..dq-1] of integer;
v:array[0..2] of array of integer;
vl:integer;
flags:array[0..2] of boolean;
min,max:array[0..2] of byte;
mx:byte;
begin
if MFAll.Checked then begin
r.Left := 0; r.Top :=0;
r.Right := FSource.Width;
r.Bottom := FSource.Height;
end
else begin
r.Left := round(area.Left * kx);
r.Right := round(area.Right * kx);
r.Top := round(area.Top * ky);
r.Bottom := round(area.Bottom * ky);
end;
r0 := Rect(0, 0, r.Right - r.Left, r.Bottom - r.Top);
bmp := TBitmap.Create;
try
bmp.Width := r0.Right;
bmp.Height := r0.Bottom;
bmp.PixelFormat := DefPixelFormat;
bmp.Canvas.CopyRect(r0, FSource.Canvas, r);

for i:=0 to 255 do begin
hist[0][i] := 0; //b
hist[1][i] := 0; //g
hist[2][i] := 0; //r
end;
for i:=0 to dq-1 do begin
h[0][i] := 0; //b
h[0][i] := 0; //g
h[0][i] := 0; //r
end;

{Построение гистограммы}
for i:=0 to bmp.Height-1 do begin
p := bmp.ScanLine[i];
for j:=0 to bmp.Width-1 do begin
for l:=0 to 2 do begin
inc(hist[l][p[j*4+l]]); //b
end;
end;
if i mod 10 = 0 then begin
StatusBar.SimpleText := IntToStr(round(0 + 50 * i / bmp.Height))+'%';
Application.ProcessMessages;
end;
end;

{Нормировка изображения}
for l:=0 to 2 do begin
min[l] := 255;
max[l] := 0;
i := 0;
while (i < 256) do begin
if hist[l][i] > 0 then begin
min[l] := i;
break;
end;
inc(i);
end;
i := 255;
while (i >= 0) do begin
if hist[l][i] > 0 then begin
max[l] := i;
break;
end;
dec(i);
end;
mx := max[l];
max[l] := max[l] - min[l];
for i:=0 to 255 do
histn[l][i] := 0;
for i:=min[l] to mx do begin
vl := round(255 * (i - min[l]) / max[l]);
histn[l][vl] := hist[l][i];
end;
end;

{Разбиение на однородные участки}
for l:=0 to 2 do begin
s1[l] := 0; s2[l] := 0;
end;
k := bmp.Height * bmp.Width div dq;
for i:=0 to 255 do begin
for l:=0 to 2 do begin //b to r
inc(s1[l], histn[l][i]);
if s1[l] >= k then begin
h[l][s2[l]] := i;
s1[l] := 0;
inc(s2[l]);
end;
end;
end;

{Преобразования интенсивности}
SetLength(v[0], bmp.Width);
SetLength(v[1], bmp.Width);
SetLength(v[2], bmp.Width);
for i:=0 to bmp.Height-1 do begin
p := bmp.ScanLine[i];
for j:=0 to bmp.Width-1 do
for l:=0 to 2 do begin
if flags[l] then begin
{нормировка}
vl := round(255 * (p[j*4+l] - min[l]) / max[l]);
for m:=0 to s2[l]-1 do
if vl <= h[l][m] then break;
v[l][j] := round(255 * (m / s2[l]));
end
else v[l][j] := p[j*4+l];
end;
for j:=0 to bmp.Width-1 do
bmp.Canvas.Pixels[j,i] := (v[0][j] shl 16) + (v[1][j] shl 8) + (v[2][j]);
if i mod 10 = 0 then begin
StatusBar.SimpleText := IntToStr(round(50 + 50 * i / bmp.Height))+'%';
Application.ProcessMessages;
end;
end;
FSource.Canvas.CopyRect(r, bmp.Canvas, r0);
FormResize(Sender);
finally
bmp.Free;
end;
end;
{Автоматический режим - конец}

{Операторный метод - начало}
procedure Operational_Mode(Sender: TObject);
var
i:integer;
begin
ChartForm.BmpChart.Correct;
with Main.GraphicsManager do
SetBmpInfo(bmp, ChartForm.BmpChart.BmpInfo, Intensities(
itRed in ChartForm.BmpChart.ITypes,
itGreen in ChartForm.BmpChart.ITypes,
itBlue in ChartForm.BmpChart.ITypes{,
itAlpha in ChartForm.BmpChart.ITypes}),
NegativeIntensities);

{цветовой канал серого}
if itAlpha in BmpChart.ITypes then
for i:=0 to High(ChartForm.BmpChart.BmpInfo[itAlpha]) do
ChartForm.BmpChart.BmpInfo[itAlpha][i] := round(
sqrt( sqr(ChartForm.BmpChart.BmpInfo[itRed][i]) +
sqr(ChartForm.BmpChart.BmpInfo[itGreen][i]) +
sqr(ChartForm.BmpChart.BmpInfo[itBlue][i])));
end;

procedure CloseBtnClick(Sender: TObject);
begin
Close;
Main.StatusBar.SimpleText := 'Для обработки фрагмента изображения выделите его мышью, иначе обрабатываться будет все изображение';
end;

procedure FormCreate(Sender: TObject);
begin
bmp := TBitmap.Create;
orig := TBitmap.Create;
with Main.GraphicsManager, BmpChart do begin
SeriesClass := TLineSeries;
ITypes := [itBlue, itGreen, itRed, itAlpha];
Title.Text.Clear;
Title.Text.Add('Гистограмма распределения яркости ');
end;
end;

procedure FormShow(Sender: TObject);
var
BmpInfo_: TBmpInfo;
i{,max}:integer;

begin
with Main.GraphicsManager, BmpChart do GetBmpInfo(bmp,
BmpInfo_, bitPercent{bitAbsolute}, Intensities(itRed in ITypes, itGreen in ITypes,
itBlue in ITypes, itAlpha in ITypes));

{цветовой канал серого}
if itAlpha in BmpChart.ITypes then
for i:=0 to High(BmpInfo_[itAlpha]) do
BmpInfo_[itAlpha][i] := round(sqrt( sqr(BmpInfo_[itRed][i])/3 +
sqr(BmpInfo_[itGreen][i])/3 + sqr(BmpInfo_[itBlue][i])/3));

try
with ChartForm.BmpChart do begin
DeleteSeries;
LeftAxis.Maximum := _100Percent{ChartForm.bmp.Height * 255};
BottomAxis.Maximum := ChartForm.bmp.Width;
if itAlpha in ITypes then
UpdateSeries(CreateSeries(clBlack), BmpInfo_[itAlpha]);
end;
end;

procedure ApplyBtnClick(Sender: TObject);
begin
Main.FSource.Canvas.CopyRect(r, bmp.Canvas, r0);
Main.FormResize(Sender);
FormShow(Sender);
end;
{Операторный метод - конец}

end.