|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#1
|
|||
|
|||
Долго строится картинка попиксельно
Здравствуйте, уважаемые форумчане!
Помогите, пожалуйста, решить следующую проблему: Я загружаю любой файл в программу, преобразовываю его в 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. |
#2
|
||||
|
||||
Canvas.Pixels[x,y] как и все средства GDI медленно работает. Думаю проблема в этом.
Попробуйте это - Graphics32 00110001 00101100 00110110 00110001 00111000 00110000 00110011 00110011 00111001 00111000 00111000 00110111 00110100 00111001 00111000 00111001 00110100 00111000 00110100 00111000 00110010 00110000 00110100 00110101 00111000 00110110 00111000 00110011 00110100 00110011 00110110 00110101 00110110 Последний раз редактировалось ~TB~, 31.05.2011 в 22:28. |
#3
|
|||
|
|||
Блин, очень глупо с моей стороны также было попиксельно сохранять картинку в файл. Вынес "Image1.Picture.SaveToFile('c:\test.bmp');" за цикл - теперь те же, к примеру, 5,5 Мб обрабатываются и на выходе сохраняются в картинку за 12-15 секунд. Уже неплохо, возможно, и достаточно, но да - хотелось бы ещё быстрее, думаю это возможно как-то
~TB~, покопаюсь, спасибо за наводку! |
#4
|
||||
|
||||
Как вариант: не работай со стринг...
|
#5
|
|||
|
|||
Цитата:
А что оптимальнее будет использовать? |
#6
|
||||
|
||||
Цитата:
В твоем случае стоит попытаться переписать под байты. Хотя, опять же: нужно смотреть. |
#7
|
|||
|
|||
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; Последний раз редактировалось lmikle, 31.05.2011 в 23:56. |
#8
|
||||
|
||||
Вот вариант ~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; If end Then begin; |
#9
|
|||
|
|||
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. Картинка с такой длиной и высотой для пользователя, конечно, не самый лучший вариант. У этого числа только два таких простых множителя, другого разложения на множители нет. Выходит, в таких случаях лучше будет, нпаример, дописать ещё один любой пиксель? Он будет не заметен на общей картинке, но тогда длина и ширина более "человечные" получатся. |
#10
|
|||
|
|||
Хотя пусть даже она будет квадратная с погрешностью.
AND_REY, скажите, а как можно, используя Ваш код, сделать ещё такую проверку в нём: чтобы картинка формировалась не цветная, а черно-белая (это, в принципе, можно сделать по проверке цвета пикселя: если <$7FFFFF, то черный, если >, то белый). А вот как можно встроить внутренний цикл, чтобы обрабатывался квадрат, скажем, из 10х10 пикселей и, если в нем доминирует больше черных пикселей, то весь такой квадрат закрашивается черным, если больше белых - то белым? |
#11
|
|||
|
|||
Черно-белой делаю так:
Код:
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, исходя из того пикселей какого цвета в этом квадрате больше. |
#12
|
||||
|
||||
Скорость упала (~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; If end Then begin; |
#13
|
|||
|
|||
2AND_REY, а не подскажете как лучше всего реализовать построение такой картинки в черно-белом виде, но чтобы использовалось только два цвета - черный и белый. Т.е. без каких-либо оттенков серого?
Т.е. мне даже не обязательно требуется сначала приводить картинку к цветному виду, можно сразу к двухцветному. Последний раз редактировалось Cramol, 01.06.2011 в 20:14. |
#14
|
||||
|
||||
В цикл вставить этот код и будет ч/б без градаций.
Код:
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; If end Then begin; |
#15
|
|||
|
|||
Спасибо, Андрей! То, что надо.
Ну а со скоростью уже ничего не поделаешь из-за внутреннего цикла, да? Возможно, есть какой-то способ сразу представлять картинку в двух цветах, не строя сначала цветную? Возможно, это поможет или нет? Так ч/б картинка из файла размером 10 Мб строится чуть больше полуминуты Последний раз редактировалось Cramol, 01.06.2011 в 20:27. |