[Cramol]

Здравствуйте, уважаемые форумчане!
Помогите, пожалуйста, решить следующую проблему:
Я загружаю любой файл в программу, преобразовываю его в HEX-вид, делю на HEX-триады ($FFFFFF, $FFAACC и т.д.), а потом строю из всего этого квадратную картинку, после чего сохраняю в файл.
Все бы хорошо, но если размер загружаемого >50 Кб, то программа виснет. Да и вообще - медленно все работает. Подгружаемые файлы предусматриваются не более 10 Мб.
Подскажите, пожалуйста, правильное написание кода. Сейчас использую так:

Код:

unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, StdCtrls, ExtCtrls, math, ComCtrls;

type
 TForm1 = class(TForm)
   OpenDialog1: TOpenDialog;
   Image1: TImage;
   Button4: TButton;
   redt1: TRichEdit;
   procedure Button4Click(Sender: TObject);
 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;

implementation

{$R *.dfm}

function StreamToHex(Buf: TStream): string;
const
Convert: array[0..15] of Char = '0123456789ABCDEF';
var
i, p: integer;
B: byte;
begin
SetLength(Result, Buf.Size * 2);
p := Buf.Position;
Buf.Position := 0;
for i := 1 to Buf.Size do
begin
Buf.Read(B, 1);
Result[(i * 2) - 1] := Convert[B shr $4];
Result[(i * 2)] := Convert[B and $F];
end;
Buf.Position := p;
end;

procedure TForm1.Button4Click(Sender: TObject);
const
Convert: array[0..15] of Char = '0123456789ABCDEF';
var
i, p, r: integer;
B: byte;
str: string;

w,h, x,y: integer;
Stream: TFileStream;
color: tcolor;
begin
if OpenDialog1.Execute then
Stream := TFileStream.Create(OpenDialog1.FileName, fmOpenRead);

Stream.Seek(0,soFromBeginning);
redt1.Text:= StreamTohex(Stream);
Stream.Position :=0;
r := Stream.Size;
str:='$';

h := ceil(sqrt(r/3));
w := ceil(sqrt(r/3));

Image1.Picture.Bitmap.Height := h;
Image1.Picture.Bitmap.Width := w;

x:=0;
y:=0;
for i := 1 to Stream.Size do
begin
Stream.Read(B, 1);
str := str + Convert[B shr $4] + Convert[B and $F];
if (i mod 3) = 0 then
begin
color := stringToColor(str);
Image1.Picture.Bitmap.Canvas.Pixels[x,y] := color;
inc(x);
if x>w then
begin
  x:=0;
  inc(y);
end;
str := '$';
end;
Image1.Picture.SaveToFile('c:\test.bmp');
end;
Stream.Free;
end;

end.

[~TB~]

Canvas.Pixels[x,y] как и все средства GDI медленно работает. Думаю проблема в этом.

Попробуйте это - Graphics32

[Cramol]

Блин, очень глупо с моей стороны также было попиксельно сохранять картинку в файл. Вынес "Image1.Picture.SaveToFile('c:\test.bmp');" за цикл - теперь те же, к примеру, 5,5 Мб обрабатываются и на выходе сохраняются в картинку за 12-15 секунд. Уже неплохо, возможно, и достаточно, но да - хотелось бы ещё быстрее, думаю это возможно как-то

~TB~, покопаюсь, спасибо за наводку!

[Konrad]

Как вариант: не работай со стринг...

[Cramol]

Сообщение от Konrad

Как вариант: не работай со стринг...

А что оптимальнее будет использовать?

[Konrad]

Сообщение от Cramol

А что оптимальнее будет использовать?

Смотря для чего...

В твоем случае стоит попытаться переписать под байты.

Хотя, опять же: нужно смотреть.

[lmikle]

ScanLine. Самый быстрый из нативных способов.
Еще быстрее только если через API строить картинку сразу в памяти а потом еще переделать в битмап. Но оно сложно и тебе не нужно. ScanLine'а должно хватить.

