Top.Mail.Ru
Мастера DELPHI, Delphi programming community Титульная страница Поиск, карта сайта Написать письмо 
| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL |
| Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

« предыдущая ветвь | форум | следующая ветвь »

Быстрое сжатие битмапов [D7, WinXP]


Eraser ©   (2005-02-11 19:00:00) 

Добрый вечер.
Есть ли у кого-нибудь компоненты/ссылки_на_них по алгоритмам сжатия Bitmap'ов. При этом не в Jpeg или Gif, а быстрых, таких как разные версии RLE или HEX.
Очень благодарен.

Eraser   (2005-02-23 14:08:00) [1]

Дмитрий В. Белькевич

Спасибо. Давно уже искал подобное!

Дмитрий В. Белькевич   (2005-02-23 03:45:00) [2]

Вот тебе еще до полного счастья rle, правда, только для 8 бит, TDAByte - Array of byte:

procedure RLEEncode8(const Src: TDAByte; var Dest: TDAByte; var Size:
 Integer);
var
 ReadPos, WritePos, FEPos, NewSize, RealSize: Integer;
 FEByte: Byte;
 procedure PutByte(B: Byte);
 begin
  Inc(NewSize);
  if RealSize < ((NewSize div 256) + 1) * 256 then
  begin
   RealSize := ((NewSize div 256) + 1) * 256;
   SetLength(Dest, RealSize);
  end;
  Dest[WritePos] := B;
  Inc(WritePos);
 end;
begin
 if Size <= 2 then
 begin
  SetLength(Dest, Size);
  Move(Pointer(Src)^, Pointer(Dest)^, Size);
 end;
 FEPos := 0;
 WritePos := 0;
 NewSize := 0;
 RealSize := 0;
 FEByte := Src[0];
 ReadPos := 1;
 Dec(Size);
 while ReadPos <= Size do
 begin
  while (Src[ReadPos] = FEByte) and (ReadPos < Size) and
   ((ReadPos - FEPos) < 255) do
   Inc(ReadPos);
  if (ReadPos - FEPos) > 2 then
  begin
   PutByte(0);
   PutByte(ReadPos - FEPos);
   PutByte(FEByte);
  end
  else if (ReadPos - FEPos) > 1 then
  begin
   if FEByte = 0 then
   begin
    PutByte(0);
    PutByte(0);
    PutByte(0);
    PutByte(0);
   end
   else
   begin
    PutByte(FEByte);
    PutByte(FEByte);
   end;
  end
  else
  begin
   if FEByte = 0 then
   begin
    PutByte(0);
    PutByte(0);
   end
   else
    PutByte(FEByte);
  end;
  FEByte := Src[ReadPos];
  FEPos := ReadPos;
  Inc(ReadPos);
 end;
 if FEByte = 0 then
 begin
  PutByte(0);
  PutByte(0);
 end
 else
  PutByte(FEByte);
 SetLength(Dest, NewSize);
 Size := NewSize;
end;

procedure RLEDecode8(const Src: TDAByte; var Dest: TDAByte; var Size:
 Integer);
var
 ReadPos, WritePos, NewSize, RealSize: Integer;
 FEByte: Byte;
 procedure PutByte(B: Byte);
 begin
  Inc(NewSize);
  if RealSize < ((NewSize div 256) + 1) * 256 then
  begin
   RealSize := ((NewSize div 256) + 1) * 256;
   SetLength(Dest, RealSize);
  end;
  Dest[WritePos] := B;
  Inc(WritePos);
 end;
begin
 if Size <= 2 then
 begin
  SetLength(Dest, Size);
  Move(Pointer(Src)^, Pointer(Dest)^, Size);
 end;
 WritePos := 0;
 NewSize := 0;
 RealSize := 0;
 FEByte := Src[0];
 ReadPos := 1;
 while ReadPos < Size do
 begin
  if FEByte = 0 then
  begin
   if Src[ReadPos] = 0 then
   begin
    PutByte(0);
    Inc(ReadPos);
    if ReadPos > High(Src) then
     Continue;
    FEByte := Src[ReadPos];
    Inc(ReadPos);
   end
   else
   begin
    FEByte := Src[ReadPos];
    Inc(ReadPos);
    while FEByte > 0 do
    begin
     PutByte(Src[ReadPos]);
     Dec(FEByte);
    end;
    Inc(ReadPos);
    if ReadPos > High(Src) then
     Continue;
    FEByte := Src[ReadPos];
    Inc(ReadPos);
   end;
  end
  else
  begin
   PutByte(FEByte);
   FEByte := Src[ReadPos];
   Inc(ReadPos);
  end;
 end;
 if ReadPos = Size then
  PutByte(FEByte);
 SetLength(Dest, NewSize);
 Size := NewSize;
end;

Eraser   (2005-02-21 10:58:00) [3]

XProger ©
Спасибо большое за готовый алгоритм!

Это и сжатием обозвать довольно-таки сложно, ибо из 16 млн цветов ты получаешь всего 4096

Именно это мне и надо!

Можно создать палитру и переводить эти RGB цвета в 8 битный цвет (поиск ближайшего цвета в палитре) Но тогда будет 256 цветная картинка (это вобще кошмарики)

