Текущий архив: 2011.05.15;
Скачать: CL | DM;

Вниз

Быстрый вывод пикселей на канву   Найти похожие ветки 

← →
qazxsw   (2011-01-28 14:00) [0]

Доброго времени суток. Вопрос к тем кто прогает в Lazarus.
У меня имеется двумерный массив с пикселями, как бы быстро вывести их на канву собственными средствами, тоесть сторонии компонентами пользоваться нельзя. В делфях я бы создал битмап и посредством сканлайн заполнил бы его, а затем draw на канву. А здесь как быть? попиксельный доступ к канве очень медленный...

---

← →
MBo ©   (2011-01-28 14:03) [1]

а что, в Лазарусе битмапов нет?

---

← →
qazxsw   (2011-01-28 14:08) [2]

есть, но нет scanline

---

← →
MBo ©   (2011-01-28 14:23) [3]

Первая же ссылка предлагает некое решение:
http://www.google.ru/search?client=opera&rls=ru&q=lazarus+scanline&sourceid=opera&ie=utf-8&oe=utf-8&channel=suggest

---

← →
qazxsw   (2011-01-28 16:06) [4]

Да смотрел я эту ерунду. Очень медлено...

254 тиков против 15 на scanline

---

← →
RWolf ©   (2011-01-28 16:15) [5]

Битмап можно и в TMemoryStream загрузить, а там уже править его там как угодно с максимально возможной скоростью.
После редактирования — TBitmap.LoadFromStream.

---

← →
han_malign   (2011-01-28 16:56) [6]

> У меня имеется двумерный массив с пикселями
...
> Битмап можно и в TMemoryStream загрузить

- пример для Delphiю. Т.к TBitmap принимает  только поток с файловым заголовком(функции принимающие упакованный DIB спрятаны от доступа) - то было сделано логическое объединение двух кусков(чтобы лишний раз по 4 Mb в памяти не гонять), количество склеиваемых кусков можно при нужде и добавить...
type
  TPackedDIBFakeFileStream = class(TStream)
  private
     F_pFHdr: TBitmapFileHeader;
     F_pDIB : PBitmapInfo;
     F_cbPos: LongWord;
  public
     function GetSize: Int64; override;
     function Read(var Buffer; Count: Longint): Longint; override;
     function Write(const Buffer; Count: Longint): Longint; OVERRIDE;
     function Seek(Offset: Longint; Origin: Word): Longint; override;
     constructor Create(pDIB: PBitmapInfo);
  end;
implementation
{==============================================================================}
function TPackedDIBFakeFileStream.GetSize: Int64;
begin
  Result:= F_pFHdr.bfSize;
end{};
{------------------------------------------------------------------------------}
function TPackedDIBFakeFileStream.Read(var Buffer; Count: Longint): Longint;
var _offs: integer;
begin
  Result:= F_pFHdr.bfSize - F_cbPos;
  if( Result > Count )then
     Result:= Count;
  if( Result > 0 )then begin
     _offs:= F_cbPos-sizeof(F_pFHdr);
     inc(F_cbPos, Result);
     if( _offs < 0 )then begin
        _offs:= -_offs;
        if( _offs >= Result )then begin
           move(PAnsiChar(@F_pFHdr)[sizeof(F_pFHdr)-_offs], Buffer, Result);
           exit;
        end;
        move( F_pDIB^, PAnsiChar(@Buffer)[_offs], Result - _offs);
        exit;
     end;
     move( PAnsiChar(F_pDIB)[_offs], Buffer, Result);
  end;
end{};
{------------------------------------------------------------------------------}
function TPackedDIBFakeFileStream.Write(const Buffer; Count: Longint): Longint;
begin
  Result:= 0;
  {$IFOPT O-}asm int 3 end;{$ENDIF}
end{};
{------------------------------------------------------------------------------}
function TPackedDIBFakeFileStream.Seek(Offset: Longint; Origin: Word): Longint;
var _base: int64;
begin
  case(Origin)of
  ord(soBeginning): _base:= 0;
  ord(soCurrent  ): _base:= F_cbPos;
  ord(soEnd      ): _base:= F_pFHdr.bfSize;
  else
     raise ERangeError.CreateRes(@SRangeError);
  end;
  inc( _base, offset);
  if( _base < 0 )then
     Result:= 0
  else
     if( _base > F_pFHdr.bfSize )then
        Result:= F_pFHdr.bfSize
     else
        Result:= _base;
  F_cbPos:= Result;