Ну и зачем делать какие-то преобразования. открываешь файл как бинарник и вычитываешь 3 байта. Из них формируешь цвет, т.к. компьютеру все-равно в каком виде это будет в середине. Ему выжны собственно значения, так что никаких преобразований не надо.

Код:

var
  Stream : TFileStream;
  r, g, b : Byte;
  c : TColor;
begin
  Stream := TFileStream.Create(...);
  ...
  Stream.ReadBuffer(r,SizeOf(Byte));  
  Stream.ReadBuffer(g,SizeOf(Byte));
  Stream.ReadBuffer(b,SizeOf(Byte));
  c := RGBToColor(r,g,b);
  ...
end;

[AND_REY]

Вот вариант ~50мб за пару сек. рисует:

Код:

procedure TForm1.Button2Click(Sender: TObject);
Type
 TRGB = Record
   B,G,R: Byte;
  end;
 PRGBLine = ^TRGBLine;
 TRGBLine = Array [0..65535] of TRGB;
Var
 F: TFileStream;
 Bmp: TBitmap;
 Line: PRGBLine;
 R, j: Integer;
begin
 if OpenDialog1.Execute Then
  F:= TFileStream.Create(OpenDialog1.FileName, fmOpenRead) Else Exit;
 Bmp:= TBitmap.Create;
 Bmp.PixelFormat:= pf24bit;
 if (F.Size Mod 3) = 0 Then R:= (F.Size Div 3)
  Else R:= (F.Size Div 3) + 1 ;
 Bmp.Width:= Round(Sqrt(R));
 Bmp.Height:= Bmp.Width;
 if (Bmp.Width*Bmp.Height) < R Then Bmp.Height:= Bmp.Height + 1;
 For j:= 0 To Bmp.Height - 1 Do
  begin
   Line:= Bmp.ScanLine[j];
   F.Read(Line^, Bmp.Width*3);
  end;
 Image1.Canvas.Draw(0, 0, Bmp);
 Bmp.SaveToFile('c:\test.bmp');
 Bmp.Free;
 F.Free;
end;

[Cramol]

AND_REY, действительно - скорость практически мгновенная даже на больших файлах! Идеально! Спасибо огромное!

Ребят, а ещё один вопрос. Скажите, как лучше реализовать (по какой формуле, что ли) следующее:
Вот строится картинка. Кол-во её пикселей составляет 480.000. В идеале соотношение сторон будет 800х600.
Если сделать вот так:

Код:

procedure TForm1.Button1Click(Sender: TObject);
var
 Z, W, H, I: integer;
begin
 H := 0;
 W := 0;
 Z := StrToInt(Edit1.Text);
 for I := Trunc(Sqrt(Z)) downto 1 do
 begin
   H := I;
   W := Z div H;
   if W * H = Z then
     break
 end;
 ShowMessage(Format('W = %d, H = %d', [W, H]))
end;

...то, в принципе, все нормально - 750x640 тоже будет смотреться, скажем так, "наглядно" для человека.
Но вот проблема: если число пикселей будет 480.001, то остается лишь один вариант - 12973х37. Картинка с такой длиной и высотой для пользователя, конечно, не самый лучший вариант. У этого числа только два таких простых множителя, другого разложения на множители нет.
Выходит, в таких случаях лучше будет, нпаример, дописать ещё один любой пиксель? Он будет не заметен на общей картинке, но тогда длина и ширина более "человечные" получатся.

[Cramol]

Хотя пусть даже она будет квадратная с погрешностью.
AND_REY, скажите, а как можно, используя Ваш код, сделать ещё такую проверку в нём:
чтобы картинка формировалась не цветная, а черно-белая (это, в принципе, можно сделать по проверке цвета пикселя: если <$7FFFFF, то черный, если >, то белый).
А вот как можно встроить внутренний цикл, чтобы обрабатывался квадрат, скажем, из 10х10 пикселей и, если в нем доминирует больше черных пикселей, то весь такой квадрат закрашивается черным, если больше белых - то белым?