В том то и дело, что 256 цветов мало, а 16 бит - много.

Eraser   (2005-02-21 10:57:00) [4]

XProger ©
Спасибо большое за готовый алгоритм!

Это и сжатием обозвать довольно-таки сложно, ибо из 16 млн цветов ты получаешь всего 4096

Именно это мне и надо!

Можно создать палитру и переводить эти RGB цвета в 8 битный цвет (поиск ближайшего цвета в палитре) Но тогда будет 256 цветная картинка (это вобще кошмарики)

В том то и дело, что 256 мало, а 16 бит - много.

XProger   (2005-02-21 01:57:00) [5]

хм, ну не намного он сожмёт кстати :)
Ровно в 2 раза + потеря качества цвета.

А если хочешь попиксельно и быстро то...

type
TRGB = array [0..1] of record
 R, G, B : Byte;
end;
PRGB = ^TRGB;

var
bmp : TBitmap;

procedure Compress(k: integer);
var
x, y    : integer;
p       : PRGB;
begin
for y := 0 to bmp.Height - 1 do
begin
p := bmp.ScanLine[y];
for x := 0 to bmp.Width - 1 do
 begin
 // А тут махинации с
 // p[x].R;
 // p[x].G;
 // p[x].B;
 // т.е. p[x].R  := p[x].R and 120
 // а потом необходимо как-то умудриться запихнуть эти компоненты в массивчик если это надо (запомни что пихать нужно только левые 4 бита ;)
 end;
end;
end;

P.S.
Это и сжатием обозвать довольно-таки сложно, ибо из 16 млн цветов ты получаешь всего 4096 :)
Можно создать палитру и переводить эти RGB цвета в 8 битный цвет (поиск ближайшего цвета в палитре) Но тогда будет 256 цветная картинка (это вобще кошмарики)

Eraser   (2005-02-21 00:43:00) [6]

-->> XProger ©

Кстати спасибо огромное! Уже несколько недель ходил вокруг да около, а решение оказалось очень простым и очевидным (как и всё гениальное ;-))

Eraser   (2005-02-21 00:33:00) [7]

Всё! Дошло! (всмысле алгоритм ;))
А эту операцию можно ускорить. Попиксельно это черезчур медленно. Картинку надо обрабатывать довольно быстро...

Eraser   (2005-02-21 00:29:00) [8]

XProger ©

По-моему что-то типа этого я и искал!!!
Можно по подробнее? Есть ссылка на алгоритм?
Буду очень признателен.

XProger   (2005-02-20 23:46:00) [9]

У тебя есть цвета:
RGB
что можно с ними сделать?
Мона сжать в 12 битный цвет (аля NOKIA 3510i)
$AB CD EF = $A0 C0 E0
В итоге получаем ACE. Каждый по 4 бита => 12 бит
как тебе такой расклад?
Быстро и строго :)

Eraser   (2005-02-18 16:36:00) [10]

miek ©

Да много кто такое умеет делать! Только я не умею )

miek   (2005-02-18 13:26:00) [11]

GIFLite, JPEG optimizer, ну еще Xara Webstyler умеет такое делать.

Eraser   (2005-02-18 12:50:00) [12]

А есть ли быстрые упаковщики, даже точнее не упаковщики, а срезальщики "лишних" цветов с битмапа?
Задумка такая: уменьшить кол-во цветов в битмапе (до 512 например) и зжать ZLib'ом.

zero-g   (2005-02-16 02:02:00) [13]

to miek

Посмотрел ваш упаковшик :)
Тема :)
Ну теперь можете какой нибудь виев писать, с поддержкой вашего формата :)

Eraser   (2005-02-15 22:02:00) [14]

Дмитрий В. Белькевич

Интерес есть ОГРОМНЫЙ!!!
Буду очень благодарен.

miek   (2005-02-14 13:24:00) [15]

Я написал неплохой упаковщик, жмет сильно (местами лучше PNG), но оч-оч медленно. Распаковывает быстро.
http://www.miek.narod.ru/bis.zip

Дмитрий В. Белькевич   (2005-02-14 03:17:00) [16]

Могу реализацию RLE закинуть, если есть интерес.

Eraser   (2005-02-13 13:26:00) [17]

Дмитрий В. Белькевич

Я тоже сейчас использую zlib. Но хочется поэксерементировать. В мей программе очень важна скорость сжатия.

Дмитрий В. Белькевич   (2005-02-13 04:05:00) [18]

А чем zlib плох? У меня на лету постоянно в памяти битмапы (вернее, битовые цветовые массивы) пакуются/распаковываются. За счет резкого уменьшения требуемой память работает быстрее - в своп не сваливается. Включаешь fast алгоритм, он пакует чуть хуже, чем максмиальной компресии (на 10-20% результат больше), зато работает (на некоторых данных) на порядок быстрее.
Раньше рле пользовал - сжимал где-то в 2 раза, zlib сжимает часто в 4-5 раз, бывает 10, иногда в 20 раз.

Eraser   (2005-02-12 11:36:00) [19]

miek ©

Кроме zlib, он уже есть ))

miek   (2005-02-12 09:10:00) [20]

Zlib

Наверх

Титульная страница Поиск, карта сайта Написать письмо