diff --git a/Addons/KolZLib.pas b/Addons/KolZLib.pas deleted file mode 100644 index b5118bf..0000000 --- a/Addons/KolZLib.pas +++ /dev/null @@ -1,576 +0,0 @@ -{*******************************************************} -{ } -{ Delphi Supplemental Components } -{ ZLIB Data Compression Interface Unit } -{ } -{ Copyright (c) 1997 Borland International } -{ } -{*******************************************************} - -{ Modified for zlib 1.1.3 by Davide Moretti } -{ Modified for KOL by Alexey Shuvalov } -{ Updated to zlib 1.1.4 by Dimaxx } - -// Important! As this unit does not use Kol_Err.pas and SysUtils.pas, there is no -// exceptions raised. Therefore check for errors by comparing the values returned by -// functions such as Read/Write/Seek with value ZLIB_ERROR. - - -//Uncomment this to enable CompressBuf & DecompressBuf procedures. -//!!! This procedures converted but UNTESTED and MAY BE UNSTABLE !!! -//{$DEFINE BUFFERPROCS} - -unit KolZLib; - -{$I KOLDEF.INC} - -interface - -uses Windows, Kol; - -const - ZLIB_ERROR = TStrmSize (-1); - -type - TAlloc = function (AppData: Pointer; Items, Size: Integer): Pointer; - TFree = procedure (AppData, Block: Pointer); - - // Internal structure. Ignore. - TZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Integer; // number of bytes available at next_in - total_in: Integer; // total nb of input bytes read so far - - next_out: PChar; // next output byte should be put here - avail_out: Integer; // remaining free space at next_out - total_out: Integer; // total nb of bytes output so far - - msg: PChar; // last error message, NULL if no error - internal: Pointer; // not visible by applications - - zalloc: TAlloc; // used to allocate the internal state - zfree: TFree; // used to free the internal state - AppData: Pointer; // private data object passed to zalloc and zfree - - data_type: Integer; // best guess about the data type: ascii or binary - adler: Integer; // adler32 value of the uncompressed data - reserved: Integer; // reserved for future use - end; - - TZLibEvent = procedure (Sender: PStream) of Object; - - PZLibData = ^TZLibData; - TZLibData = record - FStrm: PStream; - FStrmPos: Cardinal; - FOnProgress: TZLibEvent; - FZRec: TZStreamRec; - FBuffer: array [Word] of Char; - end; - -{ TCompressionStream compresses data on the fly as data is written to it, and - stores the compressed data to another stream. - - TCompressionStream is write-only and strictly sequential. Reading from the - stream will raise an exception. Using Seek to move the stream pointer - will raise an exception. - - Output data is cached internally, written to the output stream only when - the internal output buffer is full. All pending output data is flushed - when the stream is destroyed. - - The Position property returns the number of uncompressed bytes of - data that have been written to the stream so far. - - CompressionRate returns the on-the-fly percentage by which the original - data has been compressed: (1 - (CompressedBytes / UncompressedBytes)) * 100 - If raw data size = 100 and compressed data size = 25, the CompressionRate - is 75% - - The OnProgress event is called each time the output buffer is filled and - written to the output stream. This is useful for updating a progress - indicator when you are writing a large chunk of data to the compression - stream in a single call.} - - TCompressionLevel = (clNone, clFastest, clDefault, clMax); - -//******************* NewCompressionStream ************************* -// Creates new ZLib decompression stream. If ZLib initialization failed returns Nil; -// On Read/Write errors Read/Write functions return ZLIB_ERROR value (also for Seek). - -function NewCompressionStream (CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): PStream; - -{ TDecompressionStream decompresses data on the fly as data is read from it. - - Compressed data comes from a separate source stream. TDecompressionStream - is read-only and unidirectional; you can seek forward in the stream, but not - backwards. The special case of setting the stream position to zero is - allowed. Seeking forward decompresses data until the requested position in - the uncompressed data has been reached. Seeking backwards, seeking relative - to the end of the stream, requesting the size of the stream, and writing to - the stream will return ZLIB_ERROR as a Result. - - The Position property returns the number of bytes of uncompressed data that - have been read from the stream so far. - - The OnProgress event is called each time the internal input buffer of - compressed data is exhausted and the next block is read from the input stream. - This is useful for updating a progress indicator when you are reading a - large chunk of data from the decompression stream in a single call.} - - -//******************* NewDecompressionStream ************************* -// Creates new ZLib decompression stream. If ZLib initialization failed returns Nil; -// On Read/Write errors Read/Write functions return ZLIB_ERROR value (also for Seek). - -function NewDecompressionStream (Source: PStream; OnProgress: TZLibEvent): PStream; - - -//******************* NewZLibXStream ************************* -//Calls New[De]CompressionStream and returns True if Result<>Nil; Stream = Result. -// !!! Don't use Overload on this functions - it may cause compilation error -// when called with OnProgress=Nil !!! - -function NewZLibDStream (var Stream: PStream; Source: PStream; OnProgress: TZLibEvent): Boolean; -function NewZLibCStream (var Stream: PStream; CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): Boolean; - - -{$IFDEF BUFFERPROCS} -{ CompressBuf compresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } - -function CompressBuf(const InBuf: Pointer; InBytes: Integer; out OutBuf: Pointer; out OutBytes: Integer): Boolean; - -{ DecompressBuf decompresses data, buffer to buffer, in one call. - In: InBuf = ptr to compressed data - InBytes = number of bytes in InBuf - OutEstimate = zero, or est. size of the decompressed data - Out: OutBuf = ptr to newly allocated buffer containing decompressed data - OutBytes = number of bytes in OutBuf } - -function DecompressBuf(const InBuf: Pointer; InBytes: Integer; OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer): Boolean; -{$ENDIF BUFFERPROCS} - -const - ZLib_Version = '1.1.4'; - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = (-1); - Z_STREAM_ERROR = (-2); - Z_DATA_ERROR = (-3); - Z_MEM_ERROR = (-4); - Z_BUF_ERROR = (-5); - Z_VERSION_ERROR = (-6); - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - - _z_errmsg: array[0..9] of PChar = ( - 'need dictionary', // Z_NEED_DICT (2) - 'stream end', // Z_STREAM_END (1) - '', // Z_OK (0) - 'file error', // Z_ERRNO (-1) - 'stream error', // Z_STREAM_ERROR (-2) - 'data error', // Z_DATA_ERROR (-3) - 'insufficient memory', // Z_MEM_ERROR (-4) - 'buffer error', // Z_BUF_ERROR (-5) - 'incompatible version', // Z_VERSION_ERROR (-6) - '' ); - -function adler32(adler: Integer; buf: PChar; len: Integer): Integer; - -{$L Obj\deflate.obj} -{$L Obj\trees.obj} -{$L Obj\inflate.obj} -{$L Obj\inftrees.obj} -{$L Obj\adler32.obj} -{$L Obj\infblock.obj} -{$L Obj\infcodes.obj} -{$L Obj\infutil.obj} -{$L Obj\inffast.obj} - -procedure _tr_init; external; -procedure _tr_tally; external; -procedure _tr_flush_block; external; -procedure _tr_align; external; -procedure _tr_stored_block; external; -function adler32; external; -procedure inflate_blocks_new; external; -procedure inflate_blocks; external; -procedure inflate_blocks_reset; external; -procedure inflate_blocks_free; external; -procedure inflate_set_dictionary; external; -procedure inflate_trees_bits; external; -procedure inflate_trees_dynamic; external; -procedure inflate_trees_fixed; external; -procedure inflate_codes_new; external; -procedure inflate_codes; external; -procedure inflate_codes_free; external; -procedure _inflate_mask; external; -procedure inflate_flush; external; -procedure inflate_fast; external; - -// deflate compresses data -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; recsize: Integer): Integer; external; -function deflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function deflateEnd(var strm: TZStreamRec): Integer; external; - -// inflate decompresses data -function inflateInit_(var strm: TZStreamRec; Version: PChar; recsize: Integer): Integer; external; -function inflate(var strm: TZStreamRec; flush: Integer): Integer; external; -function inflateEnd(var strm: TZStreamRec): Integer; external; -function inflateReset(var strm: TZStreamRec): Integer; external; - -implementation - -procedure _memset(P: Pointer; B: Byte; count: Integer);cdecl; -begin - FillChar(P^, count, Char( B )); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer);cdecl; -begin - Move(source^, dest^, count); -end; - -function zcalloc(AppData: Pointer; Items, Size: Integer): Pointer; -begin - GetMem(Result, Items*Size); -end; - -procedure zcfree(AppData, Block: Pointer); -begin - FreeMem(Block); -end; - -function ZCheck(Code: Integer; var Clear: Boolean): Integer; -begin - Result:=Code; - Clear:=Code>=0; -end; - -{$IFDEF BUFFERPROCS} -function CompressBuf(const InBuf: Pointer; InBytes: Integer; - out OutBuf: Pointer; out OutBytes: Integer): Boolean; -var - strm: TZStreamRec; - P: Pointer; -begin - Result:=True; - FillChar(strm, SizeOf(strm), 0); - OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - ZCheck(deflateInit_(strm, Z_BEST_COMPRESSION, zlib_version, sizeof(strm)), Result); - If not Result then Exit; - while (ZCheck(deflate(strm, Z_FINISH), Result)<>Z_STREAM_END) and Result do - begin - P := OutBuf; - Inc(OutBytes, 256); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := 256; - end; - If Result then ZCheck(deflateEnd(strm), Result) - else deflateEnd(strm); - If not Result then Exit; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - finally - If not Result then begin - FreeMem(OutBuf); - OutBuf:=nil; - end; - end; -end; - -function DecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer): Boolean; -var - strm: TZStreamRec; - P: Pointer; - BufInc: Integer; -begin - Result:=True; - FillChar(strm, sizeof(strm), 0); - BufInc := (InBytes + 255) and not 255; - if OutEstimate = 0 then - OutBytes := BufInc - else - OutBytes := OutEstimate; - GetMem(OutBuf, OutBytes); - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; - ZCheck(InflateInit_(strm, zlib_version, sizeof(strm)), Result); - If not Result then Exit; - while (ZCheck(Inflate(strm, Z_FINISH), Result) <> Z_STREAM_END) and Result do - begin - P := OutBuf; - Inc(OutBytes, BufInc); - ReallocMem(OutBuf, OutBytes); - strm.next_out := PChar(Integer(OutBuf) + (Integer(strm.next_out) - Integer(P))); - strm.avail_out := BufInc; - end; - If Result then ZCheck(inflateEnd(strm), Result) - else InflateEnd(strm); - If not Result Then Exit; - ReallocMem(OutBuf, strm.total_out); - OutBytes := strm.total_out; - finally - If not Result then begin - FreeMem(OutBuf); - OutBuf:=nil; - end; - end; -end; -{$ENDIF BUFFERPROCS} - -// Dummy methods -procedure DummySetSize(Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Value: TStrmSize); -asm -end; - -function DummyReadWrite (Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize; -begin - Result:=ZLIB_ERROR; -end; - -function DummyGetSize(Strm: PStream): TStrmSize; -begin - Result:=ZLIB_ERROR; -end; - -// CompressStream methods -function CZLibWriteStream(Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize; -var - Check: Boolean; -begin - Result:=ZLIB_ERROR; - With PZlibData (Strm.Methods.fCustom)^ do begin - FZRec.next_in := @Buffer; - FZRec.avail_in := Count; - If FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - While (FZRec.avail_in > 0) do begin - ZCheck(deflate(FZRec, 0), Check); - If not Check then Exit; - If FZRec.avail_out = 0 then begin - If FStrm.Write (FBuffer, SizeOf(FBuffer))<>SizeOf(FBuffer) then Exit; - FZRec.next_out := FBuffer; - FZRec.avail_out := SizeOf(FBuffer); - FStrmPos := FStrm.Position; - If Assigned (fOnProgress) then - fOnProgress (Strm); - end; - end; - end; - Result := Count; -end; - -function CZLibSeekStream(Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Offset: TStrmMove; Origin: TMoveMethod): TStrmSize; -begin - If (Offset = 0) and (Origin=spCurrent) then Result:=PZlibData (Strm.Methods.fCustom).FZRec.total_in - else Result:=ZLIB_ERROR; -end; - -procedure CZLibCloseStream(Strm: PStream); -var - Check: Boolean; -begin - With PZlibData (Strm.Methods.fCustom)^ do begin - FZRec.next_in := nil; - FZRec.avail_in := 0; - try - If FStrm.Position <> FStrmPos then FStrm.Position := FStrmPos; - while (ZCheck(deflate(FZRec, Z_FINISH), Check) <> Z_STREAM_END) and (FZRec.avail_out = 0) do begin - If not Check then Exit; - If FStrm.Write (FBuffer, SizeOf(FBuffer))<>SizeOf(FBuffer) then Exit; - FZRec.next_out := FBuffer; - FZRec.avail_out := sizeof(FBuffer); - end; - If FZRec.avail_out < SizeOf(FBuffer) then - FStrm.Write (FBuffer, SizeOf(FBuffer) - FZRec.avail_out) - finally - deflateEnd(FZRec); - Dispose (PZLibData (Strm.Methods.fCustom)); - end; - end; -end; - -// DecompressStream methods -procedure DZLibCloseStream(Strm: PStream); -begin - InflateEnd(PZLibData (Strm.Methods.fCustom).FZRec); - Dispose (PZLibData (Strm.Methods.fCustom)); -end; - -function DZLibSeekStream(Strm: PStream; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Offset: TStrmMove; Origin: TMoveMethod): TStrmSize; -var - I: Integer; - Buf: array [0..4095] of Char; - Check: Boolean; - Off: TStrmMove; -begin - Result:=ZLIB_ERROR; - Off := Offset; - With PZlibData (Strm.Methods.fCustom)^ do begin - If (Off=0) and (Origin=spBegin) then begin - ZCheck(InflateReset(FZRec), Check); - If not Check then Exit; - FZRec.next_in := FBuffer; - FZRec.avail_in := 0; - FStrm.Position := 0; - FStrmPos := 0; - end - else If ((Off>=0) and (Origin=spCurrent)) or (((Off-FZRec.total_out)>0) and (Origin=spBegin)) then begin - If Origin=spBegin then Dec(Off, FZRec.total_out); - If Off>0 then begin - for I:=1 to Off div SizeOf(Buf) do - If Strm.Read(Buf, SizeOf(Buf))=ZLIB_ERROR then Exit; - If Strm.Read(Buf, Off mod SizeOf(Buf))=ZLIB_ERROR then Exit; - end; - end else Exit; - Result:=FZRec.total_out; - end; -end; - -function DZLibReadStream (Strm: PStream; var Buffer; {$IFNDEF STREAM_COMPAT} const {$ENDIF} Count: TStrmSize): TStrmSize; -var - Check: Boolean; - D: PZLibData; -begin - Result:=ZLIB_ERROR; - D := PZlibData (Strm.Methods.fCustom); - D.FZRec.next_out := @Buffer; - D.FZRec.avail_out := Count; - If D.FStrm.Position <> D.FStrmPos then - D.FStrm.Position := D.FStrmPos; - While (D.FZRec.avail_out > 0) do begin - If D.FZRec.avail_in = 0 then begin - D.FZRec.avail_in := D.FStrm.Read(D.FBuffer, SizeOf(D.FBuffer)); - If D.FZRec.avail_in = 0 then begin - Result := Count - DWord(D.FZRec.avail_out); - Exit; - end; - D.FZRec.next_in := D.FBuffer; - D.FStrmPos := D.FStrm.Position; - If Assigned (D.fOnProgress) then - D.fOnProgress (Strm); - end; - ZCheck(Inflate(D.FZRec, 0), Check); - If not Check then Exit; - end; - Result:=Count; -end; - -const - BaseCZlibMethods: TStreamMethods = ( - fSeek: CZLibSeekStream; - fGetSiz: DummyGetSize; - fSetSiz: DummySetSize; - fRead: DummyReadWrite; - fWrite: CZLibWriteStream; - fClose: CZLibCloseStream; - fCustom: nil; ); - - BaseDZlibMethods: TStreamMethods = ( - fSeek: DZLibSeekStream; - fGetSiz: DummyGetSize; - fSetSiz: DummySetSize; - fRead: DZLibReadStream; - fWrite: DummyReadWrite; - fClose: DZLibCloseStream; - fCustom: nil; ); - -function NewDecompressionStream (Source: PStream; OnProgress: TZLibEvent): PStream; -var - Inited: Boolean; - ZLibData: PZLibData; -begin - New (ZLibData); - With ZLibData^ do begin - FillChar(FZRec, SizeOf(FZRec), #0); - FOnProgress:=OnProgress; - FStrm:=Source; - FStrmPos:=Source.Position; - FZRec.next_in := FBuffer; - FZRec.avail_in := 0; - ZCheck(InflateInit_(FZRec, ZLib_Version, SizeOf(FZRec)), Inited); - end; - If Inited then begin - Result:=_NewStream (BaseDZlibMethods); - Result.Methods.fCustom:=ZLibData; - end else begin - Dispose (ZLibData); - Result:=nil; - end; -end; - -function NewCompressionStream (CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): PStream; -const - Levels: array [TCompressionLevel] of ShortInt = (Z_NO_COMPRESSION, Z_BEST_SPEED, Z_DEFAULT_COMPRESSION, Z_BEST_COMPRESSION); -var - Inited: Boolean; - ZLibData: PZLibData; -begin - New (ZLibData); - With ZLibData^ do begin - FillChar(FZRec, SizeOf(FZRec), #0); - FOnProgress:=OnProgress; - FStrm:=Destination; - FStrmPos:=Destination.Position; - FZRec.next_out := FBuffer; - FZRec.avail_out := SizeOf(FBuffer); - ZCheck(deflateInit_(FZRec, Levels[CompressionLevel], ZLib_Version, SizeOf(FZRec)), Inited); - end; - If Inited then begin - Result:=_NewStream (BaseCZlibMethods); - Result.Methods.fCustom:=ZLibData; - end else begin - Dispose (ZLibData); - Result:=nil; - end; -end; - -function NewZLibDStream (var Stream: PStream; Source: PStream; OnProgress: TZLibEvent): boolean; -begin - Stream:=NewDecompressionStream (Source, OnProgress); - Result:=Assigned (Stream); -end; - -function NewZLibCStream (var Stream: PStream; CompressionLevel: TCompressionLevel; Destination: PStream; OnProgress: TZLibEvent): boolean; -begin - Stream:=NewCompressionStream (CompressionLevel, Destination, OnProgress); - Result:=Assigned (Stream); -end; - -end. - diff --git a/Addons/bis.pas b/Addons/bis.pas deleted file mode 100644 index 26aab32..0000000 --- a/Addons/bis.pas +++ /dev/null @@ -1,1017 +0,0 @@ -unit bis; -// Упаковщик изображений BIS V1.23 -// Image compression utility BIS v1.23 -// (C) 2004 Miek -// Freeware - -// Предназначен для сжатия изображений, имеющих большие области, -// заполненные одним цветом - -// Intended for compressing images with large areas filled by single colour - - -// Достоинства: -// Advantages: - -// + неограниченный коэффициент сжатия (пустые области любого размера -// могут быть сжаты в несколько бит) -// + unlimited compression ratio (empty areas of any size can be compressed -// into several bits) - -// + поддерживает форматы от 1 бит на пиксел до 32 бит на пиксел -// + supports any image formats from 1 bit per pixel to 32 bits per pixel - -// + малый объем кода -// + small code - -// + неплохая скорость распаковки -// + quick uncompression - -// Недостатки: -// Disadvantages: - -// - чувствителен к любым шумам (неоднородностям) в изображении -// - any noise (irregularity) in the source image lower the compression -// ratio considerably - -// - низкая скорость упаковки -// - low compression speed - -// - в данный момент не является thread-safe, т.е не может быть запущен -// одновременно из нескольких потоков одной программы -// - current version is not thread-safe - - -interface - -uses - windows, KOL, KOLadd, KOLZLib; - // Выходной двоичный поток компрессора направляется в ZIP-упаковщик. - // В принципе можно ZLIB заменить на любой другой модуль архивации, если он - // поддерживает последовательные операции с потоками. - - // The output stream of the compressor goes directly to the ZIP compressor. - // Any compression module which use similar interface (stream writing - // and reading) can be used inistead of ZLIB. - -const - BISmagic = $1200FADE; // сигнатура BIS-файла V1.2 - // BIS file signature V1.2 - - BISversion = '1.23'; // версия BIS - // program version - - beOK = 0; - beWriteError = 1; - beReadError = 2; - beWrongFileFormat = 3; - beWrongImageFormat = 4; - beUnknownError = 5; - - // сжать в существующий поток - // compress an image into a stream - procedure BISCompressToStream( source: pbitmap; var dst: pstream); - - // распаковать из существующего потока - // decompress an image from a stream - function BISDecompressFromStream( srcstream: pstream): pbitmap; - - // сжать в файл - // compress an image into a file - procedure BISCompressToFile( source: pbitmap; dstfilename: string); - - // распаковать из файла - // compress an image from a file - function BISDecompressFromFile( sourcefilename: string): pbitmap; - - // получить расшифровку текущего кода ошибки - // convert the current BIS error-code into a text string - function GetErrorString( errcode: integer): string; - -var - LastBISError: integer; - -implementation - -// sorry, further comments only in Russian! - -type - // К сожалению, TBits (пока) не имеет средств записи в поток - // Приходится изворачиваться самому - PBitsEx= ^TBitsEx; - TBitsEx = object( tbits) - procedure SaveToStream( dst: pstream); - function LoadFromStream( src: pstream): boolean; - end; - - // идентификатор результата анализа региона: - // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - // zUncompressed - регион не удалось сжать и он записан напрямую - // zMixed - регион содержит области разного типа - // zOne - регион заполнен единицами - // zZero - регион заполнен нулями - packresult = (zUncompressed=0, zMixed=1, zZero=2, zOne=3); - - // типы данных для более эффективного использования стека - tsmallpoint= packed record - x, y: smallint; - end; - - tsmallrectrec = packed record - a, b: tsmallpoint; - end; - - tsmallrect = int64; - -var - src: pbitmap; - data: PBitsEx; - bitindex: integer; - - scanline0: pointer; - scanlinedelta: integer; - -function GetErrorString; -begin - case errcode of - beOK: result:= 'No error'; - beWriteError: result:= 'Stream write error'; - beReadError: result:= 'Stream read error'; - beWrongFileFormat: result:= 'Wrong file format'; - beWrongImageFormat: result:= 'Wrong source image format'; - else result:= 'Unknown error'; - end; -end; - -{$R-} -// преобразовать две точки в упакованный прямоугольник -function packrect( a, b: tsmallpoint): tsmallrect; -begin - tsmallrectrec( result).a:= a; - tsmallrectrec( result).b:= b; -end; - -// переместить указатель в TBitsEx на начало -procedure rewind; -begin - bitindex:= 0; -end; - -// Взять следующий бит из потока -function peekbit: boolean; -begin - result:= data.Bits[ bitindex]; - inc( bitindex); -end; - -// Добавить бит в поток -procedure addbit( x: boolean); -begin - data.Bits[ bitindex]:= x; - inc( bitindex); -end; - -// записать в поток результат анализа региона -procedure writeresult( x: packresult); -begin - case x of - zUncompressed: - begin - addbit( false); - addbit( false); - end; - zMixed: - begin - addbit( false); - addbit( true); - end; - zZero: - begin - addbit( true); - addbit( false); - end; - zOne: - begin - addbit( true); - addbit( true); - end; - end; -end; - -// Используемый метод я пока не встречал в литературе, поэтому условно -// называю его методом бинарной декомпозиции (binary image splitting). -// --------------------------------------------------------------------- -// Суть компрессии в следующем. -// ----------------------------- -// Сжимается монохромное двумерное изображение. Если в исходном изображении -// глубина цвета больше, нужно его сначала разбить на битовые плоскости. - -// В рекурсивную процедуру передаются координаты сжимаемого региона (прямоугольника). -// Если регион пустой - заполнен одним цветом - в выходной поток будет записан -// код цвета. Если регион не пустой, в поток пишется соотв.признак, после чего -// регион разбивается на части (2 или 4, в зависимости от размера) и для каждой -// процедура вызывается рекурсивно. Узнать, пустой регион или нет, можно только -// после спуска в рекурсию, разумеется. - -// Когда размер региона дойдет до 1x1, содержимое региона будет -// определено однозначно и рекурсия пойдет назад. -// Во время рекурсивного анализа определяются случаи, когда все регионы, на -// которые был разбит регион-источник, оказались заполненными одним -// определенным цветом. В этом случае в поток не пишется ничего, предоставляя -// это более верхнему уровню рекурсии. При записи также определяется факт, что -// содержимое региона не удалось сжать - в этом случае записывает соотв.признак -// и следом напрямую содержимое региона. - -// P.S. Поскольку разбиение регионов на части однозначное, то их координаты -// никуда записывать не придется. - - -// запаковать регион в поток. Процедура рекурсивная, теоретически возможно -// переполнение стека, впрочем, такого пока не случалось -function pack( z: tsmallrect): packresult; -var - j, i: Integer; - rind: integer; - lt, lb, rt, rb: tsmallrectrec; - results: packed record - rlt, rlb, rrt, rrb: packresult; - end; -begin - result:= zMixed; - if lastbiserror<>beUnknownError then exit; - - // запомнить положение указателя в потоке - rind:= bitindex; - with tsmallrectrec( z), results do - begin - // если размер региона один пиксел, то его содержимое однозначно известно - // и здесь рекурсию надо отматывать назад - if (b.x=a.x) and (b.y=a.y) then - begin - // взять пиксел через прямой доступ в память - if src.dibpixels[ a.x, a.y]=0 then -// if byte( pointer( integer( scanline0)+a.y*scanlinedelta+a.x shr 3)^) and (1 shl (7-a.x and 7))=0 then - result:= zZero - else - result:= zOne; - end - else - begin - // иначе нужно разбить регион на части и для каждой сделать - // рекурсивный вызов - addbit( false); // временно пишем код zMixed - addbit( true); - lt:= tsmallrectrec( z); - rt:= tsmallrectrec( z); - lb:= tsmallrectrec( z); - rb:= tsmallrectrec( z); - if b.x-a.x>0 then - begin - if b.y-a.y>0 then - begin - // разбиваем на четыре части - lt.b.x:= lt.a.x+(lt.b.x-lt.a.x) div 2; - rt.a.x:= lt.b.x+1; - lb.b.x:= lt.b.x; - rb.a.x:= rt.a.x; - - lt.b.y:= lt.a.y+(lt.b.y-lt.a.y) div 2; - lb.a.y:= lt.b.y+1; - rt.b.y:= lt.b.y; - rb.a.y:= lb.a.y; - // анализ региона - rlt:= pack( tsmallrect( lt)); - // проанализировали регион: если он смешанный, то ничего не - // записываем в поток, потому что это уже сделал - // более глубокий уровень рекурсии - if rlt<>zMixed then - begin - // один маленький трюк: если регион сократился до одного - // пиксела, будем его код записывать одним битом, а не - // двумя! - if (lt.a.x=lt.b.x) and (lt.a.y=lt.b.y) then - addbit( rlt=zOne) - else - writeresult( rlt); - end; - - rrt:= pack( tsmallrect( rt)); - if rrt<>zMixed then - begin - if (rt.a.x=rt.b.x) and (rt.a.y=rt.b.y) then - addbit( rrt=zOne) - else - writeresult( rrt); - end; - rlb:= pack( tsmallrect( lb)); - if rlb<>zMixed then - begin - if (lb.a.x=lb.b.x) and (lb.a.y=lb.b.y) then - addbit( rlb=zOne) - else - writeresult( rlb); - end; - rrb:= pack( tsmallrect( rb)); - if rrb<>zMixed then - begin - if (rb.a.x=rb.b.x) and (rb.a.y=rb.b.y) then - addbit( rrb=zOne) - else - writeresult( rrb); - end; - - // если все части определены и одинаковы, ничего в поток - // писать не надо. Но туда уже записано заранее, поэтому - // просто возвращаем указатель на сохраненную позицию. - if (rlt=rrt) and (rlb=rrb) and (rlb=rrt) and (rlt<>zMixed) then - begin - result:= rlt; - bitindex:= rind; - end - else - begin - result:= zMixed; - // а если все-таки сжатый размер региона больше, чем - // исходный, то запишем код zUncompressed и следом - // "прямым текстом" это несжимаемое содержимое. - if (bitindex-rind)>(b.x-a.x+1)*(b.y-a.y+1) then - begin - bitindex:= rind; - writeresult( zUncompressed); - for j:= a.y to b.y do - begin - integer( lt.a):= integer( scanline0)+j*scanlinedelta; - for i:= a.x to b.x do - addbit( byte( pointer( integer( lt.a)+i shr 3)^) and (1 shl (7-i and 7))<>0); - end; - end; - end; - end - else - begin - // разбиваем на две части по горизонтали - lt.b.x:= lt.a.x+(lt.b.x-lt.a.x) div 2; - rt.a.x:= lt.b.x+1; - rlt:= pack( tsmallrect( lt)); - if rlt<>zMixed then - begin - if (lt.a.x=lt.b.x) and (lt.a.y=lt.b.y) then - addbit( rlt=zOne) - else - writeresult( rlt); - end; - rrt:= pack( tsmallrect( rt)); - if rrt<>zMixed then - begin - if (rt.a.x=rt.b.x) and (rt.a.y=rt.b.y) then - addbit( rrt=zOne) - else - writeresult( rrt); - end; - - if (rlt=rrt) and (rlt<>zMixed) then - begin - result:= rlt; - bitindex:= rind; - end - else - begin - result:= zMixed; - if (bitindex-rind)>(b.x-a.x+1)*(b.y-a.y+1) then - begin - bitindex:= rind; - writeresult( zUncompressed); - for j:= a.y to b.y do - begin - integer( lt.a):= integer( scanline0)+j*scanlinedelta; - for i:= a.x to b.x do - addbit( byte( pointer( integer( lt.a)+i shr 3)^) and (1 shl (7-i and 7))<>0); - end; - end; - end; - end; - end - else - begin - // разбиваем на две части по вертикали - lt.b.y:= lt.a.y+(lt.b.y-lt.a.y) div 2; - lb.a.y:= lt.b.y+1; - rlt:= pack( tsmallrect( lt)); - if rlt<>zMixed then - begin - if (lt.a.x=lt.b.x) and (lt.a.y=lt.b.y) then - addbit( rlt=zOne) - else - writeresult( rlt); - end; - rlb:= pack( tsmallrect( lb)); - if rlb<>zMixed then - begin - if (lb.a.x=lb.b.x) and (lb.a.y=lb.b.y) then - addbit( rlb=zOne) - else - writeresult( rlb); - end; - - if (rlt=rlb) and (rlt<>zMixed) then - begin - result:= rlt; - bitindex:= rind; - end - else - begin - result:= zMixed; - if (bitindex-rind)>(b.x-a.x+1)*(b.y-a.y+1) then - begin - bitindex:= rind; - writeresult( zUncompressed); - for j:= a.y to b.y do - begin - integer( lt.a):= integer( scanline0)+j*scanlinedelta; - for i:= a.x to b.x do - addbit( byte( pointer( integer( lt.a)+i shr 3)^) and (1 shl (7-i and 7))<>0); - end; - end; - end; - end; - end; - end; -end; - -procedure unpack( z: tsmallrect); -var - lt, lb, rt, rb: tsmallrectrec; - i, j: integer; -begin - if lastbiserror<>beUnknownError then exit; - - with tsmallrectrec( z) do - begin - // если регион сократился до одного пиксела, взять один бит - if (b.x=a.x) and (b.y=a.y) then - begin - if peekbit then - // установить пиксел через прямой доступ в память - src.DIBPixels[ a.x, a.y]:= clwhite; - end - else - begin - // берем первый бит 2-битного кода - if peekbit then - begin - // код zOne или zZero: регион заполнен одним цветом - if peekbit then - patblt( src.canvas.Handle, a.x, a.y, b.x-a.x+1, b.y-a.y+1, whiteness) - end - else - begin - if not peekbit then - // код zUncompressed: несжатый регион - begin - for j:= a.y to b.y do - for i:= a.x to b.x do - if peekbit then src.DIBPixels[ i, j]:= clwhite; - end - else - begin - // код zMixed: регион смешанный, углубить рекурсию - lt:= tsmallrectrec( z); - rt:= tsmallrectrec( z); - lb:= tsmallrectrec( z); - rb:= tsmallrectrec( z); - if b.x-a.x>0 then - begin - if b.y-a.y>0 then - begin - lt.b.x:= lt.a.x+(lt.b.x-lt.a.x) div 2; - lt.b.y:= lt.a.y+(lt.b.y-lt.a.y) div 2; - unpack( tsmallrect( lt)); - - rt.a.x:= lt.b.x+1; - rt.b.y:= lt.b.y; - unpack( tsmallrect( rt)); - - lb.b.x:= lt.b.x; - lb.a.y:= lt.b.y+1; - unpack( tsmallrect( lb)); - - rb.a.y:= lb.a.y; - rb.a.x:= rt.a.x; - unpack( tsmallrect( rb)); - end - else - begin - lt.b.x:= lt.a.x+(lt.b.x-lt.a.x) div 2; - unpack( tsmallrect( lt)); - - rt.a.x:= lt.b.x+1; - unpack( tsmallrect( rt)); - end; - end - else - begin - lt.b.y:= lt.a.y+(lt.b.y-lt.a.y) div 2; - unpack( tsmallrect( lt)); - - lb.a.y:= lt.b.y+1; - unpack( tsmallrect( lb)); - end; - end; - end; - end; - end; -end; - -function NewBitsEx: PBitsEx; -begin - result:= pbitsex( newbits); - result.Capacity:= 50000*8; - bitindex:= 0; -end; - -function TBitsEx.LoadFromStream; -var - i: integer; -begin - result:= false; - - if src.Read( i, sizeof( i))<>sizeof( i) then - lastbiserror:= beReadError; - if i<1 then exit; - self.bits[ i]:= false; - - if src.Read( self.fList.datamemory^, (i+7) shr 3)<>cardinal( (i+7) shr 3) then - lastbiserror:= beReadError; - self.fCount:= i; - result:= true; -end; - -procedure TBitsEx.SaveToStream( dst: pstream); -var - i: integer; -begin - i:= bitindex; - if dst.Write( i, sizeof( i))<>sizeof( i) then - lastbiserror:= beWriteError; - if dst.Write( self.fList.datamemory^, (i+7) shr 3)<>cardinal( (i+7) shr 3) then - lastbiserror:= beWriteError; -end; - -procedure getmask( src, dst: pbitmap; digit: integer); -var - i, j, k, l: integer; - ptr, p, psrc: pointer; -begin - k:= 1; - for i:= 1 to digit do - k:= k shl 1; - - scanline0:= src.ScanLine[ 0]; - scanlinedelta:= integer( src.ScanLine[ 1])-integer( ScanLine0); - ptr:= scanline0; - case src.pixelformat of - pf1bit: - for j:= 0 to src.Height-1 do - begin - p:= ptr; - psrc:= dst.ScanLine[ j]; - move( p^, psrc^, (src.Width+7) shr 3); - inc( integer( ptr), scanlinedelta); - end; - pf4bit: - for j:= 0 to src.Height-1 do - begin - psrc:= dst.ScanLine[ j]; - p:= ptr; - for i:= 0 to src.width-1 do - begin - if i and 1=0 then - l:= byte( p^) shr 4 - else - begin - l:= byte( p^) and $F; - inc( integer( p)); - end; - if l and k<>0 then - byte( psrc^):= byte( psrc^) or (1 shl ((7-i) and 7)); - if (i and 7)=7 then inc( integer( psrc)); - end; - inc( integer( ptr), scanlinedelta); - end; - pf8bit: - for j:= 0 to src.Height-1 do - begin - psrc:= dst.ScanLine[ j]; - p:= ptr; - digit:= 0; - for i:= 0 to src.width-1 do - begin - if byte( p^) and k<>0 then - digit:= digit or (1 shl ((7-i) and 7)); - inc( integer( p)); - if (i and 7)=7 then - begin - if digit<>0 then - byte( psrc^):= lo( digit); - inc( integer( psrc)); - digit:= 0; - end; - end; - if ((i and 7)<>7) and (digit<>0) then byte( psrc^):= digit; - inc( integer( ptr), scanlinedelta); - end; - pf15bit, pf16bit: - for j:= 0 to src.Height-1 do - begin - p:= ptr; - psrc:= dst.ScanLine[ j]; - digit:= 0; - for i:= 0 to src.width-1 do - begin - if word( p^) and k<>0 then - digit:= digit or (1 shl ((15-i) and 15)); - inc( integer( p), 2); - if (i and 15)=15 then - begin - if digit<>0 then - word( psrc^):= digit; - inc( integer( psrc), 2); - digit:= 0; - end; - end; - if ((i and 15)<>15) and (digit<>0) then word( psrc^):= digit; - inc( integer( ptr), scanlinedelta); - end; - pf24bit: - begin - for j:= 0 to src.Height-1 do - begin - p:= ptr; - psrc:= dst.ScanLine[ j]; - for i:= 0 to src.width-2 do - begin - if dword( p^) and k<>0 then - byte( psrc^):= byte( psrc^) or (1 shl ((7-i) and 7)); - inc( integer( psrc), ord( (i and 7)=7)); - inc( integer( p), 3); - end; - if src.DIBPixels[ src.width-1, j] and k<>0 then - byte( psrc^):= byte( psrc^) or (1 shl ((7-(src.width-1)) and 7)); - inc( integer( ptr), scanlinedelta); - end; - end; - pf32bit: - for j:= 0 to src.Height-1 do - begin - p:= ptr; - psrc:= dst.ScanLine[ j]; - digit:= 0; - for i:= 0 to src.width-1 do - begin - if dword( p^) and k<>0 then - digit:= digit or (1 shl ((31-i) and 31)); - inc( integer( p), 4); - if (i and 31)=31 then - begin - dword( psrc^):= digit; - inc( integer( psrc), 4); - digit:= 0; - end; - end; - if ((i and 31)<>31) and (digit<>0) then dword( psrc^):= digit; - inc( integer( ptr), scanlinedelta); - end; - end; -end; - -procedure putmask( src, dst: pbitmap; digit: integer); -var - i, j: integer; - k: cardinal; - p, psrc, ptr: pointer; - -begin - k:= 1; - for i:= 1 to digit do - k:= k shl 1; - - ptr:= scanline0; - case dst.BitsPerPixel of - 1: - begin - digit:= (src.Width+7) shr 3; - for j:= 0 to src.Height-1 do - begin - psrc:= ptr; - p:= dst.ScanLine[ j]; - move( psrc^, p^, digit); - inc( integer( ptr), scanlinedelta); - end; - end; - 4: - for j:= 0 to src.Height-1 do - begin - p:= dst.ScanLine[ j]; - psrc:= ptr; - for i:= 0 to src.width-1 do - begin - if byte( psrc^) and (1 shl ((7-i) and 7))<>0 then - begin - if i and 1=0 then - byte( p^):= byte( p^) or (k shl 4) - else - byte( p^):= byte( p^) or k; - end; - inc( integer( p), ord( i and 1<>0)); - inc( integer( psrc), ord( (i and 7)=7)); - end; - inc( integer( ptr), scanlinedelta); - end; - 8: - for j:= 0 to src.Height-1 do - begin - p:= dst.ScanLine[ j]; - psrc:= ptr; - digit:= byte( psrc^); - for i:= 0 to src.width-1 do - begin - if digit and (1 shl ((7-i) and 7))<>0 then - byte( p^):= byte( p^) or k; - inc( integer( p)); - if (i and 7=7) then - begin - inc( integer( psrc)); - if i0 then - word( p^):= word( p^) or k; - inc( integer( p), 2); - if (i and 15)=15 then - begin - inc( integer( psrc), 2); - if i0 then - dword( p^):= dword( p^) or k; - inc( integer( psrc), ord( (i and 7)=7)); - inc( integer( p), 3); - end; - if byte( psrc^) and (1 shl ((7-(src.width-1)) and 7))<>0 then - dword( pointer( integer( p)-1)^):= dword( pointer( integer( p)-1)^) or (k shl 8); - inc( integer( ptr), scanlinedelta); - end; - 32: - for j:= 0 to src.Height-1 do - begin - p:= dst.ScanLine[ j]; - psrc:= ptr; - digit:= dword( psrc^); - for i:= 0 to src.width-1 do - begin - if digit and (1 shl ((31-i) and 31))<>0 then - dword( p^):= dword( p^) or k; - inc( integer( p), 4); - if (i and 31)=31 then - begin - inc( integer( psrc), 4); - if i32766) or (source.height>32766) or - (source.PixelFormat=pfDevice) then - begin - lastbiserror:= beWrongImageFormat; - exit; - end; - if not NewZLibCStream( Zipper, clMax, Dst, nil) then exit; - - i:= source.Width; - if zipper.Write( i, sizeof( i))<>sizeof( i) then - lastbiserror:= bewriteerror; - i:= source.height; - if zipper.Write( i, sizeof( i))<>sizeof( i) then - lastbiserror:= bewriteerror; - i:= source.BitsPerPixel; - if zipper.Write( i, sizeof( i))<>sizeof( i) then - lastbiserror:= bewriteerror; - - i:= source.DIBPalEntryCount; - if zipper.Write( i, sizeof( i))<>sizeof( i) then - lastbiserror:= bewriteerror; - for i:= 0 to i-1 do - begin - bpp:= source.DIBPalEntries[ i]; - if zipper.Write( bpp, sizeof( bpp))<>sizeof( bpp) then - lastbiserror:= bewriteerror; - end; - - case source.PixelFormat of - pf1bit: bpp:= 1; - pf4bit: bpp:= 4; - pf8bit: bpp:= 8; - pf15bit: bpp:= 15; - pf16bit: bpp:= 16; - pf24bit: bpp:= 24; - else bpp:= 32; - end; - - // если изображение не монохромное, сначала разобьем его на битовые плоскости - for i:= 0 to bpp-1 do - begin - tmpbitmap[ i]:= newbitmap( source.Width, source.Height); - tmpbitmap[ i].PixelFormat:= pf1bit; - patblt( tmpbitmap[ i].canvas.Handle, 0, 0, tmpbitmap[ i].Width, tmpbitmap[ i].Height, blackness); - getmask( source, tmpbitmap[ i], i); -// tmpbitmap[ i].SaveToFile( int2str( i)+'.bmp'); - end; - - data:= newbitsex; - m.x:= 0; - m.y:= 0; - n.x:= source.Width-1; - n.y:= source.Height-1; - for i:= 0 to bpp-1 do - begin - src:= tmpbitmap[ i]; - scanline0:= src.ScanLine[ 0]; - scanlinedelta:= integer( src.ScanLine[ 1])-integer( scanline0); - rewind; - if lastbiserror<>beUnknownerror then - begin - zipper.free; - data.free; - exit; - end; - case pack( packrect( m, n)) of - zZero: - begin - addbit( true); - addbit( false); - end; - zOne: - begin - addbit( true); - addbit( true); - end; - end; - data.savetostream( zipper); - end; - zipper.Free; - data.free; - lastbiserror:= beOk; -end; - -function BISdecompressfromstream; -var - w, h, i, j, bpp: integer; - m, n: tsmallpoint; - unzipper: pstream; -begin - lastbiserror:= beUnknownError; - result:= nil; - if not NewZLibDStream( unZipper, srcstream, nil) then exit; - - data:= newbitsex; - bitindex:= 0; - - if unzipper.Read( w, sizeof( w))<>sizeof( w) then - lastbiserror:= bereaderror; - if unzipper.Read( h, sizeof( h))<>sizeof( h) then - lastbiserror:= bereaderror; - if unzipper.Read( bpp, sizeof( bpp))<>sizeof( bpp) then - lastbiserror:= bereaderror; - m.x:= 0; - m.y:= 0; - n.x:= W-1; - n.y:= H-1; - - src:= newdibbitmap( w, h, pf1bit); - result:= newbitmap( w, h); - case bpp of - 1: result.PixelFormat:= pf1bit; - 4: result.PixelFormat:= pf4bit; - 8: result.PixelFormat:= pf8bit; - 15: result.PixelFormat:= pf15bit; - 16: result.PixelFormat:= pf16bit; - 24: result.PixelFormat:= pf24bit; - 32: result.PixelFormat:= pf32bit; - end; - - if unzipper.read( i, sizeof( i))<>sizeof( i) then - lastbiserror:= bereaderror; - for i:= 0 to i-1 do - begin - if unzipper.read( j, sizeof( j))<>sizeof( j) then - lastbiserror:= bereaderror; - result.DIBPalEntries[ i]:= j; - end; - - patblt( result.canvas.Handle, 0, 0, result.Width, result.Height, blackness); - - for i:= 0 to bpp-1 do - begin - data.LoadFromStream( unzipper); - rewind; - patblt( src.canvas.Handle, 0, 0, result.Width, result.Height, blackness); - if lastbiserror<>beUnknownerror then - begin - unzipper.free; - src.free; - data.free; - exit; - end; - unpack( packrect( m, n)); - scanline0:= src.ScanLine[ 0]; - scanlinedelta:= integer( src.ScanLine[ 1])-integer( scanline0); -// src.SaveToFile( int2str( i)+'.bmp'); - putmask( src, result, i); - end; - unzipper.Free; - src.free; - data.free; - lastbiserror:= beOk; -end; - -procedure BISCompressToFile; -var - strm: pstream; - i: cardinal; -begin - lastbiserror:= beUnknownError; - strm:= newwritefilestream( dstfilename); - if strm=nil then exit; - i:= bismagic; - if strm.Write( i, sizeof( i))<>sizeof( i) then - begin - lastbisError:= bewriteerror; - strm.Free; - exit; - end; - biscompresstostream( source, strm); - strm.Free; - lastbiserror:= beOk; -end; - -function BISDecompressFromFile; -var - strm: pstream; - i: cardinal; -begin - lastbiserror:= beUnknownError; - result:= nil; - strm:= newreadfilestream( sourcefilename); - if strm=nil then exit; - if strm.Read( i, sizeof( i))<>sizeof( i) then - begin - lastbisError:= bereaderror; - strm.Free; - exit; - end; - if i=bismagic then - result:= bisdecompressfromstream( strm) - else - begin - lastbiserror:= beWrongFileFormat; - strm.free; - exit; - end; - strm.free; - lastbiserror:= beOk; -end; - -end. -