end{};
{------------------------------------------------------------------------------}
constructor TPackedDIBFakeFileStream.Create(pDIB: PBitmapInfo);
var clr: LongWord;
begin
  F_pDIB:= pDIB;
  if( pDIB <> nil )then begin
     clr:= 0;
     if( F_pDIB.bmiHeader.biBitCount <= 8 )then clr:= 1 shl F_pDIB.bmiHeader.biBitCount;
     if( F_pDIB.bmiHeader.biCompression = BI_BITFIELDS )then inc(clr, 3);
     F_pFHdr.bfType:= $4D42;
     F_pFHdr.bfOffBits:= sizeof(F_pFHdr) +
        pDIB.bmiHeader.biSize + clr * sizeof(pDIB.bmiColors[0]);
     F_pFHdr.bfSize:= F_pFHdr.bfOffBits + pDIB.bmiHeader.biSizeImage;
  end;
  //else all fields zeroed
end{};
{------------------------------------------------------------------------------}
{==============================================================================}


---

← →
Pavia ©   (2011-01-28 18:53) [7]

Есть в лазариусе scanline только он спрятан. Там используется.
TBitmap.RawImage.Data
Вот пример перевода из моего класса TByteMap в  TBitmap для дельфи и лазариуса.

function ByteMap2BitMap(bm:TByteMap):TBitmap;
var
pf:TPixelFormat;
j,i:Integer;
p,p1:PByteArray;
begin
Result:=Nil;
{$IFDEF FPC}
if bm<>nil then
 begin
 case bm.UnitFormat of
 uf1Unit:pf:=pf24bit;
 uf3Unit:pf:=pf24bit;
 uf4Unit:pf:=pf32bit;
 else exit;
 end;
 Result:=TBitmap.Create;

 Result.PixelFormat:=pf;
 if bm.UnitFormat=uf1Unit then
  begin
  Result.Width:=bm.Width;
  Result.Height:=bm.Height;
  p:=PByteArray(Result.RawImage.Data);
  for j:=0 to bm.Height-1 do
   begin
   p1:=bm.ScanLine[j];
   for i:=0 to bm.Width-1 do
    begin
    p[i*3+0]:=p1[i];
    p[i*3+1]:=p1[i];
    p[i*3+2]:=p1[i];
    end;
   Inc(PByte(P),Result.RawImage.Description.BytesPerLine);
   end;
  exit;
  end;
 Result.Width:=bm.Width;
 Result.Height:=bm.Height;
 p:=PByteArray(Result.RawImage.Data);
 for j:=0 to bm.Height-1 do
  begin
  move(bm.ScanLine[j]^,p^,bm.Width*bm.UnitFormat*SizeOf(Byte));
  Inc(PByte(P),Result.RawImage.Description.BytesPerLine);
  end;
 end;

{$ELSE}
if bm<>nil then
 begin
 case bm.UnitFormat of
 uf1Unit:pf:=pf8bit;
 uf3Unit:pf:=pf24bit;
 uf4Unit:pf:=pf32bit;
 else exit;
 end;
 Result:=TBitmap.Create;

 Result.PixelFormat:=pf;
 if bm.UnitFormat=uf1Unit then
  Result.Palette:=GetGrayPall;
 Result.Width:=bm.Width;
 Result.Height:=bm.Height;
 for j:=0 to bm.Height-1 do
   move(bm.ScanLine[j]^,Result.ScanLine[j]^,bm.Width*bm.UnitFormat*SizeOf(Byte));
 end;
{$ENDIF}
end;


---

← →
qazxsw   (2011-01-28 19:21) [8]

> Pavia ©   (28.01.11 18:53) [7]

Угу пасиб посмотрю.

Я тут еще спопсб надыбал, где-то 15-16 тиков

procedure TForm1.Button1Click(Sender: TObject);
var
 bitmap: Tbitmap;
 a, b:   integer;
begin

 a      := GetTickCount;
 bitmap := Tbitmap.Create;
 bitmap.Width := 1000;
 Bitmap.Height := 1000;

 Test(bitmap);
 canvas.Draw(0, 0, bitmap);

 bitmap.Free;
 b := GetTickCount;
 ShowMessage(IntToStr(b - a));