[Cramol]

Черно-белой делаю так:

Код:

function CreateGrayBmp (Source: TBitmap): TBitmap;
var
  Table: array[Byte] of TRGBQuad;
  I: Integer;
begin
  Result := TBitmap.Create;
  with Result do
  begin
    PixelFormat := pf8Bit;
    Width := Source.Width;
    Height := Source.Height;
    for I := Low(Table) to High(Table) do
      with Table[i] do
      begin
        rgbRed := I;
        rgbGreen := I;
        rgbBlue := I;
        rgbReserved := 0;
      end;
    if (SetDIBColorTable(Canvas.Handle, Low(Table), High(Table), Table) = 0) then
      RaiseLastWin32Error;
    Canvas.Draw(0, 0, Source);
  end;
end;

Остался вопрос лишь с квадратами 10х10, которые надо преобразовать в один цвет целиком 10х10, исходя из того пикселей какого цвета в этом квадрате больше.

[AND_REY]

Скорость упала (~16Мб за 14сек.) из-за внутреннего цикла и чтения по байтно:

Код:

procedure TForm1.Button2Click(Sender: TObject);
Type
 TRGB = Record
   B,G,R: Byte;
  end;
 PRGBLine = ^TRGBLine;
 TRGBLine = Array [0..65535] of TRGB;
Var
 F: TFileStream;
 Bmp: TBitmap;
 Line: PRGBLine;
 R, j, i: Integer;
 C1, C2, C3, Y: Byte;
begin
 if OpenDialog1.Execute Then
  F:= TFileStream.Create(OpenDialog1.FileName, fmOpenRead) Else Exit;
 Bmp:= TBitmap.Create;
 Bmp.PixelFormat:= pf24bit;
 if (F.Size Mod 3) = 0 Then R:= (F.Size Div 3)
  Else R:= (F.Size Div 3) + 1 ;
 Bmp.Width:= Round(Sqrt(R));
 Bmp.Height:= Bmp.Width;
 if (Bmp.Width*Bmp.Height) < R Then Bmp.Height:= Bmp.Height + 1;
 For j:= 0 To Bmp.Height - 1 Do
  begin
   Line:= Bmp.ScanLine[j];
   For i:= 0 To Bmp.Width - 1 Do
    begin
     F.Read(C1, 1); //R
     F.Read(C2, 1); //G
     F.Read(C3, 1); //B
     Y:= Round(0.299*C1 + 0.587*C1 + 0.114*C1);
     Line^[i].R:= Y;
     Line^[i].G:= Y;
     Line^[i].B:= Y;
    end;
  end;
 Image1.Canvas.Draw(0, 0, Bmp);
 Bmp.SaveToFile('c:\test.bmp');
 Bmp.Free;
 F.Free;
end;

[Cramol]

2AND_REY, а не подскажете как лучше всего реализовать построение такой картинки в черно-белом виде, но чтобы использовалось только два цвета - черный и белый. Т.е. без каких-либо оттенков серого?

Т.е. мне даже не обязательно требуется сначала приводить картинку к цветному виду, можно сразу к двухцветному.

[AND_REY]

В цикл вставить этот код и будет ч/б без градаций.

Код:

     F.Read(C1, 1); //R
     F.Read(C2, 1); //G
     F.Read(C3, 1); //B
     if (C1 + C2 + C3) Div 3 > 127 Then
      begin
       Line^[i].R:= $FF;
       Line^[i].G:= $FF;
       Line^[i].B:= $FF;
      end
     Else
      begin
       Line^[i].R:= $00;
       Line^[i].G:= $00;
       Line^[i].B:= $00;
      end;

[Cramol]

Спасибо, Андрей! То, что надо.
Ну а со скоростью уже ничего не поделаешь из-за внутреннего цикла, да? Возможно, есть какой-то способ сразу представлять картинку в двух цветах, не строя сначала цветную? Возможно, это поможет или нет?
Так ч/б картинка из файла размером 10 Мб строится чуть больше полуминуты