Долго строится картинка попиксельно

AND_REY · #16 01.06.2011, 20:43

Что бы увеличить скорость программы до макс. можно сделать так:

1.Открываем файл, читаем блоками в массив1.
2.Суммируем по 3 байта из массива1 и делим на 3 = средний цвет
3.Проверяем условие: средний цвет > 127 --> белый (1) иначе чёрный (0)
4.Заполняем массив2 из получившихся (0), (1).
5.Создаём заголовок bmp файла с пустыми данными рис.
6.Сохр. массив2 в файл bmp блоками в место где должны быть данные.

Нужно разбираться с форматом ч/б bmp файла (структурой) для реализации алгоритма.

А зачем файлы преобразовывать в двуцветные картинки?

Cramol · #17 01.06.2011, 20:48

Цитата:

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

5.Создаём заголовок bmp файла с пустыми данными рис.
6.Сохр. массив2 в файл bmp блоками в место где должны быть данные.

Нужно разбираться с форматом ч/б bmp файла (структурой) для реализации алгоритма.

Это если BMP. Мне все равно нужно отрисовать её на Image, после чего я сохраняю её в JPG:

Код:

  JpegIm := TJpegImage.Create;
  JpegIm.Assign(bmp);
  JpegIm.CompressionQuality := 100;
  JpegIm.Compress;
  JpegIm.SaveToFile(dlgSave1.FileName);
  JpegIm.Destroy;

Цитата:

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

А зачем файлы преобразовывать в двуцветные картинки?

Можно сказать, личные извращения

Эх, я так обрадовался Вашему коду, который просто строит цветную картинку - скорость отличная, больше и не надо. А вот с двухцветной не получается так

Что же придумать...

AND_REY · #18 01.06.2011, 21:03

Заменил чтение блоком. Скорость возросла

Просто подумал как так цветное быстрее рисуется

Код:

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];
   F.Read(Line^, Bmp.Width*3);
   For i:= 0 To Bmp.Width - 1 Do
    begin
     if (Line^[i].R + Line^[i].G + Line^[i].B) 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;
    end;
  end;
 Image1.Canvas.Draw(0, 0, Bmp);
 Bmp.SaveToFile('c:\test.bmp');
 Bmp.Free;
 F.Free;
end;

Cramol · #19 01.06.2011, 21:09

Ничего себе! Ради интереса проверил на файле 100 Мб - меньше чем за 2 секунды. Даже получше, чем Ваш первый код для цветной картинки! Спасибо Вам большое!

И последний вопрос. Может, Вы и с этим поможете.
Как лучше теперь эту двухцветную картинку обработать в том плане, чтобы пиксели обрабатывались по блокам, к примеру, 10х10 и, если в этом блоке кол-во черных пикселей будет больше белых, то весь этот квадрат 10х10 перерисовывался полность в черный?
Тут, по идее, двумя циклами делать нужно: внутренний будет попиксельно проходить этот квадрат 10х10, высчитывать соотношение черных и белых пикселей, а затем перерисовывать его; а внешний цикл каким-то образом должен отвечать за позицию внутреннего цикла.
Только тут, получается, что пройдя таким образом самую первую строчку, последний блок может получиться не 10х10, а, например, 6х10. С ним тогда нужно поступить аналогичным образом, после чего перейти к следующей строчке.

AND_REY · #20 01.06.2011, 22:15

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

Cramol · #21 01.06.2011, 22:39

Цитата:

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

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

Ну мне не совсем размытие надо, а, скорее, чтобы наподобие мозайки получилось. В принципе, как сейчас строится в 2 цвета, только, по сути, пиксель больше будет (как 10х10 пикселей, к примеру).

angvelem · #22 02.06.2011, 00:00

Ну это не совсем мозаика будет, а скорее размытие.

Cramol · #23 02.06.2011, 00:41

В общем, кое-как получилось, в принципе.
Только не могу понять как теперь на Image отобразить уменьшенную получившуюся картинку. Вот изначально, когда она преобразовывается попиксельно в два цвета (черный и белый), размеры картинки, отображаемые в Image, одинаковые вне зависимости от того, какая в действительности ширина и высота исходной картинки.
Потом я прохожусь циклами для преобразования квадратиков 10х10, опять таки хочу отобразить полученный результат на Image, но он уже отображается такой длины и высоты, как сама картинка, а не размеры Image. Т.е. во весь размер.
Как сделать, чтобы она была по размерам Image? т.е. уменьшенная.

Код:

procedure Tmp32jpg.btn1Click(Sender: TObject);
Type
 TRGB = Record
   B,G,R: Byte;
  end;
 PRGBLine = ^TRGBLine;
 TRGBLine = Array [0..65535] of TRGB;
