Вообщем разобрался ! (в процессе упрощения кода ) Спасибо за отклики !
Зуб, ты прав и неправ одновременно ...
Дело не в режиме отладки как я думал, а в странном поведении TBitmap в одно битовом режиме ...
(а отладка просто вылезала как "очевидная причина" ввиду устоявшегося привычного набора действий при запуске программы из под среды : сразу все проверить не загружая картинки)
Суть (как я уже писал другой теме ) в том что
любое обращение к данным в обход стандартных методов в одно битовом режиме переводит TBitmap в "не изменяемый режим" .
И любое действие (Очистка, Освобождение памяти или изменение размера ) вызывает исключение ...
Для теста на скорость это несущественно но я не учел необходимость масштабирования при загрузке как результат если загружать сразу (или использовать только заранее загруженную картину ) все работало нормально но стоило
повторно загрузить битмап другого размера возникали ошибки при поиске контуров
Загрузка с масштабированием решила проблему ДЛЯ ТЕСТА . Но "не понятка" осталась ...
- Код: Выделить всё
procedure TBTForm.Button1Click(Sender: TObject);
Var f:String;
im:Timage;
begin
GetDir(0,F);
OpenDialog1.InitialDir:=F;
OpenDialog1.FileName:='*.bmp;*.jpg;*.png';
If OpenDialog1.Execute then begin
im:=Timage.Create(nil);
im.Picture.LoadFromFile(OpenDialog1.FileName);
image1.Picture.Bitmap.Canvas.
StretchDraw(rect(0,0,image1.Picture.Bitmap.Width,image1.Picture.Bitmap.Height),im.Picture.Bitmap);
im.Free;
end;
end;
Зы
Полный код "урезанного" тестового модуля
(Для нормальной работы нужна предварительно загруженная (во время создания формы ) картинка TBTForm.Image1 )
Формат "двухцветный" Чб 24 бита ...
- Код: Выделить всё
unit BTun1;
{$mode objfpc}{$H+}
interface
uses
Windows,Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,
Buttons, StdCtrls,Math,LCLType;
type
{ TBTForm }
TBTForm = class(TForm)
Button1: TButton;
Button2: TButton;
Button4: TButton;
CheckBox1: TCheckBox;
Image1: TImage;
Image2: TImage;
Label2: TLabel;
Label3: TLabel;
ListBox2: TListBox;
OpenDialog1: TOpenDialog;
Panel1: TPanel;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
private
public
const B1:TBitmap=nil;
end;
var
BTForm: TBTForm;
implementation
{$R *.lfm}
{ TBTForm }
Function InR(AA,B,C:Longint):Boolean;
begin
InR:=((AA>=B) And (AA<=C));
End;
// Только 24 Бита ! Запись
Procedure Set_Pixel(Var BB:TBitmap;X,Y,C:Integer);
Type
TA=Array[0..2] of byte;
var
PA:^TA;
begin
if bb = NIL then exit;
if not InR(x,0,bb.Width-1) then exit;
if not InR(y,0,bb.Height-1) then exit;
Bb.BeginUpdate; ;
pa:=Pointer( BB.ScanLine[y]+(x *3));
pa^[0]:=Blue(C);
pa^[1]:=Green(C);
pa^[2]:=red(C);
Bb.EndUpdate;
end;
// Только 24 Бита ! Чтение
Function Get_Pixel(Const BB:TBitmap;X,Y:Integer):Integer;
Type
TA=Array[0..2] of byte;
Var
PA:^TA;
n:integer;
begin
Get_Pixel:=-1;
if bb = NIL then exit;
if not InR(x,0,bb.Width-1) then exit;
if not InR(y,0,bb.Height-1) then exit;
pa:=Pointer( BB.ScanLine[y]+(x *3));
Get_Pixel:=rgb(pa^[2],pa^[1],pa^[0]);
end;
Var
BytePerLine:Longint;
// Доступ к одно битовым битмапам Чтение
function Get_Pixel_State(Var B:TbitMap; x, y: integer): integer;
Var
addrPixel:PByte;
begin
addrPixel:=Pointer(B.ScanLine[y]+(x div 8));
result:=integer(((addrPixel^ shl (x and 7)) and $80)=$80);
end;
// Доступ к одно битовым битмапам Запись
procedure Change_Pixel_State(Var B:TbitMap; x, y, c: integer);
var
addrPixel:PByte;
begin
addrPixel:=Pointer(B.ScanLine[y]+(x div 8));
if (c=1) then
addrPixel^:=Byte(addrPixel^ or ($80 shr (x and 7)))
else
addrPixel^:=Byte(addrPixel^ and ($80 shr (x and 7) xor $ff));
end;
// Конверсия
procedure TBTForm.Button2Click(Sender: TObject);
Type A=Array[0..1] Of byte;
var X,Y:Integer;
BA,ba2:^A;
begin
if B1= nil then b1:=TBitmap.Create ;
B1.PixelFormat:=pf1bit;
b1.SetSize(image1.Picture.Bitmap.Width,image1.Picture.Bitmap.Height);
// b1.Canvas.Draw(0,0,image1.Picture.Bitmap); // Так не работает !
image2.Picture.Bitmap.SetSize(B1.Width,b1.Height);
b1.BeginUpdate;
For Y:=0 To b1.Height-1 do For X:=0 To B1.Width-1 do
begin
Change_Pixel_State(B1,X,Y,
Integer( Get_Pixel(Image1.Picture.Bitmap,X,Y) <>0));
end;
b1.EndUpdate;
image2.Picture.Bitmap.Canvas.Draw(0,0,b1);
label3.Caption:='Размер 24 бита: '+
IntToStr(Image1.Picture.Bitmap.RawImage.DataSize)+' Размер 1 бит : '+
IntToStr(B1.RawImage.DataSize);
end;
// Загрузка ...
procedure TBTForm.Button1Click(Sender: TObject);
Var f:String;
im:Timage;
begin
GetDir(0,F);
OpenDialog1.InitialDir:=F;
OpenDialog1.FileName:='*.bmp;*.jpg;*.png';
If OpenDialog1.Execute then begin
im:=Timage.Create(nil);
im.Picture.LoadFromFile(OpenDialog1.FileName);
image1.Picture.Bitmap.Canvas.
StretchDraw(rect(0,0,image1.Picture.Bitmap.Width,image1.Picture.Bitmap.Height),im.Picture.Bitmap);
im.Free;
end;
end;
/// Рекурсивнй поиск границ контура 1Bit
function ScanOBJ_1Bit(Var image:tBitmap;x,y:integer):trect;
const delta: array[1 .. 8] of record dx, dy: integer;
end = ( (dx:0; dy:1),
(dx:1; dy:0),
(dx:0; dy:-1),
(dx:-1; dy:0),
(dx:1; dy:1),
(dx:1; dy:-1),
(dx:-1; dy:1),
(dx:-1; dy:-1) );
XC : integer=0;
YC: integer=0;
Var
i: byte;
begin
with result do
begin
Left := x; Top := y;
Right := x; Bottom := y;
end;
// if SumpF Then SUMP:=SUMP+1;
Change_Pixel_State(image,x, y, 1);
for i := 1 to 8 do
begin
if not InR(x+delta[i].dx, 0,image.Width-1) then continue;
if not InR(y+delta[i].dy, 0,image.Height-1) then continue;
XC:=x+delta[i].dx;
YC:=y+delta[i].dy;
if Get_Pixel_State(Image,xc,yc)= 0 then
begin
With ScanOBJ_1Bit(image, XC,YC) do begin
if Left <= result.left then result.Left := Left;
if right >= result.right then result.right := right;
if top <= result.top then result.top := top;
if bottom >= result.bottom then result.bottom :=bottom;
end
end
end
end;
procedure ScanOBJECTS1Bit(Var RL:TList; Var image:tBitmap;DR:Longint;
FMySobj:Boolean );
Var
// W,H:Longint;
R:^Trect;
Lf:Boolean;
I,x,y:Longint;
begin
If image=nil then exit;
Lf:=False;
Repeat
Lf:=False;
For Y:=0 to image.Width-1 do
For X:=0 to image.Height-1 do
begin
if Get_Pixel_State(image,x,y) =0 then
begin
GetMem(R,SizeOf(Trect));
if FMySobj then begin
//...
end else
R^:=ScanOBJ_1Bit(image,x,y );
if (ABS(r^.Bottom-R^.Top)>DR) AND (Abs(R^.Right-r^.Left)>DR) then
begin
RL.Add(R) ;
LF:=True;
end else FreeMem(R,SizeOf(Trect));
end
end;
Until not LF;
end;
// Тест ...
procedure TBTForm.Button4Click(Sender: TObject);
Var
myTime:TDateTime;
ts:String;
X,y,i:Integer;
R:^Trect;
Const
RL:TList=nil;
RL2:TList=nil;
B:TBitmap=nil;
B2:TBitmap=nil;
begin
if B1= nil then exit;
If RL=nil then RL:=TList.Create else Rl.Clear;;
if B=nil then B:=TBitmap.Create;
if B2=nil then begin
B2:=TBitmap.Create;
B2.PixelFormat:=pf1bit;
b2.SetSize(b1.Width,b1.Height ); // !! Тут была собака зарыта ...
end;
//--------------------------------------------
For Y:=0 to b1.Height-1 do begin
b2.BeginUpdate;
For X:=0 to B2.Width-1 do
begin
Change_Pixel_State(b2,X,Y,Get_Pixel_State(B1,X,Y ));
end;
b2.EndUpdate;
end;
//--------------------------------------------
If RL2=nil then RL2:=TList.Create else Rl2.Clear;// Да, я знаю что тут "микро-утечка" но для теста сойдет ....
b2.BeginUpdate;
myTime:=now;
ScanOBJECTS1Bit(RL2 ,b2 ,5,CheckBox1.Checked );
str((now-myTime)*10e4:2:5,ts);
b2.endUpdate;
Label2.Caption:='Время 1 Bit: '+ts +' Контуров '+IntToStr(rl2.count);
// -------------------------
ListBox2.Clear;
For i:=0 to Rl2.Count-1 do begin
Image2.Picture.Bitmap.Canvas.Pen.Color:=clred;
Image2.Picture.Bitmap.Canvas.Frame(Trect( rl2[i]^));
With Trect( rl2[i]^) do ListBox2.Items.Add(
Format('%d %d %d %d ',[left,top,Right,Bottom]));
end;
end;
end.
