Главная страница
    Top.Mail.Ru    Яндекс.Метрика
Форум: "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
1-1116495478
Delphi_is_cool
2005-05-19 13:37
2005.06.06
Как убрать иконку с формы ?


14-1116490997
GrayFace
2005-05-19 12:23
2005.06.06
Протестируйте программу на Win9x и WinMe.


9-1110394276
Arkafon
2005-03-09 21:51
2005.06.06
GDI


4-1113721831
Ola
2005-04-17 11:10
2005.06.06
Как при запуске приложения менять курсор мыши на мой собственный.


1-1116484642
ANB
2005-05-19 10:37
2005.06.06
Как удобнее оформит передачу массива записей в функцию





Afrikaans Albanian Arabic Armenian Azerbaijani Basque Belarusian Bulgarian Catalan Chinese (Simplified) Chinese (Traditional) Croatian Czech Danish Dutch English Estonian Filipino Finnish French
Galician Georgian German Greek Haitian Creole Hebrew Hindi Hungarian Icelandic Indonesian Irish Italian Japanese Korean Latvian Lithuanian Macedonian Malay Maltese Norwegian
Persian Polish Portuguese Romanian Russian Serbian Slovak Slovenian Spanish Swahili Swedish Thai Turkish Ukrainian Urdu Vietnamese Welsh Yiddish Bengali Bosnian
Cebuano Esperanto Gujarati Hausa Hmong Igbo Javanese Kannada Khmer Lao Latin Maori Marathi Mongolian Nepali Punjabi Somali Tamil Telugu Yoruba
Zulu
Английский Французский Немецкий Итальянский Португальский Русский Испанский