Var
 F: TFileStream;
 Line: PRGBLine;
 R, j, i: Integer;
 C1, C2, C3, Y: Byte;
 mx,my:Integer;
 pix:Integer;
 chx,chy,m,n,m2,n2:Integer;
begin
 if dlgOpen1.Execute Then
 F:= TFileStream.Create(dlgOpen1.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);
   For i:= 0 To Bmp.Width - 1 Do
    begin
     if (Line^[i].R + Line^[i].G + Line^[i].B) 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;
    end;
  end;
 img1.Canvas.Draw(0, 0, Bmp);

 mx:=10;
 my:=10;

 chx:=Bmp.Width div 10;
 chy:=Bmp.Height div 10;

for m:=0 to chx do
begin
for m2:=0 to chy do
begin
 pix:=0;

 for i:=m2*10 to (mx*(m2+1))-1 do
 begin
  for j:=m*10 to (my*(m+1))-1 do
  begin
   if bmp.Canvas.pixels[j,i]=$000000 then
    Inc(pix);
   end;
 end;

 if pix<=50 then
 begin
  for i:=m2*10 to mx*(m2+1) do
  begin
    for j:=m*10 to my*(m+1) do
    begin
     bmp.Canvas.Pixels[j,i]:=$ffffff;
    end;
  end;
 end;

 if pix>50 then
 begin
  for i:=m2*10 to mx*(m2+1) do
  begin
    for j:=m*10 to my*(m+1) do
    begin
     bmp.Canvas.Pixels[j,i]:=$000000;
    end;
  end;
 end;

end;
end;

 ShowMessage('bmp: '+inttostr(bmp.width) +' , img: '+inttostr(img1.width));
 F.Free;
end;

Намудрил, походу, че-то в коде

angvelem · #24 02.06.2011, 01:07

Если просто уменьшить, то StretchBlt

AND_REY · #25 02.06.2011, 13:36

Навалял

, вроде работет, разберайтесь.

Код:

procedure TForm1.Button1Click(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, Mx, My, x, y, j, i, n: Integer;
 M: Array of Array of 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);
   For i:= 0 To Bmp.Width - 1 Do
    begin
     if (Line^[i].R + Line^[i].G + Line^[i].B) 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;
    end;
  end;
 if (Bmp.Width Mod 10) = 0 Then Mx:= Bmp.Width Div 10
  Else Mx:= (Bmp.Width Div 10) + 1;
 if (Bmp.Height Mod 10) = 0 Then My:= Bmp.Height Div 10
  Else My:= (Bmp.Height Div 10) + 1;
 Setlength(M, My*10, Mx);
 For j:= 0 To Bmp.Height - 1 Do
  begin
   Line:= Bmp.ScanLine[j];
   For i:= 0 To Mx - 1 Do
    begin
     n:= 0;
     For x:= 0 To 9 Do if Line^[i*10+x].R = $FF Then Inc(n) Else Dec(n);
     M[j,i]:= n;
   end;
  end;
 Image1.Width:= Mx*30;
 Image1.Height:= My*30;
 For i:= 0 To Mx - 1 Do
  For j:= 0 To My - 1 Do
   begin
    n:= 0;
    For y:= 0 To 9 Do n:= n + M[j*10+y,i];
    if n >= 0 Then Image1.Canvas.Brush.Color:= clWhite
     Else Image1.Canvas.Brush.Color:= clSilver;
    Image1.Canvas.Rectangle(i*30,j*30,i*30+30,j*30+30);
    Image1.Canvas.TextOut(i*30+5,j*30+10,IntToStr(n));
   end;
 Image1.Picture.SaveToFile('c:\test.bmp');
 Bmp.Free;
 F.Free;
end;

Cramol · #26 02.06.2011, 19:11

Спасибо, парни! Всю суть понял, есть над чем теперь работать. Благодарю ещё раз!

Опции темы	Поиск в этой теме
Версия для печати Отправить на Email	Поиск в этой теме: Расширенный поиск
Опции просмотра
Линейный вид Комбинированный вид Древовидный вид

	Сайт	Форум	FAQ	Соглашения	Прочее
	Новости Исходники Компоненты Статьи Добавить исходник Поиск	Правила Поиск Сообщения за сегодня Пользователи Кто на форуме?	Delphi FAQ - 5000 статей DRKB - 4500 статей (ZIP-архив) Справочник функций и процедур Delphi Delphi Programming Guide Indy in Depth. Глубины Indy	Конфиденциальность Соглашение пользователя Правила обработки cookie	О сайте Donate Контакты