end;

procedure TForm1.Test(var FBitmap: TBitMap);

var
 y: integer;
 RawImage: TRawImage;
 BitmapHandle, MaskHandle: HBitmap;
 FData, FFdata: PBGRPixel;
begin
 ReAllocMem(FData, FBitmap.Width * FBitmap.Height * sizeof(TBGRPixel));
 FFdata := FData;
 /////////////////////////////Здесь можем рисовать
 for y := 0 to FBitmap.Height*fbitmap.Width-1 do
  begin
   FFdata^.red   := 0;
   FFdata^.Green := 0;
   FFdata^.Blue  := 255;
   Inc(FFdata);
 end;

 if (FBitmap.Width > 0) and (FBitmap.Height > 0) then
 begin
   RawImage.Init;
   RawImage.Description.Init_BPP24_B8G8R8_BIO_TTB(FBitmap.Width, FBitmap.Height);
   RawImage.Description.LineOrder := riloBottomToTop;
   RawImage.Data     := PByte(FData);
   RawImage.DataSize := FBitmap.Width * FBitmap.Height * sizeof(TBGRPixel);
   if not RawImage_CreateBitmaps(RawImage, BitmapHandle, MaskHandle, False) then
     raise FPImageException.Create("Failed to create bitmap handle");
   FBitmap.Handle     := BitmapHandle;
   FBitmap.MaskHandle := MaskHandle;
 end;

 FBitmap.Canvas.AntialiasingMode := amOff;
 freemem(FData);
 FData := nil;
end;                

---

← →
qazxsw   (2011-01-28 19:23) [9]

да юниты
GraphType, LCLIntf, FPimage

---

← →
qazxsw   (2011-01-28 19:32) [10]

Эту забыл


type
 PBGRPixel = ^TBGRPixel;

 TBGRPixel = packed record
   blue, green, red: byte;
 end;

...............

---

← →
qazxsw   (2011-01-29 04:32) [11]

> Pavia ©   (28.01.11 18:53) [7]



> p[i*3+0]:=p1[i];
>     p[i*3+1]:=p1[i];
>     p[i*3+2]:=p1[i];



Этот участок не очень понятен. Почему ко всем трем P применяется один и тот же байт P1[i] ?

---

← →
Pavia ©   (2011-01-29 10:26) [12]

> P1[i] ?

Это я градации серого 8бит перевожу в 24 бита Лазариус палитру не поддерживает. А если картинка изначально 24 битное, то код ниже.

Result.Width:=bm.Width;
Result.Height:=bm.Height;
p:=PByteArray(Result.RawImage.Data);
for j:=0 to bm.Height-1 do
 begin
 move(bm.ScanLine[j]^,p^,bm.Width*bm.UnitFormat*SizeOf(Byte));
 Inc(PByte(P),Result.RawImage.Description.BytesPerLine);
 end;
end;

---

← →
Anatoly Podgoretsky ©   (2011-01-29 13:21) [13]

> qazxsw  (29.01.2011 04:32:11)  [11]

Gray Scale

---

← →
Anatoly Podgoretsky ©   (2011-01-29 13:22) [14]

Правда паршивый

---

← →
qazxsw   (2011-01-30 12:56) [15]

> > Pavia ©   (28.01.11 18:53) [7]


мх что-то не могу повторить код :(

на выделенной строке прога валится

var
 p: PByteArray;
 y: integer;
 bitmap: TBitMap;
begin

  bitmap := Tbitmap.Create;
 bitmap.Width := 10;
 Bitmap.Height := 10;

 bitmap.PixelFormat := pf24bit;
 p := PByteArray(bitmap.RawImage.Data);

  p^[5]:=10;

  bitmap.Free;        

---

← →
Pavia ©   (2011-01-30 13:27) [16]

У меня работает. Может от версии лазариуса зависит?

 bitmap.PixelFormat := pf24bit; эта строчка в лазариусе не работает должным образом. Свойство носит только информативный характер.

---

← →
qazxsw   (2011-01-30 13:42) [17]

Lazarus-0.9.28.2
fpc-2.2.4

---

Страницы: 1 вся ветка

Текущий архив: 2011.05.15;
Скачать: CL | DM;

Наверх

Память: 0.52 MB
Время: 0.008 c