Форум: "Media";
Текущий архив: 2005.06.06;
Скачать: [xml.tar.bz2];

Вниз

Быстрое сжатие битмапов   Найти похожие ветки 

← →
Eraser ©   (2005-02-11 19:00) [0]

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

---

← →
miek ©   (2005-02-12 09:10) [1]

Zlib

---

← →
Eraser ©   (2005-02-12 11:36) [2]

miek ©

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

---

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

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

---

← →
Eraser ©   (2005-02-13 13:26) [4]

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

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

---

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

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

---

← →
miek ©   (2005-02-14 13:24) [6]

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

---

← →
Eraser ©   (2005-02-15 22:02) [7]

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

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

---

← →
zero-g ©   (2005-02-16 02:02) [8]

to miek

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

---

← →
Eraser ©   (2005-02-18 12:50) [9]

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

---

← →
miek ©   (2005-02-18 13:26) [10]

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

---

← →
Eraser ©   (2005-02-18 16:36) [11]

miek ©

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

---

← →
XProger ©   (2005-02-20 23:46) [12]

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

---

← →
Eraser ©   (2005-02-21 00:29) [13]

XProger ©

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

---

← →
Eraser ©   (2005-02-21 00:33) [14]

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

---

← →
Eraser ©   (2005-02-21 00:43) [15]

-->> XProger ©

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

---

← →
XProger ©   (2005-02-21 01:57) [16]

хм, ну не намного он сожмёт кстати :)
Ровно в 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 10:57) [17]

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

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

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

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

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

---

← →
Eraser ©   (2005-02-21 10:58) [18]

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

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

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

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

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

---

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

Вот тебе еще до полного счастья 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-23 14:08) [20]

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

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

---

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

Форум: "Media";
Текущий архив: 2005.06.06;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.51 MB
Время: 0.013 c