diff --git a/Addons/HeapMM.pas b/Addons/HeapMM.pas deleted file mode 100644 index 51f6322..0000000 --- a/Addons/HeapMM.pas +++ /dev/null @@ -1,122 +0,0 @@ -{ - Alternative memory manager. To use it, just place a reference to this - unit *FIRST* in the uses clause of your project (dpr-file). It is a good idea - to use this memory manager with system dcu replacement by Vladimir Kladov. - - Heap API used, which is fast and very effective (allocated block granularity - is 16 bytes). One additional benefit is that some proofing tools (MemProof) - do not detect API failures, which those can find when standard Delphi memory - manager used. - ===================================================================== - Copyright (C) by Vladimir Kladov, 2001 - --------------------------------------------------------------------- - http://xcl.cjb.net - mailto: bonanzas@xcl.cjb.net -} - -unit HeapMM; - -interface - -uses windows; - -const - HEAP_NO_SERIALIZE = $00001; - HEAP_GROWABLE = $00002; - HEAP_GENERATE_EXCEPTIONS = $00004; - HEAP_ZERO_MEMORY = $00008; - HEAP_REALLOC_IN_PLACE_ONLY = $00010; - HEAP_TAIL_CHECKING_ENABLED = $00020; - HEAP_FREE_CHECKING_ENABLED = $00040; - HEAP_DISABLE_COALESCE_ON_FREE = $00080; - HEAP_CREATE_ALIGN_16 = $10000; - HEAP_CREATE_ENABLE_TRACING = $20000; - HEAP_MAXIMUM_TAG = $00FFF; - HEAP_PSEUDO_TAG_FLAG = $08000; - HEAP_TAG_SHIFT = 16 ; - -{$DEFINE USE_PROCESS_HEAP} - -var - HeapHandle: THandle; - {* Global handle to the heap. Do not change it! } - - HeapFlags: DWORD = 0; - {* Possible flags are: - HEAP_GENERATE_EXCEPTIONS - system will raise an exception to indicate a - function failure, such as an out-of-memory - condition, instead of returning NULL. - HEAP_NO_SERIALIZE - mutual exclusion will not be used while the HeapAlloc - function is accessing the heap. Be careful! - Not recommended for multi-thread applications. - But faster. - HEAP_ZERO_MEMORY - obviously. (Slower!) - } - - { Note from MSDN: - The granularity of heap allocations in Win32 is 16 bytes. So if you - request a global memory allocation of 1 byte, the heap returns a pointer - to a chunk of memory, guaranteeing that the 1 byte is available. Chances - are, 16 bytes will actually be available because the heap cannot allocate - less than 16 bytes at a time. - } -implementation - -function HeapGetMem(size: Integer): Pointer; -// Allocate memory block. -begin - Result := HeapAlloc( HeapHandle, HeapFlags, size ); -end; - -function HeapFreeMem(p: Pointer): Integer; -// Deallocate memory block. -begin - Result := Integer( not HeapFree( HeapHandle, HeapFlags and HEAP_NO_SERIALIZE, - p ) ); -end; - -function HeapReallocMem(p: Pointer; size: Integer): Pointer; -// Resize memory block. -begin - Result := HeapRealloc( HeapHandle, HeapFlags and (HEAP_NO_SERIALIZE and - HEAP_GENERATE_EXCEPTIONS and HEAP_ZERO_MEMORY), - // (Prevent using flag HEAP_REALLOC_IN_PLACE_ONLY here - to allow - // system to move the block if necessary). - p, size ); -end; - -{function HeapMemoryManagerSet: Boolean; -begin - Result := TRUE; -end;} - -const - HeapMemoryManager: TMemoryManager = ( - GetMem: HeapGetMem; - FreeMem: HeapFreeMem; - ReallocMem: HeapReallocMem); - -var OldMM: TMemoryManager; - //OldIsMMset: function : Boolean; - -initialization - - {$IFDEF USE_PROCESS_HEAP} - HeapHandle := GetProcessHeap; - {$ELSE} - HeapHandle := HeapCreate( 0, 0, 0 ); - {$ENDIF} - GetMemoryManager( OldMM ); - //OldIsMMset := IsMemoryManagerSet; - //IsMemoryManagerSet := HeapMemoryManagerSet; - SetMemoryManager( HeapMemoryManager ); - -finalization - - SetMemoryManager( OldMM ); - //IsMemoryManagerSet := OldIsMMset; - {$IFNDEF USE_PROCESS_HEAP} - HeapDestroy( HeapHandle ); - {$ENDIF} - -end. diff --git a/Addons/KolZLibBzip.pas b/Addons/KolZLibBzip.pas deleted file mode 100644 index 5d7aa33..0000000 --- a/Addons/KolZLibBzip.pas +++ /dev/null @@ -1,1960 +0,0 @@ -//{$DEFINE USE_EXCEPTIONS} -{***************************************************************************** -* unit based on * -* ZLibEx.pas (zlib 1.2.1) * -* Edition 2003.12.18 * -* * -* copyright (c) 2002-2003 Roberto Della Pasqua (www.dellapasqua.com) * -* copyright (c) 2000-2002 base2 technologies (www.base2ti.com) * -* copyright (c) 1997 Borland International (www.borland.com) * -* * -* and * -* * -* BZip2 unit by Edison Mera (www.geocities.com/efmera/) * -* Version 1.02 * -* Edition 21-11-2002 * -* * -* Changes made by GMax: * -* * -* units joined. gzip support functions added. * -* compression/decompression streams classes excluded, * -* compression/decompression stream2stream functions added * -* * -* procedures converted to functions to add "no exceptions" functionality * -* return values actual ONLY in this case (no exceptions) * -* error occured while value<0 * -* * -* function names for Z(De)Compress changed to Z(De)CompressBuf * -* * -* (C) GMax 2004. email: gmax@loving.ru * -*****************************************************************************} - -unit KOLZLibBzip; - -interface - -uses - KOL{$IFDEF USE_EXCEPTIONS}, ERR{$ENDIF}; - -const - ZLIB_VERSION = '1.2.1'; - BZIP_VERSION = '1.0.2'; - -type - TAlloc = function(opaque: Pointer; Items, Size: Integer): Pointer; cdecl; - TFree = procedure(opaque, Block: Pointer); cdecl; - - TZCompressionLevel = (zcNone, zcFastest, zcDefault, zcMax); - TZCompressionStrategy = (zcsDefault, zcsFiltered, zcsHuffmanOnly); - {** TZStreamRec ***********************************************************} - - TZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Longint; // number of bytes available at next_in - total_in: Longint; // total nb of input bytes read so far - - next_out: PChar; // next output byte should be put here - avail_out: Longint; // remaining free space at next_out - total_out: Longint; // total nb of bytes output so far - - msg: PChar; // last error message, NULL if no error - state: Pointer; // not visible by applications - - zalloc: TAlloc; // used to allocate the internal state - zfree: TFree; // used to free the internal state - opaque: Pointer; // private data object passed to zalloc and zfree - - data_type: Integer; // best guess about the data type: ascii or binary - adler: Longint; // adler32 value of the uncompressed data - reserved: Longint; // reserved for future use - end; - - {** zlib public routines ****************************************************} - - {***************************************************************************** - * ZCompressBuf * - * * - * pre-conditions * - * inBuffer = pointer to uncompressed data * - * inSize = size of inBuffer (bytes) * - * outBuffer = pointer (unallocated) * - * level = compression level * - * * - * post-conditions * - * outBuffer = pointer to compressed data (allocated) * - * outSize = size of outBuffer (bytes) * - *****************************************************************************} - -function ZCompressBuf(const inBuffer: Pointer; inSize: Integer; - out outBuffer: Pointer; out outSize: Integer; - level: TZCompressionLevel = zcDefault): Integer; - -{***************************************************************************** -* ZDecompressBuf * -* * -* pre-conditions * -* inBuffer = pointer to compressed data * -* inSize = size of inBuffer (bytes) * -* outBuffer = pointer (unallocated) * -* outEstimate = estimated size of uncompressed data (bytes) * -* * -* post-conditions * -* outBuffer = pointer to decompressed data (allocated) * -* outSize = size of outBuffer (bytes) * -*****************************************************************************} - -function ZDecompressBuf(const inBuffer: Pointer; inSize: Integer; - out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer = 0): Integer; - -{** string routines *********************************************************} - -function ZCompressStr(const s: string; level: TZCompressionLevel = zcDefault): string; - -function ZDecompressStr(const s: string): string; - -{** stream routines *********************************************************} - -function ZCompressStream(inStream, outStream: PStream; - level: TZCompressionLevel = zcDefault): Integer; - -function ZDecompressStream(inStream, outStream: PStream): Integer; - -{** utility routines ********************************************************} - -function adler32(adler: LongInt; const buf: PChar; len: Integer): LongInt; -function CRC32(CRC: Cardinal; const Data: PChar; cbData: Cardinal): Cardinal; -function compressBound(sourceLen: LongInt): LongInt; - -{****************************************************************************} - -procedure MoveI32(const Source; var Dest; Count: Integer); -procedure ZFastCompressString(var s: string; level: TZCompressionLevel); -procedure ZFastDecompressString(var s: string); -procedure ZSendToBrowser(var s: string); - -type - TgzipHeader = packed record - FileName: string; - Comment: string; - FileTime: TDateTime; - Extra: string; - end; - -function gZipCompressStream(inStream, outStream: PStream; var gzHdr: TgzipHeader; level: TZCompressionLevel = zcDefault; strategy: TZCompressionStrategy = zcsDefault): Integer; overload; -function gZipCompressStream(inStream, outStream: PStream; level: TZCompressionLevel = zcDefault; strategy: TZCompressionStrategy = zcsDefault): Integer; overload; -function gZipDecompressStreamHeader(inStream: PStream; var gzHdr: TgzipHeader): Integer; -function gZipDecompressStreamBody(inStream, outStream: PStream; const aCheckCRC: Boolean = True): Integer; -function gZipDecompressStream(inStream, outStream: PStream; var gzHdr: TgzipHeader): Integer; -function gZipDecompressString(const S: String; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): String; - -{*******************************************************} -{ } -{ BZIP2 Data Compression Interface Unit } -{ } -{*******************************************************} -type - // Internal structure. - TBZStreamRec = packed record - next_in: PChar; // next input byte - avail_in: Integer; // number of bytes available at next_in - total_in_lo32: Integer; // total nb of input bytes read so far - total_in_hi32: Integer; - - next_out: PChar; // next output byte should be put here - avail_out: Integer; // remaining free space at next_out - total_out_lo32: Integer; // total nb of bytes output so far - total_out_hi32: Integer; - - state: Pointer; - - bzalloc: TAlloc; // used to allocate the internal state - bzfree: TFree; // used to free the internal state - opaque: Pointer; - end; - TBlockSize100k = 1..9; - { 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 BZCompressBuf(const InBuf: Pointer; InBytes: Integer; - out OutBuf: Pointer; out OutBytes: Integer): Integer; - -{ 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 BZDecompressBuf(const InBuf: Pointer; InBytes: Integer; - OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer): Integer; - -function BZCompressStream(inStream, outStream: PStream; BlockSize100k: TBlockSize100k = 5): Integer; -function BZDecompressStream(inStream, outStream: PStream): Integer; - - -{** deflate routines ********************************************************} - -function deflateInit_(var strm: TZStreamRec; level: Integer; version: PChar; - recsize: Integer): Integer; external; - -function DeflateInit2_(var strm: TZStreamRec; level: integer; method: integer; windowBits: integer; - memLevel: integer; strategy: integer; version: PChar; recsize: integer): integer; external; - -function deflate(var strm: TZStreamRec; flush: Integer): Integer; - external; - -function deflateEnd(var strm: TZStreamRec): Integer; external; - -{** inflate routines ********************************************************} - -function inflateInit_(var strm: TZStreamRec; version: PChar; - recsize: Integer): Integer; external; - -function inflateInit2_(var strm: TZStreamRec; windowBits: integer; - 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; - -const - gzBufferSize = 16384; - gz_magic : array[0..1] of Byte = ($1F, $8B); - { gzip flag byte } - - GZF_ASCII_FLAG = $01; { bit 0 set: file probably ascii text } - GZF_HEAD_CRC = $02; { bit 1 set: header CRC present } - GZF_EXTRA_FIELD = $04; { bit 2 set: extra field present } - GZF_ORIG_NAME = $08; { bit 3 set: original file name present } - GZF_COMMENT = $10; { bit 4 set: file comment present } - GZF_RESERVED = $E0; { bits 5..7: reserved } - Z_EOF = -1; - -const - { ** Maximum value for windowBits in deflateInit2 and inflateInit2 } - MAX_WBITS = 15; - { ** Maximum value for memLevel in deflateInit2 } -const - MAX_MEM_LEVEL = 9; - DEF_MEM_LEVEL = 8; - - {** link zlib 1.2.1 *********************************************************} - {** bcc32 flags: -c -6 -O2 -Ve -X- -pr -a8 -b -d -k- -vi -tWM -r -RT- } - -{$L zlib\adler32.obj} -{$L zlib\compress.obj} - {.$L zlib\crc32.obj} -{$L zlib\deflate.obj} -{$L zlib\infback.obj} -{$L zlib\inffast.obj} -{$L zlib\inflate.obj} -{$L zlib\inftrees.obj} -{$L zlib\trees.obj} -{$L zlib\uncompr.obj} - - {***************************************************************************** - * note: do not reorder the above -- doing so will result in external * - * functions being undefined * - *****************************************************************************} - -const - {** flush constants *******************************************************} - - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - - {** return codes **********************************************************} - - 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_WRITE_ERROR = (-10); - Z_CRC_ERROR = (-11); - Z_SIZE_ERROR = (-12); - - {** compression levels ****************************************************} - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = (-1); - - {** compression strategies ************************************************} - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_DEFAULT_STRATEGY = 0; - - {** data types ************************************************************} - - Z_BINARY = 0; - Z_ASCII = 1; - Z_UNKNOWN = 2; - - {** compression methods ***************************************************} - - Z_DEFLATED = 8; - - Z_NULL = nil; { for initializing zalloc, zfree, opaque } - - {** return code messages **************************************************} - - _z_errmsg : array[0..14] 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) - '', '', '', - 'stream write error', // Z_WRITE_ERROR = (-10); - 'crc error', // Z_CRC_ERROR = (-11); - 'size mismarch' // Z_SIZE_ERROR = (-12); - ); - - ZLevels : array[TZCompressionLevel] of Shortint = ( - Z_NO_COMPRESSION, - Z_BEST_SPEED, - Z_DEFAULT_COMPRESSION, - Z_BEST_COMPRESSION - ); - ZStrategy : array[TZCompressionStrategy] of Shortint = ( - Z_DEFAULT_STRATEGY, - Z_FILTERED, - Z_HUFFMAN_ONLY - ); - - {************** BZip constants **********************************************} -{$L bz2\blocks~1.obj} //blocksort -{$L bz2\huffman.obj} -{$L bz2\compress.obj} -{$L bz2\decomp~1.obj} //decompress -{$L bz2\bzlib.obj} - { $L bz2\crctable.obj} - { $L bz2\randtable.obj} - -procedure _BZ2_hbMakeCodeLengths; external; -procedure _BZ2_blockSort; external; -procedure _BZ2_hbCreateDecodeTables; external; -procedure _BZ2_hbAssignCodes; external; -procedure _BZ2_compressBlock; external; -procedure _BZ2_decompress; external; - -const - bzBufferSize = 32768; - - BZ_RUN = 0; - BZ_FLUSH = 1; - BZ_FINISH = 2; - BZ_OK = 0; - BZ_RUN_OK = 1; - BZ_FLUSH_OK = 2; - BZ_FINISH_OK = 3; - BZ_STREAM_END = 4; - BZ_SEQUENCE_ERROR = (-1); - BZ_PARAM_ERROR = (-2); - BZ_MEM_ERROR = (-3); - BZ_DATA_ERROR = (-4); - BZ_DATA_ERROR_MAGIC = (-5); - BZ_IO_ERROR = (-6); - BZ_UNEXPECTED_EOF = (-7); - BZ_OUTBUFF_FULL = (-8); - - BZ_Error_Msg : array[1..8] of PChar = ( - 'BZ_SEQUENCE_ERROR', - 'BZ_PARAM_ERROR', - 'BZ_MEM_ERROR', - 'BZ_DATA_ERROR', - 'BZ_DATA_ERROR_MAGIC', - 'BZ_IO_ERROR', - 'BZ_UNEXPECTED_EOF', - 'BZ_OUTBUFF_FULL' - ); - - BZ_BLOCK_SIZE_100K = 9; - - _BZ2_rNums : array[0..511] of Longint = ( - 619, 720, 127, 481, 931, 816, 813, 233, 566, 247, - 985, 724, 205, 454, 863, 491, 741, 242, 949, 214, - 733, 859, 335, 708, 621, 574, 73, 654, 730, 472, - 419, 436, 278, 496, 867, 210, 399, 680, 480, 51, - 878, 465, 811, 169, 869, 675, 611, 697, 867, 561, - 862, 687, 507, 283, 482, 129, 807, 591, 733, 623, - 150, 238, 59, 379, 684, 877, 625, 169, 643, 105, - 170, 607, 520, 932, 727, 476, 693, 425, 174, 647, - 73, 122, 335, 530, 442, 853, 695, 249, 445, 515, - 909, 545, 703, 919, 874, 474, 882, 500, 594, 612, - 641, 801, 220, 162, 819, 984, 589, 513, 495, 799, - 161, 604, 958, 533, 221, 400, 386, 867, 600, 782, - 382, 596, 414, 171, 516, 375, 682, 485, 911, 276, - 98, 553, 163, 354, 666, 933, 424, 341, 533, 870, - 227, 730, 475, 186, 263, 647, 537, 686, 600, 224, - 469, 68, 770, 919, 190, 373, 294, 822, 808, 206, - 184, 943, 795, 384, 383, 461, 404, 758, 839, 887, - 715, 67, 618, 276, 204, 918, 873, 777, 604, 560, - 951, 160, 578, 722, 79, 804, 96, 409, 713, 940, - 652, 934, 970, 447, 318, 353, 859, 672, 112, 785, - 645, 863, 803, 350, 139, 93, 354, 99, 820, 908, - 609, 772, 154, 274, 580, 184, 79, 626, 630, 742, - 653, 282, 762, 623, 680, 81, 927, 626, 789, 125, - 411, 521, 938, 300, 821, 78, 343, 175, 128, 250, - 170, 774, 972, 275, 999, 639, 495, 78, 352, 126, - 857, 956, 358, 619, 580, 124, 737, 594, 701, 612, - 669, 112, 134, 694, 363, 992, 809, 743, 168, 974, - 944, 375, 748, 52, 600, 747, 642, 182, 862, 81, - 344, 805, 988, 739, 511, 655, 814, 334, 249, 515, - 897, 955, 664, 981, 649, 113, 974, 459, 893, 228, - 433, 837, 553, 268, 926, 240, 102, 654, 459, 51, - 686, 754, 806, 760, 493, 403, 415, 394, 687, 700, - 946, 670, 656, 610, 738, 392, 760, 799, 887, 653, - 978, 321, 576, 617, 626, 502, 894, 679, 243, 440, - 680, 879, 194, 572, 640, 724, 926, 56, 204, 700, - 707, 151, 457, 449, 797, 195, 791, 558, 945, 679, - 297, 59, 87, 824, 713, 663, 412, 693, 342, 606, - 134, 108, 571, 364, 631, 212, 174, 643, 304, 329, - 343, 97, 430, 751, 497, 314, 983, 374, 822, 928, - 140, 206, 73, 263, 980, 736, 876, 478, 430, 305, - 170, 514, 364, 692, 829, 82, 855, 953, 676, 246, - 369, 970, 294, 750, 807, 827, 150, 790, 288, 923, - 804, 378, 215, 828, 592, 281, 565, 555, 710, 82, - 896, 831, 547, 261, 524, 462, 293, 465, 502, 56, - 661, 821, 976, 991, 658, 869, 905, 758, 745, 193, - 768, 550, 608, 933, 378, 286, 215, 979, 792, 961, - 61, 688, 793, 644, 986, 403, 106, 366, 905, 644, - 372, 567, 466, 434, 645, 210, 389, 550, 919, 135, - 780, 773, 635, 389, 707, 100, 626, 958, 165, 504, - 920, 176, 193, 713, 857, 265, 203, 50, 668, 108, - 645, 990, 626, 197, 510, 357, 358, 850, 858, 364, - 936, 638 - ); - - _BZ2_crc32Table : array[0..255] of Longint = ( - $00000000, $04C11DB7, $09823B6E, $0D4326D9, - $130476DC, $17C56B6B, $1A864DB2, $1E475005, - $2608EDB8, $22C9F00F, $2F8AD6D6, $2B4BCB61, - $350C9B64, $31CD86D3, $3C8EA00A, $384FBDBD, - $4C11DB70, $48D0C6C7, $4593E01E, $4152FDA9, - $5F15ADAC, $5BD4B01B, $569796C2, $52568B75, - $6A1936C8, $6ED82B7F, $639B0DA6, $675A1011, - $791D4014, $7DDC5DA3, $709F7B7A, $745E66CD, - -$67DC4920, -$631D54A9, -$6E5E7272, -$6A9F6FC7, - -$74D83FC4, -$70192275, -$7D5A04AE, -$799B191B, - -$41D4A4A8, -$4515B911, -$48569FCA, -$4C97827F, - -$52D0D27C, -$5611CFCD, -$5B52E916, -$5F93F4A3, - -$2BCD9270, -$2F0C8FD9, -$224FA902, -$268EB4B7, - -$38C9E4B4, -$3C08F905, -$314BDFDE, -$358AC26B, - -$0DC57FD8, -$09046261, -$044744BA, -$0086590F, - -$1EC1090C, -$1A0014BD, -$17433266, -$13822FD3, - $34867077, $30476DC0, $3D044B19, $39C556AE, - $278206AB, $23431B1C, $2E003DC5, $2AC12072, - $128E9DCF, $164F8078, $1B0CA6A1, $1FCDBB16, - $018AEB13, $054BF6A4, $0808D07D, $0CC9CDCA, - $7897AB07, $7C56B6B0, $71159069, $75D48DDE, - $6B93DDDB, $6F52C06C, $6211E6B5, $66D0FB02, - $5E9F46BF, $5A5E5B08, $571D7DD1, $53DC6066, - $4D9B3063, $495A2DD4, $44190B0D, $40D816BA, - -$535A3969, -$579B24E0, -$5AD80207, -$5E191FB2, - -$405E4FB5, -$449F5204, -$49DC74DB, -$4D1D696E, - -$7552D4D1, -$7193C968, -$7CD0EFBF, -$7811F20A, - -$6656A20D, -$6297BFBC, -$6FD49963, -$6B1584D6, - -$1F4BE219, -$1B8AFFB0, -$16C9D977, -$1208C4C2, - -$0C4F94C5, -$088E8974, -$05CDAFAB, -$010CB21E, - -$39430FA1, -$3D821218, -$30C134CF, -$3400297A, - -$2A47797D, -$2E8664CC, -$23C54213, -$27045FA6, - $690CE0EE, $6DCDFD59, $608EDB80, $644FC637, - $7A089632, $7EC98B85, $738AAD5C, $774BB0EB, - $4F040D56, $4BC510E1, $46863638, $42472B8F, - $5C007B8A, $58C1663D, $558240E4, $51435D53, - $251D3B9E, $21DC2629, $2C9F00F0, $285E1D47, - $36194D42, $32D850F5, $3F9B762C, $3B5A6B9B, - $0315D626, $07D4CB91, $0A97ED48, $0E56F0FF, - $1011A0FA, $14D0BD4D, $19939B94, $1D528623, - -$0ED0A9F2, -$0A11B447, -$075292A0, -$03938F29, - -$1DD4DF2E, -$1915C29B, -$1456E444, -$1097F9F5, - -$28D8444A, -$2C1959FF, -$215A7F28, -$259B6291, - -$3BDC3296, -$3F1D2F23, -$325E09FC, -$369F144D, - -$42C17282, -$46006F37, -$4B4349F0, -$4F825459, - -$51C5045E, -$550419EB, -$58473F34, -$5C862285, - -$64C99F3A, -$6008828F, -$6D4BA458, -$698AB9E1, - -$77CDE9E6, -$730CF453, -$7E4FD28C, -$7A8ECF3D, - $5D8A9099, $594B8D2E, $5408ABF7, $50C9B640, - $4E8EE645, $4A4FFBF2, $470CDD2B, $43CDC09C, - $7B827D21, $7F436096, $7200464F, $76C15BF8, - $68860BFD, $6C47164A, $61043093, $65C52D24, - $119B4BE9, $155A565E, $18197087, $1CD86D30, - $029F3D35, $065E2082, $0B1D065B, $0FDC1BEC, - $3793A651, $3352BBE6, $3E119D3F, $3AD08088, - $2497D08D, $2056CD3A, $2D15EBE3, $29D4F654, - -$3A56D987, -$3E97C432, -$33D4E2E9, -$3715FF60, - -$2952AF5B, -$2D93B2EE, -$20D09435, -$24118984, - -$1C5E343F, -$189F298A, -$15DC0F51, -$111D12E8, - -$0F5A42E3, -$0B9B5F56, -$06D8798D, -$0219643C, - -$764702F7, -$72861F42, -$7FC53999, -$7B042430, - -$6543742B, -$6182699E, -$6CC14F45, -$680052F4, - -$504FEF4F, -$548EF2FA, -$59CDD421, -$5D0CC998, - -$434B9993, -$478A8426, -$4AC9A2FD, -$4E08BF4C - ); - -// deflate compresses data - -function BZ2_bzCompressInit(var strm: TBZStreamRec; blockSize100k: Integer; - verbosity: Integer; workFactor: Integer): Integer; stdcall; external; - -function BZ2_bzCompress(var strm: TBZStreamRec; action: Integer): Integer; stdcall; external; - -function BZ2_bzCompressEnd(var strm: TBZStreamRec): Integer; stdcall; external; - -function BZ2_bzBuffToBuffCompress(dest: Pointer; var destLen: Integer; source: Pointer; - sourceLen, blockSize100k, verbosity, workFactor: Integer): Integer; stdcall; external; - -// inflate decompresses data - -function BZ2_bzDecompressInit(var strm: TBZStreamRec; verbosity: Integer; - small: Integer): Integer; stdcall; external; - -function BZ2_bzDecompress(var strm: TBZStreamRec): Integer; stdcall; external; - -function BZ2_bzDecompressEnd(var strm: TBZStreamRec): Integer; stdcall; external; - -function BZ2_bzBuffToBuffDecompress(dest: Pointer; var destLen: Integer; source: Pointer; - sourceLen, small, verbosity: Integer): Integer; stdcall; external; - -{** utility routines *******************************************************} - -function adler32; external; -function compressBound; external; - -// -function InflateInit(var stream: TZStreamRec): Integer; - -implementation - -procedure _bz_internal_error(errcode: Integer); cdecl; -begin -{$IFDEF USE_EXCEPTIONS} - //raise EBZip2Error.CreateFmt('Compression Error %d', [errcode]); - raise Exception.CreateFMT(e_Convert, 'Compression Error %d', [errcode]); - // I don't know, what make in {$ELSE} :( -{$ENDIF} -end; - -function _malloc(size: Integer): Pointer; cdecl; -begin - GetMem(Result, Size); -end; - -procedure _free(block: Pointer); cdecl; -begin - FreeMem(block); -end; - -function bzip2AllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; -begin - GetMem(Result, Items * Size); -end; - -procedure bzip2FreeMem(AppData, Block: Pointer); cdecl; -begin - FreeMem(Block); -end; - -{*********************** Peter Morris not aligned move **********************} - -procedure MoveI32(const Source; var Dest; Count: Integer); register; -asm - cmp ECX,0 - Je @JustQuit - push ESI - push EDI - mov ESI, EAX - mov EDI, EDX - @Loop: - Mov AL, [ESI] - Inc ESI - mov [EDI], AL - Inc EDI - Dec ECX - Jnz @Loop - pop EDI - pop ESI - @JustQuit: -end; -{****************************************************************************} - -{** utility routines *******************************************************} - -//function crc32; external; -function CRC32(CRC: Cardinal; const Data: PChar; cbData: Cardinal): Cardinal; assembler; -asm - or edx, edx - je @@exi - jecxz @@exi - xor eax,0FFFFFFFFh - push ebx -@@upd: - movzx ebx, al - xor bl, [ edx ] - shr eax, 8 - and eax, 00FFFFFFh - xor eax, cs:[ebx*4 + offset @@c32tt ]//OFFSET @@C32TT ] - inc edx - loop @@upd - pop ebx - xor eax,0FFFFFFFFh -@@exi: - ret - -@@C32TT: - -DD 000000000h, 077073096h, 0ee0e612ch, 0990951bah -DD 0076dc419h, 0706af48fh, 0e963a535h, 09e6495a3h -DD 00edb8832h, 079dcb8a4h, 0e0d5e91eh, 097d2d988h -DD 009b64c2bh, 07eb17cbdh, 0e7b82d07h, 090bf1d91h -DD 01db71064h, 06ab020f2h, 0f3b97148h, 084be41deh -DD 01adad47dh, 06ddde4ebh, 0f4d4b551h, 083d385c7h -DD 0136c9856h, 0646ba8c0h, 0fd62f97ah, 08a65c9ech -DD 014015c4fh, 063066cd9h, 0fa0f3d63h, 08d080df5h -DD 03b6e20c8h, 04c69105eh, 0d56041e4h, 0a2677172h -DD 03c03e4d1h, 04b04d447h, 0d20d85fdh, 0a50ab56bh -DD 035b5a8fah, 042b2986ch, 0dbbbc9d6h, 0acbcf940h -DD 032d86ce3h, 045df5c75h, 0dcd60dcfh, 0abd13d59h -DD 026d930ach, 051de003ah, 0c8d75180h, 0bfd06116h -DD 021b4f4b5h, 056b3c423h, 0cfba9599h, 0b8bda50fh -DD 02802b89eh, 05f058808h, 0c60cd9b2h, 0b10be924h -DD 02f6f7c87h, 058684c11h, 0c1611dabh, 0b6662d3dh -DD 076dc4190h, 001db7106h, 098d220bch, 0efd5102ah -DD 071b18589h, 006b6b51fh, 09fbfe4a5h, 0e8b8d433h -DD 07807c9a2h, 00f00f934h, 09609a88eh, 0e10e9818h -DD 07f6a0dbbh, 0086d3d2dh, 091646c97h, 0e6635c01h -DD 06b6b51f4h, 01c6c6162h, 0856530d8h, 0f262004eh -DD 06c0695edh, 01b01a57bh, 08208f4c1h, 0f50fc457h -DD 065b0d9c6h, 012b7e950h, 08bbeb8eah, 0fcb9887ch -DD 062dd1ddfh, 015da2d49h, 08cd37cf3h, 0fbd44c65h -DD 04db26158h, 03ab551ceh, 0a3bc0074h, 0d4bb30e2h -DD 04adfa541h, 03dd895d7h, 0a4d1c46dh, 0d3d6f4fbh -DD 04369e96ah, 0346ed9fch, 0ad678846h, 0da60b8d0h -DD 044042d73h, 033031de5h, 0aa0a4c5fh, 0dd0d7cc9h -DD 05005713ch, 0270241aah, 0be0b1010h, 0c90c2086h -DD 05768b525h, 0206f85b3h, 0b966d409h, 0ce61e49fh -DD 05edef90eh, 029d9c998h, 0b0d09822h, 0c7d7a8b4h -DD 059b33d17h, 02eb40d81h, 0b7bd5c3bh, 0c0ba6cadh -DD 0edb88320h, 09abfb3b6h, 003b6e20ch, 074b1d29ah -DD 0ead54739h, 09dd277afh, 004db2615h, 073dc1683h -DD 0e3630b12h, 094643b84h, 00d6d6a3eh, 07a6a5aa8h -DD 0e40ecf0bh, 09309ff9dh, 00a00ae27h, 07d079eb1h -DD 0f00f9344h, 08708a3d2h, 01e01f268h, 06906c2feh -DD 0f762575dh, 0806567cbh, 0196c3671h, 06e6b06e7h -DD 0fed41b76h, 089d32be0h, 010da7a5ah, 067dd4acch -DD 0f9b9df6fh, 08ebeeff9h, 017b7be43h, 060b08ed5h -DD 0d6d6a3e8h, 0a1d1937eh, 038d8c2c4h, 04fdff252h -DD 0d1bb67f1h, 0a6bc5767h, 03fb506ddh, 048b2364bh -DD 0d80d2bdah, 0af0a1b4ch, 036034af6h, 041047a60h -DD 0df60efc3h, 0a867df55h, 0316e8eefh, 04669be79h -DD 0cb61b38ch, 0bc66831ah, 0256fd2a0h, 05268e236h -DD 0cc0c7795h, 0bb0b4703h, 0220216b9h, 05505262fh -DD 0c5ba3bbeh, 0b2bd0b28h, 02bb45a92h, 05cb36a04h -DD 0c2d7ffa7h, 0b5d0cf31h, 02cd99e8bh, 05bdeae1dh -DD 09b64c2b0h, 0ec63f226h, 0756aa39ch, 0026d930ah -DD 09c0906a9h, 0eb0e363fh, 072076785h, 005005713h -DD 095bf4a82h, 0e2b87a14h, 07bb12baeh, 00cb61b38h -DD 092d28e9bh, 0e5d5be0dh, 07cdcefb7h, 00bdbdf21h -DD 086d3d2d4h, 0f1d4e242h, 068ddb3f8h, 01fda836eh -DD 081be16cdh, 0f6b9265bh, 06fb077e1h, 018b74777h -DD 088085ae6h, 0ff0f6a70h, 066063bcah, 011010b5ch -DD 08f659effh, 0f862ae69h, 0616bffd3h, 0166ccf45h -DD 0a00ae278h, 0d70dd2eeh, 04e048354h, 03903b3c2h -DD 0a7672661h, 0d06016f7h, 04969474dh, 03e6e77dbh -DD 0aed16a4ah, 0d9d65adch, 040df0b66h, 037d83bf0h -DD 0a9bcae53h, 0debb9ec5h, 047b2cf7fh, 030b5ffe9h -DD 0bdbdf21ch, 0cabac28ah, 053b39330h, 024b4a3a6h -DD 0bad03605h, 0cdd70693h, 054de5729h, 023d967bfh -DD 0b3667a2eh, 0c4614ab8h, 05d681b02h, 02a6f2b94h -DD 0b40bbe37h, 0c30c8ea1h, 05a05df1bh, 02d02ef8dh - -end; - -{** zlib function implementations *******************************************} - -function zcalloc(opaque: Pointer; items, size: Integer): Pointer; -begin - GetMem(result, items * size); -end; - -procedure zcfree(opaque, block: Pointer); -begin - FreeMem(block); -end; - -{** c function implementations **********************************************} - -procedure _memset(p: Pointer; b: Byte; count: Integer); cdecl; -begin - FillChar(p^, count, b); -end; - -procedure _memcpy(dest, source: Pointer; count: Integer); cdecl; -begin - Move(source^, dest^, count); -end; - -{** custom zlib routines ****************************************************} - -function DeflateInit(var stream: TZStreamRec; level: Integer): Integer; -begin - result := DeflateInit_(stream, level, ZLIB_VERSION, SizeOf(TZStreamRec)); -end; - -function DeflateInit2(var stream: TZStreamRec; level, method, windowBits, memLevel, strategy: Integer): Integer; -begin - result := DeflateInit2_(stream, level, method, windowBits, memLevel, - strategy, ZLIB_VERSION, SizeOf(TZStreamRec)); -end; - -function InflateInit(var stream: TZStreamRec): Integer; -begin - result := InflateInit_(stream, ZLIB_VERSION, SizeOf(TZStreamRec)); -end; - -function InflateInit2(var stream: TZStreamRec; windowBits: Integer): Integer; -begin - result := InflateInit2_(stream, windowBits, ZLIB_VERSION, SizeOf(TZStreamRec)); -end; - -{****************************************************************************} -{$IFDEF USE_EXCEPTIONS} - -function ZCompressCheck(code: Integer): Integer; -begin - result := code; - - if code < 0 then begin - raise Exception.CreateFMT(e_Convert, 'Compression Error %d - %s', [code, _z_errmsg[2 - code]]); - end; -end; - -function ZDecompressCheck(code: Integer): Integer; -begin - Result := code; - - if code < 0 then begin - raise Exception.CreateFMT(e_Convert, 'Decompression Error %d - %s', [code, _z_errmsg[2 - code]]); - end; -end; -{$ENDIF} - -{****************************************************************************} -{****************************************************************************} -{****************************************************************************} -{**** implementation itself *************************************************} -{****************************************************************************} -{****************************************************************************} -{****************************************************************************} - -function ZCompressBuf(const inBuffer: Pointer; inSize: Integer; out outBuffer: Pointer; out outSize: Integer; level: TZCompressionLevel): Integer; -const - delta = 256; -var - zstream : TZStreamRec; -begin - FillChar(zstream, SizeOf(TZStreamRec), 0); - Result := Z_OK; - outSize := ((inSize + (inSize div 10) + 12) + 255) and not 255; - outBuffer := nil; - GetMem(outBuffer, outSize); - try - zstream.next_in := inBuffer; - zstream.avail_in := inSize; - zstream.next_out := outBuffer; - zstream.avail_out := outSize; -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(DeflateInit(zstream, ZLevels[level])); -{$ELSE} - Result := DeflateInit(zstream, ZLevels[level]); - if Result < 0 then Exit; -{$ENDIF} - try -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(deflate(zstream, Z_FINISH)); -{$ELSE} - Result := deflate(zstream, Z_FINISH); - if Result < 0 then Exit; -{$ENDIF} - while Result <> Z_STREAM_END do begin - Inc(outSize, delta); - ReallocMem(outBuffer, outSize); - - zstream.next_out := PChar(Integer(outBuffer) + zstream.total_out); - zstream.avail_out := delta; -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(deflate(zstream, Z_FINISH)); -{$ELSE} - Result := deflate(zstream, Z_FINISH); - if Result < 0 then Exit; -{$ENDIF} - end; // while - finally -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(deflateEnd(zstream)); -{$ELSE} - deflateEnd(zstream); -{$ENDIF} - end; - - ReallocMem(outBuffer, zstream.total_out); - outSize := zstream.total_out; -{$IFDEF USE_EXCEPTIONS} - except - FreeMem(outBuffer); - raise; -{$ELSE} - finally - if Result < 0 then FreeMem(outBuffer); -{$ENDIF} - end; -end; - -function ZCompressBuf2(const inBuffer: Pointer; inSize: Integer; out outBuffer: Pointer; out outSize: Integer): Integer; -const - delta = 256; -var - zstream : TZStreamRec; -begin - FillChar(zstream, SizeOf(TZStreamRec), 0); - - outSize := ((inSize + (inSize div 10) + 12) + 255) and not 255; - GetMem(outBuffer, outSize); - Result := Z_OK; - try - zstream.next_in := inBuffer; - zstream.avail_in := inSize; - zstream.next_out := outBuffer; - zstream.avail_out := outSize; -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(DeflateInit2(zstream, 1, 8, -15, 9, 0)); -{$ELSE} - Result := DeflateInit2(zstream, 1, 8, -15, 9, 0); - if Result < 0 then Exit; -{$ENDIF} - - try -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(deflate(zstream, Z_FINISH)); -{$ELSE} - Result := deflate(zstream, Z_FINISH); - if Result < 0 then Exit; -{$ENDIF} - while Result <> Z_STREAM_END do begin - Inc(outSize, delta); - ReallocMem(outBuffer, outSize); - - zstream.next_out := PChar(Integer(outBuffer) + zstream.total_out); - zstream.avail_out := delta; -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(deflate(zstream, Z_FINISH)); -{$ELSE} - Result := deflate(zstream, Z_FINISH); - if Result < 0 then Exit; -{$ENDIF} - end; // while - finally -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(deflateEnd(zstream)); -{$ELSE} - deflateEnd(zstream); -{$ENDIF} - end; - - ReallocMem(outBuffer, zstream.total_out); - outSize := zstream.total_out; -{$IFDEF USE_EXCEPTIONS} - except - FreeMem(outBuffer); - raise; -{$ELSE} - finally - if Result < 0 then FreeMem(outBuffer); -{$ENDIF} - end; -end; - -function ZDecompressBuf(const inBuffer: Pointer; inSize: Integer; out outBuffer: Pointer; out outSize: Integer; outEstimate: Integer): Integer; -var - zstream : TZStreamRec; - delta : Integer; -begin - FillChar(zstream, SizeOf(TZStreamRec), 0); - - delta := (inSize + 255) and not 255; - - if outEstimate = 0 then outSize := delta - else outSize := outEstimate; - Result := Z_OK; - GetMem(outBuffer, outSize); - try - zstream.next_in := inBuffer; - zstream.avail_in := inSize; - zstream.next_out := outBuffer; - zstream.avail_out := outSize; - -{$IFDEF USE_EXCEPTIONS} - ZDecompressCheck(InflateInit(zstream)); -{$ELSE} - Result := InflateInit(zstream); - if Result < 0 then Exit; -{$ENDIF} - - try -{$IFDEF USE_EXCEPTIONS} - Result := ZDecompressCheck(inflate(zstream, Z_NO_FLUSH)); -{$ELSE} - Result := inflate(zstream, Z_NO_FLUSH); - if Result < 0 then Exit; -{$ENDIF} - while (Result <> Z_STREAM_END) do begin - Inc(outSize, delta); - ReallocMem(outBuffer, outSize); - - zstream.next_out := PChar(Integer(outBuffer) + zstream.total_out); - zstream.avail_out := delta; -{$IFDEF USE_EXCEPTIONS} - Result := ZDecompressCheck(inflate(zstream, Z_NO_FLUSH)); -{$ELSE} - Result := inflate(zstream, Z_NO_FLUSH); - if Result < 0 then Exit; -{$ENDIF} - end; - finally -{$IFDEF USE_EXCEPTIONS} - ZDecompressCheck(inflateEnd(zstream)); -{$ELSE} - inflateEnd(zstream); -{$ENDIF} - end; - - ReallocMem(outBuffer, zstream.total_out); - outSize := zstream.total_out; - -{$IFDEF USE_EXCEPTIONS} - except - FreeMem(outBuffer); - raise; -{$ELSE} - finally - if Result < 0 then FreeMem(outBuffer); -{$ENDIF} - end; -end; - -{** string routines *********************************************************} - -function ZCompressStr(const s: string; level: TZCompressionLevel): string; -var - buffer : Pointer; - size : Integer; -begin - ZCompressBuf(PChar(s), Length(s), buffer, size, level); - SetLength(result, size); - Move(buffer^, pointer(result)^, size); - FreeMem(buffer); -end; - -procedure ZFastCompressString(var s: string; level: TZCompressionLevel); -var - outBuf : Pointer; - outBytes : Integer; -begin - ZCompressBuf(pointer(s), length(s), outBuf, outBytes, level); - SetLength(s, outBytes); - MoveI32(pointer(outBuf)^, pointer(s)^, outBytes); - FreeMem(outBuf); -end; - -procedure ZFastDecompressString(var s: string); -var - outBuf : Pointer; - outBytes : Integer; -begin - ZDecompressBuf(pointer(s), Length(s), outBuf, outBytes); - SetLength(s, outBytes); - MoveI32(pointer(outBuf)^, pointer(s)^, outBytes); - FreeMem(outBuf); -end; - -procedure ZSendToBrowser(var s: string); -var - outBuf : Pointer; - outBytes : Integer; -begin - ZCompressBuf2(pointer(s), length(s), outBuf, outBytes); - SetLength(s, outBytes); - Move(pointer(outBuf)^, pointer(s)^, outBytes); - FreeMem(outBuf); -end; - -function ZDecompressStr(const s: string): string; -var - buffer : Pointer; - size : Integer; -begin - ZDecompressBuf(PChar(s), Length(s), buffer, size); - SetLength(result, size); - Move(buffer^, pointer(result)^, size); - FreeMem(buffer); -end; - -{** stream routines *********************************************************} - -function ZCompressStream(inStream, outStream: PStream; level: TZCompressionLevel): Integer; -const - bufferSize = 32768; -var - zstream : TZStreamRec; - inBuffer : array[0..bufferSize - 1] of Char; - outBuffer : array[0..bufferSize - 1] of Char; - inSize : Integer; - outSize : Integer; -begin - FillChar(zstream, SizeOf(TZStreamRec), 0); -{$IFDEF USE_EXCEPTIONS} - Result := Z_OK; - ZCompressCheck(DeflateInit(zstream, ZLevels[level])); -{$ELSE} - Result := DeflateInit(zstream, ZLevels[level]); - if Result < 0 then Exit; -{$ENDIF} - try - inSize := inStream.Read(inBuffer, bufferSize); - - while inSize > 0 do begin - zstream.next_in := inBuffer; - zstream.avail_in := inSize; - - repeat - zstream.next_out := outBuffer; - zstream.avail_out := bufferSize; - -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(deflate(zstream, Z_NO_FLUSH)); -{$ELSE} - Result := deflate(zstream, Z_NO_FLUSH); - if Result < 0 then Exit; -{$ENDIF} - - // outSize := zstream.next_out - outBuffer; - outSize := bufferSize - zstream.avail_out; - - outStream.Write(outBuffer, outSize); - until (zstream.avail_in = 0) and (zstream.avail_out > 0); - - inSize := inStream.Read(inBuffer, bufferSize); - end; - - repeat - zstream.next_out := outBuffer; - zstream.avail_out := bufferSize; - -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(deflate(zstream, Z_FINISH)); -{$ELSE} - Result := deflate(zstream, Z_FINISH); - if Result < 0 then Break; -{$ENDIF} - - // outSize := zstream.next_out - outBuffer; - outSize := bufferSize - zstream.avail_out; - - outStream.Write(outBuffer, outSize); - until (Result = Z_STREAM_END) and (zstream.avail_out > 0); - finally -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(deflateEnd(zstream)); -{$ELSE} - deflateEnd(zstream); -{$ENDIF} - end; -end; - -function ZDecompressStream(inStream, outStream: PStream): Integer; -const - bufferSize = 32768; -var - zstream : TZStreamRec; - inBuffer : array[0..bufferSize - 1] of Char; - outBuffer : array[0..bufferSize - 1] of Char; - inSize : Integer; - outSize : Integer; -begin - FillChar(zstream, SizeOf(TZStreamRec), 0); - -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(InflateInit(zstream)); -{$ELSE} - Result := InflateInit(zstream); - if Result < 0 then Exit; -{$ENDIF} - try - inSize := inStream.Read(inBuffer, bufferSize); - - while inSize > 0 do begin - zstream.next_in := inBuffer; - zstream.avail_in := inSize; - - repeat - zstream.next_out := outBuffer; - zstream.avail_out := bufferSize; - -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(inflate(zstream, Z_NO_FLUSH)); -{$ELSE} - Result := inflate(zstream, Z_NO_FLUSH); - if Result < 0 then Exit; -{$ENDIF} - - // outSize := zstream.next_out - outBuffer; - outSize := bufferSize - zstream.avail_out; - - outStream.Write(outBuffer, outSize); - until (zstream.avail_in = 0) and (zstream.avail_out > 0); - - inSize := inStream.Read(inBuffer, bufferSize); - end; - - repeat - zstream.next_out := outBuffer; - zstream.avail_out := bufferSize; - -{$IFDEF USE_EXCEPTIONS} - Result := ZCompressCheck(inflate(zstream, Z_FINISH)); -{$ELSE} - Result := inflate(zstream, Z_FINISH); - if Result < 0 then Break; -{$ENDIF} - - // outSize := zstream.next_out - outBuffer; - outSize := bufferSize - zstream.avail_out; - - outStream.Write(outBuffer, outSize); - until (Result = Z_STREAM_END) and (zstream.avail_out > 0); - finally -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(inflateEnd(zstream)); -{$ELSE} - inflateEnd(zstream); -{$ENDIF} - end; -end; - -{** gzip Stream routines ******************************************************} -const - UnixDateDelta = 25569; - -function DateTimeToUnix(ConvDate: TDateTime): Longint; -begin - //example: DateTimeToUnix(now); - Result := Round((ConvDate - UnixDateDelta) * 86400); -end; - -function UnixToDateTime(USec: Longint): TDateTime; -begin - //Example: UnixToDateTime(1003187418); - Result := (Usec / 86400) + UnixDateDelta; -end; - -function gZipCompressStream(inStream, outStream: PStream; var gzHdr: TgzipHeader; level: TZCompressionLevel = zcDefault; strategy: TZCompressionStrategy = zcsDefault): Integer; -var - rSize, - wSize, - zResult : LongInt; - done : Boolean; - iBuffer, - oBuffer : PChar; //Array [0..gzBufferSize-1] of Char; - fCrc : Cardinal; - zStream : TZStreamRec; - stamp : Integer; - -begin - iBuffer := nil; - oBuffer := nil; -{$IFDEF USE_EXCEPTIONS} - Result := Z_MEM_ERROR; -{$ENDIF} - try - GetMem(iBuffer, gzBufferSize); - GetMem(oBuffer, gzBufferSize); - - fCrc := 0; - FillChar(zStream, SizeOf(zStream), 0); - -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(DeflateInit2(zStream, ZLevels[level], Z_DEFLATED, -MAX_WBITS, - DEF_MEM_LEVEL, ZStrategy[strategy])); -{$ELSE} - Result := DeflateInit2(zStream, ZLevels[level], Z_DEFLATED, -MAX_WBITS, - DEF_MEM_LEVEL, ZStrategy[strategy]); - if Result < 0 then Exit; -{$ENDIF} - { windowBits is passed < 0 to suppress zlib header } - oBuffer[0] := Char(gz_magic[0]); - oBuffer[1] := Char(gz_magic[1]); // gz Magic - oBuffer[2] := #08; // gz Compression method - oBuffer[3] := #0; - // set mtime - { - Inc(gzHdr.TimeStamp,gzTimeStampCorrection); - oBuffer[4]:=Lo(gzHdr.TimeStamp and $FFFF); oBuffer[5]:=Hi(gzHdr.TimeStamp and $FFFF); - oBuffer[6]:=Lo(gzHdr.TimeStamp shr 16); oBuffer[7]:=Hi(gzHdr.TimeStamp shr 16); - Dec(gzHdr.TimeStamp,gzTimeStampCorrection); - } - stamp := DateTimeToUnix(gzHdr.FileTime); - oBuffer[4] := Char(Lo(stamp and $FFFF)); - oBuffer[5] := Char(Hi(stamp and $FFFF)); - oBuffer[6] := Char(Lo(stamp shr 16)); - oBuffer[7] := Char(Hi(stamp shr 16)); - - // xfl, os code sets to 0 - oBuffer[8] := #0; - oBuffer[9] := #0; - - if gzHdr.FileName <> '' then begin - oBuffer[3] := Char(Byte(oBuffer[3]) or GZF_ORIG_NAME); - end; - if gzHdr.Comment <> '' then begin - oBuffer[3] := Char(Byte(oBuffer[3]) or GZF_COMMENT); - end; - if gzHdr.Extra <> '' then begin - oBuffer[3] := Char(Byte(oBuffer[3]) or GZF_EXTRA_FIELD); - end; - wSize := outStream.Write(oBuffer^, 10); -{$IFDEF USE_EXCEPTIONS} - if wSize <> 10 then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if wSize <> 10 then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - - // extra - if (byte(oBuffer[3]) and GZF_EXTRA_FIELD) <> 0 then begin - rSize := Length(gzHdr.Extra); - Move(gzHdr.Extra[1], iBuffer^, rSize); - iBuffer[rSize] := #0; - Inc(rSize); - wSize := outStream.Write(iBuffer^, rSize); -{$IFDEF USE_EXCEPTIONS} - if wSize <> rSize then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if wSize <> rSize then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - end; - // filename - if (byte(oBuffer[3]) and GZF_ORIG_NAME) <> 0 then begin - rSize := Length(gzHdr.FileName); - Move(gzHdr.FileName[1], iBuffer^, rSize); - iBuffer[rSize] := #0; - Inc(rSize); - wSize := outStream.Write(iBuffer^, rSize); -{$IFDEF USE_EXCEPTIONS} - if wSize <> rSize then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if wSize <> rSize then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - end; - // comment - if (byte(oBuffer[3]) and GZF_COMMENT) <> 0 then begin - rSize := Length(gzHdr.Comment); - Move(gzHdr.Comment[1], iBuffer^, rSize); - iBuffer[rSize] := #0; - Inc(rSize); - wSize := outStream.Write(iBuffer^, rSize); -{$IFDEF USE_EXCEPTIONS} - if wSize <> rSize then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if wSize <> rSize then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - end; - // hcrc - - rSize := inStream.Read(iBuffer^, gzBufferSize); - zStream.next_out := PChar(oBuffer); - zStream.avail_out := gzBufferSize; - repeat - //DoProgressEvent; - zStream.next_in := PChar(iBuffer); - zStream.avail_in := rSize; - while (zStream.avail_in <> 0) do begin - if (zStream.avail_out = 0) then begin - zStream.next_out := PChar(oBuffer); - wSize := outStream.Write(oBuffer^, gzBufferSize); - if (wSize <> gzBufferSize) then begin -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - Result := Z_WRITE_ERROR; - Exit; -{$ENDIF} - end; - zStream.avail_out := gzBufferSize; - end; -{$IFDEF USE_EXCEPTIONS} - ZCompressCheck(deflate(zStream, Z_NO_FLUSH)); -{$ELSE} - Result := deflate(zStream, Z_NO_FLUSH); - if Result < 0 then Exit; -{$ENDIF} - end; // while - fCrc := Crc32(fCrc, PChar(iBuffer), rSize); - rSize := inStream.Read(iBuffer^, gzBufferSize); - until rSize = 0; - { flush buffers } - zStream.avail_in := 0; { should be zero already anyway } - done := False; - - repeat - rSize := gzBufferSize - zStream.avail_out; - if (rSize <> 0) then begin - wSize := outStream.Write(oBuffer^, rSize); -{$IFDEF USE_EXCEPTIONS} - if (wSize <> rSize) then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if (wSize <> rSize) then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - zStream.next_out := PChar(oBuffer); - zStream.avail_out := gzBufferSize; - end; - if done then Break; - zResult := deflate(zStream, Z_FINISH); - if (rSize = 0) and (zResult = Z_BUF_ERROR) then -{$IFDEF USE_EXCEPTIONS} - else ZCompressCheck(zResult); -{$ELSE} - else begin - Result := zResult; - if Result < 0 then Exit; - end; -{$ENDIF} - { deflate has finished flushing only when it hasn't used up - all the available space in the output buffer: } - done := (zStream.avail_out <> 0) or (zResult = Z_STREAM_END); - until False; - wSize := outStream.Write(fCrc, 4); -{$IFDEF USE_EXCEPTIONS} - if wSize <> 4 then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if wSize <> 4 then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - rSize := inStream.Size; - wSize := outStream.Write(rSize, 4); -{$IFDEF USE_EXCEPTIONS} - if wSize <> 4 then ZCompressCheck(Z_WRITE_ERROR); -{$ELSE} - if wSize <> 4 then begin - Result := Z_WRITE_ERROR; - Exit; - end; -{$ENDIF} - Result := Z_OK; - finally - deflateEnd(zStream); - if Assigned(iBuffer) then FreeMem(iBuffer); - if Assigned(oBuffer) then FreeMem(oBuffer); - end; -end; - -function gZipCompressStream(inStream, outStream: PStream; level: TZCompressionLevel = zcDefault; strategy: TZCompressionStrategy = zcsDefault): Integer; overload; -var - gzHdr : TgzipHeader; -begin - FillChar(gzHdr, SizeOf(gzHdr), 0); - gzHdr.FileTime := Date; - Result := gZipCompressStream(inStream, outStream, gzHdr, level, strategy); -end; - -function gZipDecompressStreamHeader(inStream: PStream; var gzHdr: TgzipHeader): Integer; -var - i, c, flg : LongInt; - fEOF : Boolean; - - function gz_getbyte: Integer; - var - b, c : Integer; - begin - b := 0; - c := inStream.Read(b, 1); - if c = 0 then begin - fEOF := True; - Result := Z_EOF; - end - else Result := b; - end; - - function gz_getlong: Integer; - var - b, c : Integer; - begin - b := 0; - c := inStream.Read(b, 4); - if c < 4 then begin - fEOF := True; - Result := Z_EOF; - end - else Result := b; - end; -begin - // fTransparent := False; - Result := Z_OK; - fEOF := False; - gzHdr.FileName := ''; - gzHdr.Comment := ''; - gzHdr.Extra := ''; - try - for i := 0 to 1 do begin - flg := gz_getbyte; - if (flg <> gz_magic[i]) then begin - fEOF := True; - exit; - end; - end; - c := gz_getbyte; // method - flg := gz_getbyte; // flags - if (c <> Z_DEFLATED) or ((flg and GZF_RESERVED) <> 0) then begin - fEOF := True; - exit; - end; - - gzHdr.FileTime := UnixToDateTime(gz_getLong); - gz_getbyte; - gz_getbyte; { skip xflags and OS code } - - if (flg and GZF_EXTRA_FIELD) <> 0 then begin // skip extra fields - i := gz_getbyte + (gz_getbyte shl 8); // length of extra - SetLength(gzHdr.Extra, i); - c := inStream.Read(gzHdr.Extra, i); - if c <> i then begin - fEOF := True; - Exit; - end; - end; - if (flg and GZF_ORIG_NAME) <> 0 then begin // extract File Name - repeat - c := gz_getbyte; - if (c <> 0) and (c <> Z_EOF) then gzHdr.FileName := gzHdr.FileName + char(c); - until (c = 0) or (c = Z_EOF); - end; - if (flg and GZF_COMMENT) <> 0 then begin // extract Comment - repeat - c := gz_getbyte; - if (c <> 0) and (c <> Z_EOF) then gzHdr.Comment := gzHdr.Comment + char(c); - until (c = 0) or (c = Z_EOF); - end; - if (flg and GZF_HEAD_CRC) <> 0 then begin // skip head crc - gz_getbyte; - gz_getbyte; - end; - finally - if fEOF then Result := Z_DATA_ERROR - else Result := Z_OK; - end; -end; - -function gZipDecompressStreamBody(inStream, outStream: PStream; const aCheckCRC: Boolean = True): Integer; -var - iBuffer, - oBuffer : PChar; //Array [0..gzBufferSize-1] of Char; - fCrc : Cardinal; - zStream : TZStreamRec; - rSize, - wSize : LongInt; - startCRC : PChar; - fileCRC, - fileSize : Cardinal; - fEOF : Boolean; - - function gz_getbyte: Integer; - begin - // if (eof) then result:=-1; - if (zStream.avail_in = 0) then begin - zStream.avail_in := inStream.Read(iBuffer^, gzBufferSize); - if (zStream.avail_in = 0) then begin - Result := Z_EOF; - fEOF := True; - exit; - end - else zStream.next_in := PChar(iBuffer); - end; - Dec(zStream.avail_in); - Result := Byte(zStream.next_in[0]); - Inc(zStream.next_in); - end; - - function gz_getLong: Cardinal; - var - c : Integer; - begin - c := gz_getbyte; - c := c + gz_getbyte shl 8; - c := c + gz_getbyte shl 16; - c := c + gz_getbyte shl 24; - Result := Cardinal(c); - end; -begin - iBuffer := nil; - oBuffer := nil; -{$IFDEF USE_EXCEPTIONS} - Result := Z_MEM_ERROR; -{$ENDIF} - try - GetMem(iBuffer, gzBufferSize); - GetMem(oBuffer, gzBufferSize); - fEOF := False; - {Check the gzip header of a gz_stream opened for reading. - Set the stream mode to transparent if the gzip magic header is not present.} - - FillChar(zStream, SizeOf(zStream), 0); - zStream.next_in := pChar(iBuffer); - fCRC := 0; - { windowBits is passed < 0 to tell that there is no zlib header } -{$IFDEF USE_EXCEPTIONS} - ZDecompressCheck(InflateInit2(zStream, -MAX_WBITS)); -{$ELSE} - Result := InflateInit2(zStream, -MAX_WBITS); - if Result < 0 then Exit; -{$ENDIF} - while not fEOF do begin - // gzread() - // DoProgressEvent; - startCRC := PChar(oBuffer); - zStream.next_out := PChar(oBuffer); - zStream.avail_out := gzBufferSize; -// rSize := 0; - Result := Z_OK; - while zStream.avail_out <> 0 do begin - // not transparent - if (zStream.avail_in = 0) and (not fEOF) then begin - zStream.avail_in := inStream.Read(iBuffer^, gzBufferSize); - if (zStream.avail_in = 0) then fEOF := True; - zStream.next_in := PChar(iBuffer); - end; - Result := inflate(zStream, Z_NO_FLUSH); - if (Result = Z_STREAM_END) then begin - { Check CRC and original size } - fCrc := crc32(fCrc, PChar(StartCRC), (zStream.next_out - startCRC)); - startCRC := zStream.next_out; - - fileCRC := gz_getLong; - fileSize := gz_getLong; - if aCheckCRC and (fCrc <> fileCRC) then - {$IFDEF USE_EXCEPTIONS} - ZDecompressCheck(Z_CRC_ERROR) - {$ELSE} - Result := Z_CRC_ERROR - {$ENDIF} - else if aCheckCRC and (Cardinal(zStream.total_out) <> fileSize) then - {$IFDEF USE_EXCEPTIONS} - ZDecompressCheck(Z_SIZE_ERROR) - {$ELSE} - Result := Z_SIZE_ERROR - {$ENDIF} - else begin - if (zStream.avail_in > 0) then - inStream.Seek(-zStream.avail_in, spCurrent); - fEOF := True; - end; - end; - if (Result <> Z_OK) or (fEOF) then - break; - end; // while zStream.avail_out<>0 - // end of gzread() - - {$IFDEF USE_EXCEPTIONS} - DecompressCheck(Result); - {$ELSE} - if (Result < 0) then - Exit; - {$ENDIF} - fCrc := crc32(fCrc, PChar(oBuffer), (zStream.next_out - startCRC)); - rSize := gzBufferSize - zStream.avail_out; - - {$IFDEF USE_EXCEPTIONS} - if (rSize < 0) then - ZDecompressCheck(rSize); - {$ELSE} - if (rSize <= 0) then - break; - {$ENDIF} - - wSize := outStream.Write(oBuffer^, rSize); - {$IFDEF USE_EXCEPTIONS} - if (rSize <> wSize) then - ZDecompressCheck(Z_WRITE_ERROR); - {$ELSE} - if (rSize <> wSize) then begin - Result := Z_WRITE_ERROR; - Exit; - end; - {$ENDIF} - end; - if (Result = Z_STREAM_END) then - Result := Z_OK; - finally - inflateEnd(zStream); - if Assigned(iBuffer) then - FreeMem(iBuffer); - if Assigned(oBuffer) then - FreeMem(oBuffer); - end; -end; - -function gZipDecompressStream(inStream, outStream: PStream; var gzHdr: TgzipHeader): Integer; -begin - Result := gZipDecompressStreamHeader(inStream, gzHdr); - if (Result >= Z_OK) then - Result := gZipDecompressStreamBody(inStream, outStream); -end; - -function gZipDecompressString(const S: String; const useheaders: Boolean = True; const aCheckCRC: Boolean = True): String; -var - Rslt: Integer; - gzHdr: TgzipHeader; - inStream: PStream; - outStream: PStream; -begin - Result := ''; - inStream := NewExMemoryStream(@S[1], Length(S)); - // unpack head - if useheaders then - Rslt := gZipDecompressStreamHeader(inStream, gzHdr) - else - Rslt := Z_OK; - // unpack body - if (Rslt >= Z_OK) then begin - outStream := NewMemoryStream; - Rslt := gZipDecompressStreamBody(inStream, outStream, aCheckCRC); - if not useheaders or (Rslt >= Z_OK) then begin - outStream.Position := 0; - Result := outStream.ReadStrLen(outStream.Size); - end; - outStream.Free; - end; - inStream.Free; -end; - -{****************************************************************************} -{** BZip implementation *****************************************************} -{****************************************************************************} -{$IFDEF USE_EXCEPTIONS} - -function CCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise Exception.CreateFMT(e_Convert, 'Compression Error %d - %s', [code, BZ_Error_Msg[-code]]); -end; - -function DCheck(code: Integer): Integer; -begin - Result := code; - if code < 0 then - raise Exception.CreateFMT(e_Convert, 'Decompression Error %d - %s', [code, BZ_Error_Msg[-code]]); -end; -{$ENDIF} - -function BZCompressBuf(const InBuf: Pointer; InBytes: Integer; out OutBuf: Pointer; out OutBytes: Integer): Integer; -var - strm : TBZStreamRec; - P : Pointer; -begin - FillChar(strm, sizeof(strm), 0); - strm.bzalloc := bzip2AllocMem; - strm.bzfree := bzip2FreeMem; - OutBytes := ((InBytes + (InBytes div 10) + 12) + 255) and not 255; - GetMem(OutBuf, OutBytes); - Result := BZ_OK; - try - strm.next_in := InBuf; - strm.avail_in := InBytes; - strm.next_out := OutBuf; - strm.avail_out := OutBytes; -{$IFDEF USE_EXCEPTIONS} - CCheck(BZ2_bzCompressInit(strm, 9, 0, 0)); -{$ELSE} - Result := BZ2_bzCompressInit(strm, 9, 0, 0); - if Result < 0 then Exit; -{$ENDIF} - try -{$IFDEF USE_EXCEPTIONS} - Result := CCheck(BZ2_bzCompress(strm, BZ_FINISH)); -{$ELSE} - Result := BZ2_bzCompress(strm, BZ_FINISH); - if Result < 0 then Exit; -{$ENDIF} - while Result <> BZ_STREAM_END 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; -{$IFDEF USE_EXCEPTIONS} - Result := CCheck(BZ2_bzCompress(strm, BZ_FINISH)); -{$ELSE} - Result := BZ2_bzCompress(strm, BZ_FINISH); - if Result < 0 then Exit; -{$ENDIF} - end; - finally -{$IFDEF USE_EXCEPTIONS} - CCheck(BZ2_bzCompressEnd(strm)); -{$ELSE} - BZ2_bzCompressEnd(strm); -{$ENDIF} - end; - ReallocMem(OutBuf, strm.total_out_lo32); - OutBytes := strm.total_out_lo32; -{$IFDEF USE_EXCEPTIONS} - except - FreeMem(outBuf); - raise; -{$ELSE} - finally - if Result < 0 then FreeMem(outBuf); -{$ENDIF} - end; -end; - -function BZDecompressBuf(const InBuf: Pointer; InBytes: Integer; OutEstimate: Integer; out OutBuf: Pointer; out OutBytes: Integer): Integer; -var - strm : TBZStreamRec; - P : Pointer; - BufInc : Integer; -begin - FillChar(strm, sizeof(strm), 0); - strm.bzalloc := bzip2AllocMem; - strm.bzfree := bzip2FreeMem; - BufInc := (InBytes + 255) and not 255; -{$IFDEF USE_EXCEPTIONS} - Result := BZ_OK; -{$ENDIF} - 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; -{$IFDEF USE_EXCEPTIONS} - DCheck(BZ2_bzDecompressInit(strm, 0, 0)); -{$ELSE} - Result := BZ2_bzDecompressInit(strm, 0, 0); - if Result < 0 then Exit; -{$ENDIF} - try -{$IFDEF USE_EXCEPTIONS} - Result := DCheck(BZ2_bzDecompress(strm)); -{$ELSE} - Result := BZ2_bzDecompress(strm); - if Result < 0 then Exit; -{$ENDIF} - while Result <> BZ_STREAM_END 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; -{$IFDEF USE_EXCEPTIONS} - Result := DCheck(BZ2_bzDecompress(strm)); -{$ELSE} - Result := BZ2_bzDecompress(strm); - if Result < 0 then Exit; -{$ENDIF} - end; - finally -{$IFDEF USE_EXCEPTIONS} - DCheck(BZ2_bzDecompressEnd(strm)); -{$ELSE} - BZ2_bzDecompressEnd(strm); -{$ENDIF} - end; - ReallocMem(OutBuf, strm.total_out_lo32); - OutBytes := strm.total_out_lo32; - except - FreeMem(OutBuf); - raise - end; -end; - -function BZCompressStream(inStream, outStream: PStream; BlockSize100k: TBlockSize100k = 5): Integer; -var - FBZRec : TBZStreamRec; - iBuffer, - oBuffer : PChar; - wSize, - rSize : Integer; -begin - Result := BZ_MEM_ERROR; - iBuffer := nil; - oBuffer := nil; - FillChar(FBZRec, SizeOf(FBZRec), 0); - // FBZRec.bzalloc := bzip2AllocMem; - // FBZRec.bzfree := bzip2FreeMem; - try - GetMem(iBuffer, bzBufferSize); - GetMem(oBuffer, bzBufferSize); -{$IFDEF USE_EXCEPTIONS} - CCheck(BZ2_bzCompressInit(FBZRec, BlockSize100k, 0, 0)); -{$ELSE} - Result := BZ2_bzCompressInit(FBZRec, BlockSize100k, 0, 0); - if Result < 0 then Exit; -{$ENDIF} - FBZRec.next_out := PChar(oBuffer); - FBZRec.avail_out := bzBufferSize; - rSize := inStream.Read(iBuffer^, bzBufferSize); - repeat - //DoProgressEvent; - FBZRec.next_in := PChar(iBuffer); - FBZRec.avail_in := rSize; - while (FBZRec.avail_in > 0) do begin - if (FBZRec.avail_out = 0) then begin - wSize := outStream.Write(oBuffer^, bzBufferSize); - if (wSize <> bzBufferSize) then begin -{$IFDEF USE_EXCEPTIONS} - CCheck(BZ_IO_ERROR); -{$ELSE} - Result := BZ_IO_ERROR; - Exit; -{$ENDIF} - end; - FBZRec.next_out := PChar(oBuffer); - FBZRec.avail_out := bzBufferSize; - end; -{$IFDEF USE_EXCEPTIONS} - CCheck(BZ2_bzCompress(FBZRec, BZ_RUN)); -{$ELSE} - Result := BZ2_bzCompress(FBZRec, BZ_RUN); - if Result < 0 then Exit; -{$ENDIF} - end; // while - rSize := inStream.Read(iBuffer^, bzBufferSize); - until rSize = 0; - { flush buffers } - FBZRec.avail_in := 0; { should be zero already anyway } - repeat -{$IFDEF USE_EXCEPTIONS} - Result := CCheck(BZ2_bzCompress(FBZRec, BZ_FINISH)); -{$ELSE} - Result := BZ2_bzCompress(FBZRec, BZ_FINISH); - if Result < 0 then Break; -{$ENDIF} - rSize := bzBufferSize - FBZRec.avail_out; - wSize := outStream.Write(oBuffer^, rSize); -{$IFDEF USE_EXCEPTIONS} - if (wSize <> rSize) then CCheck(BZ_IO_ERROR); -{$ELSE} - if (wSize <> rSize) then begin - Result := BZ_IO_ERROR; - break; - end; -{$ENDIF} - FBZRec.next_out := PChar(oBuffer); - FBZRec.avail_out := bzBufferSize; - until Result = BZ_STREAM_END; - finally - if Result = BZ_STREAM_END then Result := BZ_OK; - BZ2_bzCompressEnd(FBZRec); - if Assigned(iBuffer) then FreeMem(iBuffer); - if Assigned(oBuffer) then FreeMem(oBuffer); - end; - -end; - -function BZDecompressStream(inStream, outStream: PStream): Integer; -var - FBZRec : TBZStreamRec; - iBuffer, - oBuffer : PChar; - wSize, - rSize : Integer; -begin - Result := BZ_MEM_ERROR; - iBuffer := nil; - oBuffer := nil; - FillChar(FBZRec, SizeOf(FBZRec), 0); - try - GetMem(iBuffer, bzBufferSize); - GetMem(oBuffer, bzBufferSize); -{$IFDEF USE_EXCEPTIONS} - DCheck(BZ2_bzDecompressInit(FBZRec, 0, 0)); -{$ELSE} - Result := BZ2_bzDecompressInit(FBZRec, 0, 0); - if Result < 0 then Exit; -{$ENDIF} - rSize := inStream.Read(iBuffer^, bzBufferSize); - FBZRec.next_in := PChar(iBuffer); - FBZRec.avail_in := rSize; - repeat - FBZRec.next_out := PChar(oBuffer); - FBZRec.avail_out := bzBufferSize; - Result := 0; - while (FBZRec.avail_out > 0) and (Result <> BZ_STREAM_END) do begin -{$IFDEF USE_EXCEPTIONS} - Result := CCheck(BZ2_bzDecompress(FBZRec)); -{$ELSE} - Result := BZ2_bzDecompress(FBZRec); - if Result < 0 then Break; -{$ENDIF} - if FBZRec.avail_in = 0 then begin - rSize := inStream.Read(iBuffer^, bzBufferSize); - FBZRec.next_in := PChar(iBuffer); - FBZRec.avail_in := rSize; - end; - end; - FBZRec.avail_out := bzBufferSize - FBZRec.avail_out; - wSize := outStream.Write(oBuffer^, FBZRec.avail_out); -{$IFDEF USE_EXCEPTIONS} - if FBZRec.avail_out <> wSize then CCheck(BZ_IO_ERROR); -{$ELSE} - if FBZRec.avail_out <> wSize then Result := BZ_IO_ERROR; -{$ENDIF} - until (rSize = 0) or (Result < 0); - finally - if Result = BZ_STREAM_END then Result := BZ_OK; - BZ2_bzDecompressEnd(FBZRec); - if Assigned(iBuffer) then FreeMem(iBuffer); - if Assigned(oBuffer) then FreeMem(oBuffer); - end; -end; - -end. diff --git a/Addons/Objects.pas b/Addons/Objects.pas deleted file mode 100644 index f0f8a40..0000000 --- a/Addons/Objects.pas +++ /dev/null @@ -1,260 +0,0 @@ -unit objects; - -interface - -uses - KOL, Windows, Messages; - -type - TWndMethod = procedure(var Message: TMessage) of object; - -function MakeObjectInstance(Method: TWndMethod): Pointer; -procedure FreeObjectInstance(ObjectInstance: Pointer); -function AllocateHWnd(Method: TWndMethod): HWND; -procedure DeallocateHWnd(Wnd: HWND); -function IncColor(C: TColor; D: integer): TColor; -procedure AjustBitmap(const M: KOL.PBitmap; S, C: TColor); - -implementation - -type - PObjectInstance = ^TObjectInstance; - TObjectInstance = packed record - Code: Byte; - Offset: Integer; - case Integer of - 0: (Next: PObjectInstance); - 1: (Method: TWndMethod); - end; - -type - PInstanceBlock = ^TInstanceBlock; - TInstanceBlock = packed record - Next: PInstanceBlock; - Code: array[1..2] of Byte; - WndProcPtr: Pointer; - Instances: array[0..100] of TObjectInstance; - end; - -var - InstBlockList: PInstanceBlock; - InstBlockCount: integer; - InstFreeList: PObjectInstance; - -{ Standard window procedure } -{ In ECX = Address of method pointer } -{ Out EAX = Result } - -function StdWndProc(Window: HWND; Message, WParam: Longint; - LParam: Longint): Longint; stdcall; assembler; -asm - XOR EAX,EAX - PUSH EAX - PUSH LParam - PUSH WParam - PUSH Message - MOV EDX,ESP - MOV EAX,[ECX].Longint[4] - CALL [ECX].Pointer - ADD ESP,12 - POP EAX -end; - -{ Allocate an object instance } - -function CalcJmpOffset(Src, Dest: Pointer): Longint; -begin - Result := Longint(Dest) - (Longint(Src) + 5); -end; - -function MakeObjectInstance(Method: TWndMethod): Pointer; -const - BlockCode: array[1..2] of Byte = ( - $59, { POP ECX } - $E9); { JMP StdWndProc } - PageSize = 4096; -var - Block: PInstanceBlock; - Instance: PObjectInstance; -begin - if InstFreeList = nil then - begin - Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE); - Block^.Next := InstBlockList; - Move(BlockCode, Block^.Code, SizeOf(BlockCode)); - Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc)); - Instance := @Block^.Instances; - repeat - Instance^.Code := $E8; { CALL NEAR PTR Offset } - Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code); - Instance^.Next := InstFreeList; - InstFreeList := Instance; - Inc(Longint(Instance), SizeOf(TObjectInstance)); - until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock); - InstBlockList := Block; - end; - Result := InstFreeList; - Instance := InstFreeList; - InstFreeList := Instance^.Next; - Instance^.Method := Method; - inc(InstBlockCount); -end; - -{ Free an object instance } - -procedure FreeObjectInstance(ObjectInstance: Pointer); -begin - if (ObjectInstance <> nil) and (InstBlockCount > 0) then - begin - PObjectInstance(ObjectInstance)^.Next := InstFreeList; - InstFreeList := ObjectInstance; - Dec(InstBlockCount); - if InstBlockCount = 0 then begin - VirtualFree(InstBlockList, 0, MEM_RELEASE); - InstBlockList := nil; -// ObjectInstance := nil; - end; - end; -end; - -var - UtilWindowClass: TWndClass = ( - style: 0; - lpfnWndProc: @DefWindowProc; - cbClsExtra: 0; - cbWndExtra: 0; - hInstance: 0; - hIcon: 0; - hCursor: 0; - hbrBackground: 0; - lpszMenuName: nil; - lpszClassName: 'KOLFakeUtilWindow'); - -function AllocateHWnd(Method: TWndMethod): HWND; -var - TempClass: TWndClass; - ClassRegistered: Boolean; -begin - UtilWindowClass.hInstance := HInstance; - ClassRegistered := GetClassInfo(HInstance, UtilWindowClass.lpszClassName, - TempClass); - if not ClassRegistered or (TempClass.lpfnWndProc <> @DefWindowProc) then - begin - if ClassRegistered then - Windows.UnregisterClass(UtilWindowClass.lpszClassName, HInstance); - Windows.RegisterClass(UtilWindowClass); - end; - Result := CreateWindowEx(WS_EX_TOOLWINDOW, UtilWindowClass.lpszClassName, - '', WS_POPUP {!0}, 0, 0, 0, 0, 0, 0, HInstance, nil); - if Assigned(Method) then - SetWindowLong(Result, GWL_WNDPROC, Longint(MakeObjectInstance(Method))); -end; - -procedure DeallocateHWnd(Wnd: HWND); -var - Instance: Pointer; -begin - Instance := Pointer(GetWindowLong(Wnd, GWL_WNDPROC)); - DestroyWindow(Wnd); - if Instance <> @DefWindowProc then FreeObjectInstance(Instance); -end; - -procedure SplitColor(C: TColor; var r, g, b: integer); -begin - b := (c and $FF0000) shr 16; - g := (c and $00FF00) shr 08; - r := (c and $0000FF) shr 00; -end; - -procedure AjustBitmap; -var i, j: integer; - t: KOL.PBitmap; - r, - g, - b, - r2, - g2, - b2: integer; - p: PRGBTriple; - - function CalcColor(c1, c2, c3: integer): integer; - begin - if c1 = c3 then begin - Result := c2; - exit; - end; - - if c1 = 0 then begin - Result := 0; - exit; - end; - -{ Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3); - exit;} - - Result := c1 * c2 div c3; - if c2 = 0 then Result := c1 * 150 div 255; - if Result > 255 then Result := 255; - if Result < 50 then Result := Result + 50; -{ exit; - a := trunc(x1 * 3); - a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3); - a := 255 * 255 - 4 * a; - try - x1 := Trunc((255 - sqrt(a)) / 2); - x2 := Trunc((255 + sqrt(a)) / 2); - if x1 > x2 then Result := Trunc(x1) - else Result := Trunc(x2); - except - Result := 0; - end;} - end; - -begin - if s = c then exit; - if m.Width = 0 then exit; - if m.Height = 0 then exit; - t := NewBitmap(m.Width, m.Height); - m.PixelFormat := pf24bit; - t.Assign(m); - SplitColor(Color2RGB(s), r, g, b); - if r = 0 then r := 1; - if g = 0 then g := 1; - if b = 0 then b := 1; - SplitColor(Color2RGB(c), r2, g2, b2); - for j := 0 to t.Height - 1 do begin - p := t.scanline[j]; - for i := 0 to t.Width - 1 do begin - p.rgbtRed := CalcColor(p.rgbtRed, r2, r); - p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g); - p.rgbtBlue := CalcColor(p.rgbtBlue, b2, b); - inc(p); - end; - end; - m.Assign(t); - t.Free; -end; - -function IncColor; -var T: TColor; - P: PRGBTriple; -begin - T := Color2RGB(C); - p := @T; - if D > 0 then begin - if p.rgbtBlue < 255 - D then p.rgbtBlue := p.rgbtBlue + D else p.rgbtBlue := 255; - if p.rgbtRed < 255 - D then p.rgbtRed := p.rgbtRed + D else p.rgbtRed := 255; - if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255; - end else begin - if p.rgbtBlue > D then p.rgbtBlue := p.rgbtBlue - D else p.rgbtBlue := 000; - if p.rgbtRed > D then p.rgbtRed := p.rgbtRed - D else p.rgbtRed := 000; - if p.rgbtGreen > D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000; - end; - Result := T; -end; - -begin - InstBlockList := nil; - InstBlockCount := 0; - InstFreeList := nil; -end. diff --git a/Addons/UBitTreeDecoder.pas b/Addons/UBitTreeDecoder.pas deleted file mode 100644 index d6f332d..0000000 --- a/Addons/UBitTreeDecoder.pas +++ /dev/null @@ -1,74 +0,0 @@ -unit UBitTreeDecoder; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL, URangeDecoder; - -type PBitTreeDecoder = ^TBitTreeDecoder; - TBitTreeDecoder=object(TObj) - public - Models: array of smallint; - NumBitLevels:integer; - constructor Create(const AnumBitLevels:integer); - procedure _Init; - function Decode(const ArangeDecoder:PRangeDecoder):integer; - function ReverseDecode(const ArangeDecoder:PRangeDecoder):integer;overload; - end; - -function ReverseDecode(var AModels: array of smallint; const AstartIndex:integer;const ArangeDecoder:PRangeDecoder; const ANumBitLevels:integer):integer;overload; - -implementation - -constructor TBitTreeDecoder.Create(const AnumBitLevels:integer); -begin -self.NumBitLevels := AnumBitLevels; -setlength(Models,1 shl AnumBitLevels); -end; - -procedure TBitTreeDecoder._Init; -begin -urangedecoder.InitBitModels(Models); -end; - -function TBitTreeDecoder.Decode(const ArangeDecoder:PRangeDecoder):integer; -var m,bitIndex:integer; -begin -m:=1; -for bitIndex := NumBitLevels downto 1 do begin - m:=m shl 1 + ArangeDecoder.DecodeBit(Models, m); - end; -result:=m - (1 shl NumBitLevels); -end; - -function TBitTreeDecoder.ReverseDecode(const ArangeDecoder:PRangeDecoder):integer; -var m,symbol,bitindex,bit:integer; -begin -m:=1; -symbol:=0; -for bitindex:=0 to numbitlevels-1 do begin - bit:=ArangeDecoder.DecodeBit(Models, m); - m:=(m shl 1) + bit; - symbol:=symbol or (bit shl bitIndex); - end; -result:=symbol; -end; - -function ReverseDecode(var AModels: array of smallint;const AstartIndex:integer; - const ArangeDecoder:PRangeDecoder;const ANumBitLevels:integer):integer; -var m,symbol,bitindex,bit:integer; -begin -m:=1; -symbol:=0; -for bitindex:=0 to ANumBitLevels -1 do begin - bit := ArangeDecoder.DecodeBit(AModels, AstartIndex + m); - m := (m shl 1) + bit; - symbol := symbol or bit shl bitindex; - end; -result:=symbol; -end; - -end. diff --git a/Addons/UBitTreeEncoder.pas b/Addons/UBitTreeEncoder.pas deleted file mode 100644 index c185595..0000000 --- a/Addons/UBitTreeEncoder.pas +++ /dev/null @@ -1,116 +0,0 @@ -unit UBitTreeEncoder; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL, URangeDecoder,URangeEncoder; - -type PBitTreeEncoder =^TBitTreeEncoder; - TBitTreeEncoder=object(TObj) - public - Models: array of smallint; - NumBitLevels:integer; - constructor Create(const AnumBitLevels:integer); - procedure _Init; - procedure Encode(const ArangeEncoder:PRangeEncoder;const Asymbol:integer); - procedure ReverseEncode(const ArangeEncoder:PRangeEncoder;Asymbol:integer); - function GetPrice(const Asymbol:integer):integer; - function ReverseGetPrice(Asymbol:integer):integer;overload; - end; - -procedure ReverseEncode(var AModels:array of smallint;const AstartIndex:integer;const ArangeEncoder:PRangeEncoder;const ANumBitLevels:integer; Asymbol:integer); -function ReverseGetPrice(var AModels:array of smallint;const AstartIndex,ANumBitLevels:integer; Asymbol:integer):integer; - -implementation - -constructor TBitTreeEncoder.Create(const AnumBitLevels:integer); -begin -self.NumBitLevels:=AnumBitLevels; -setlength(Models,1 shl AnumBitLevels); -end; - -procedure TBitTreeEncoder._Init; -begin -URangeDecoder.InitBitModels(Models); -end; - -procedure TBitTreeEncoder.Encode(const ArangeEncoder:PRangeEncoder;const Asymbol:integer); -var m,bitindex,bit:integer; -begin -m := 1; -for bitIndex := NumBitLevels -1 downto 0 do begin - bit := (Asymbol shr bitIndex) and 1; - ArangeEncoder.Encode(Models, m, bit); - m := (m shl 1) or bit; - end; -end; - -procedure TBitTreeEncoder.ReverseEncode(const ArangeEncoder:PRangeEncoder;Asymbol:integer); -var m,i,bit:integer; -begin -m:=1; -for i:= 0 to NumBitLevels -1 do begin - bit := Asymbol and 1; - ArangeEncoder.Encode(Models, m, bit); - m := (m shl 1) or bit; - Asymbol := Asymbol shr 1; - end; -end; - -function TBitTreeEncoder.GetPrice(const Asymbol:integer):integer; -var price,m,bitindex,bit:integer; -begin -price := 0; -m := 1; -for bitIndex := NumBitLevels - 1 downto 0 do begin - bit := (Asymbol shr bitIndex) and 1; - price := price + RangeEncoder.GetPrice(Models[m], bit); - m := (m shl 1) + bit; - end; -result:=price; -end; - -function TBitTreeEncoder.ReverseGetPrice(Asymbol:integer):integer; -var price,m,i,bit:integer; -begin -price := 0; -m := 1; -for i:= NumBitLevels downto 1 do begin - bit := Asymbol and 1; - Asymbol := Asymbol shr 1; - price :=price + RangeEncoder.GetPrice(Models[m], bit); - m := (m shl 1) or bit; - end; -result:=price; -end; - -function ReverseGetPrice(var AModels:array of smallint;const AstartIndex,ANumBitLevels:integer;Asymbol:integer):integer; -var price,m,i,bit:integer; -begin -price := 0; -m := 1; -for i := ANumBitLevels downto 1 do begin - bit := Asymbol and 1; - Asymbol := Asymbol shr 1; - price := price + RangeEncoder.GetPrice(AModels[AstartIndex + m], bit); - m := (m shl 1) or bit; - end; -result:=price; -end; - -procedure ReverseEncode(var AModels:array of smallint;const AstartIndex:integer;const ArangeEncoder:PRangeEncoder;const ANumBitLevels:integer;Asymbol:integer); -var m,i,bit:integer; -begin -m:=1; -for i := 0 to ANumBitLevels -1 do begin - bit := Asymbol and 1; - ArangeEncoder.Encode(AModels, AstartIndex + m, bit); - m := (m shl 1) or bit; - Asymbol := Asymbol shr 1; - end; -end; - -end. diff --git a/Addons/UBufferedFS.pas b/Addons/UBufferedFS.pas deleted file mode 100644 index 2dd3348..0000000 --- a/Addons/UBufferedFS.pas +++ /dev/null @@ -1,174 +0,0 @@ -unit UBufferedFS; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL; - -type PBufferedFS = PStream; -{ -const BufferSize=$10000;//64K - -type TBFSMode=(BFMRead,BFMWrite); - - TBufferedFS=class(TFileStream) - private - membuffer:array [0..BufferSize-1] of byte; - bytesinbuffer:integer; - bufferpos:integer; - bufferdirty:boolean; - Mode:TBFSMode; - procedure _Init; - procedure Flush; - procedure ReadBuffer; - public - constructor Create(const FileName: string; Mode: Word); overload; - constructor Create(const FileName: string; Mode: Word; Rights: Cardinal); overload; - destructor Destroy; override; - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override; - end; - -type TByteArray = array of byte; - PByteArray = ^TByteArray; -} -implementation -{ -function MovePointer(const P:pointer;const dist:integer):pointer; -begin -result:=pointer(integer(p)+dist); -end; - -procedure TBufferedFS.Init; -begin -bytesinbuffer:=0; -bufferpos:=0; -bufferdirty:=false; -mode:=BFMWrite; -end; - -procedure TBufferedFS.Flush; -begin -if bufferdirty then - inherited Write(membuffer[0],bufferpos); -bufferdirty:=false; -bytesinbuffer:=0; -bufferpos:=0; -end; - -constructor TBufferedFS.Create(const FileName: string; Mode: Word); -begin -inherited; -init; -end; - -constructor TBufferedFS.Create(const FileName: string; Mode: Word; Rights: Cardinal); -begin -inherited; -init; -end; - -destructor TBufferedFS.Destroy; -begin -flush; -inherited; -end; - -procedure TBufferedFS.ReadBuffer; -begin -flush; -bytesinbuffer:=inherited Read(membuffer,buffersize); -bufferpos:=0; -end; - -function TBufferedFS.Read(var Buffer; Count: Longint): Longint; -var p:PByteArray; - bytestoread:integer; - b:integer; -begin -if Mode=BFMWrite then flush; -mode:=BFMRead; -result:=0; -if count<=bytesinbuffer then begin - //all data already in buffer - move(membuffer[bufferpos],buffer,count); - bytesinbuffer:=bytesinbuffer-count; - bufferpos:=bufferpos+count; - result:=count; - end else begin - bytestoread:=count; - if (bytestoread<>0)and(bytesinbuffer<>0) then begin - //read data remaining in buffer and increment data pointer - b:=Read(buffer,bytesinbuffer); - p:=PByteArray(@(TByteArray(buffer)[b])); - bytestoread:=bytestoread-b; - result:=b; - end else p:=@buffer; - if bytestoread>=BufferSize then begin - //data to read is larger than the buffer, read it directly - result:=result+inherited Read(p^,bytestoread); - end else begin - //refill buffer - ReadBuffer; - //recurse - result:=result+Read(p^,math.Min(bytestoread,bytesinbuffer)); - end; - end; -end; - -function TBufferedFS.Write(const Buffer; Count: Longint): Longint; -var p:pointer; - bytestowrite:integer; - b:integer; -begin -if mode=BFMRead then begin - seek(-BufferSize+bufferpos,soFromCurrent); - bytesinbuffer:=0; - bufferpos:=0; - end; -mode:=BFMWrite; -result:=0; -if count<=BufferSize-bytesinbuffer then begin - //all data fits in buffer - bufferdirty:=true; - move(buffer,membuffer[bufferpos],count); - bytesinbuffer:=bytesinbuffer+count; - bufferpos:=bufferpos+count; - result:=count; - end else begin - bytestowrite:=count; - if (bytestowrite<>0)and(bytesinbuffer<>BufferSize)and(bytesinbuffer<>0) then begin - //write data to remaining space in buffer and increment data pointer - b:=Write(buffer,BufferSize-bytesinbuffer); - p:=MovePointer(@buffer,b); - bytestowrite:=bytestowrite-b; - result:=b; - end else p:=@buffer; - if bytestowrite>=BufferSize then begin - //empty buffer - Flush; - //data to write is larger than the buffer, write it directly - result:=result+inherited Write(p^,bytestowrite); - end else begin - //empty buffer - Flush; - //recurse - result:=result+Write(p^,bytestowrite); - end; - end; -end; - -function TBufferedFS.Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; -begin -if (Origin=soCurrent)and(Offset=0) then result:=inherited seek(Offset,origin)+bufferpos - else begin - flush; - result:=inherited Seek(offset,origin); - end; -end; -} -end. diff --git a/Addons/UDig.pas b/Addons/UDig.pas deleted file mode 100644 index 9738e7b..0000000 --- a/Addons/UDig.pas +++ /dev/null @@ -1,130 +0,0 @@ -unit UDig; - -interface - -function stri (n,n1:integer;zero,trim:boolean):string; -function strL (n: longint; n1 :integer):string; - -{function strr(n:real;n1,n2:word):string; -function strH (w : longint; c : word) : string;} -function strhl(w : longint; c : word) : string; -function hexi(s:string):word; -function hexl(s:string):longint; -function inti(s:string):word; -{function intl(s:string):longint; } - -implementation - -uses UWrd, UStr; - -function atrim(s : string) : string; -var t : string; -begin - t := s; - while (t[1] = ' ') and (length(t) > 0) do t := copy(t, 2, 255); - while (t[length(t)] = ' ') and (length(t) > 0) do t := copy(t, 1, length(t) - 1); - atrim := t; -end; - -{ -function strh; -const a:array[0..15] of cHar = - ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); -var r:string; -begin - if c>0 then r:=strh(w div 16,c-1)+a[w mod 16] - else r:=''; - strH := r; -end; -} -function strhl; -const a:array[0..15] of cHar = - ('0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'); -var r:string; -begin - if c > 0 then - if w mod 16 >= 0 tHen r := strhl(w sHr 4, c - 1) + a[ w mod 16] else - r := strHl(w sHr 4, c - 1) + a[16 + w mod 16] - else r := ''; - strHl := r; -end; - -function hexi; -const a : string[15] ='123456789ABCDEF'; - var i : integer; - h :word; -begin - h:=0; - for i:=1 to length(s) do begin - if S[i]<>' ' then begin - h:=h shl 4; - h:=h+pos(UpCase(S[i]),a); - end; - end; - hexi:=h; -end; - -function hexl; -const a : string[15] ='123456789ABCDEF'; - var i : integer; - h :longint; -begin - h:=0; - for i:=1 to length(s) do begin - if S[i]<>' ' then begin - h:=h shl 4; - h:=h+pos(UpCase(S[i]),a); - end; - end; - hexl:=h; -end; - -function inti; -var - rc : integer; - ww : longint; -begin - val(s, ww, rc); - inti := ww; -end; -{ -function intl; -var - rc : integer; - ww : integer; -begin - val(s, ww, rc); - intl := ww; -end; -} - -function stri; -var s : string; - i : integer; -begin - str(n: n1, s); - if zero THen begin - for i := 1 to lengtH(s) do - if s[i] = ' ' THen s[i] := '0'; - end; - if trim then s := atrim(s); - stri := s; -end; - -function strl; -var s:string; -begin - str(n:n1,s); - strl:=s; -end; - -{ -function strr; -var s:string; -begin - str(n:n1:n2,s); - strr:=s; -end; -} - -end. diff --git a/Addons/UFor.pas b/Addons/UFor.pas deleted file mode 100644 index 080e94f..0000000 --- a/Addons/UFor.pas +++ /dev/null @@ -1,99 +0,0 @@ -unit UFor; - -interface - -function points(d : boolean; t : string; m : integer): string; -function toreal(r : string): real; -function rtostr(r : real): string; -function plslop(o, c: string; back, buys: boolean): string; -function plslom(o, c: string; back, buys: boolean; size, amnt, intr: string): string; -function chkprc(o, c, q, b: string): boolean; - -implementation -uses SysUtils; - -function points; -var s : string; - p, - i, - e : integer; -begin - s := t; - if pos('.', s) = 0 then s := s + '.'; - while length(s) < 6 do s := s + '0'; - p := pos('.', s); - s := copy(s, 1, p - 1) + copy(s, p + 1, 6 - p); - val(s, i, e); - if d then inc(i, m) else dec(i, m); - s := inttostr(i); - while length(s) < 5 do s := '0' + s; - s := copy(s, 1, p - 1) + '.' + copy(s, p, 6 - p); - points := s; -end; - -function toreal(r: string): real; -var f : real; - i : integer; - s : string; -begin - S := R; - val(trim(S), F, I); - if (i > 0) and (I < length(S)) then begin - if S[I] = '.' then S[I] := ',' else - if S[I] = ',' then S[i] := '.'; - val(trim(S), F, I); - end; - result := F; -end; - -function rtostr; -var s : string; -begin - str(r:5:2, s); - rtostr := s; -end; - -function plslop; -var op, - cl : real; - j : integer; -begin - op := toreal(o); - cl := toreal(c); - repeat - op := op * 10; - cl := cl * 10; - until op > 3000; - j := round(cl - op); - if back xor buys then j := -j; - plslop := inttostr(j); -end; - -function plslom; -var op, cl: real; - dd: real; -begin - plslom := '0'; - op := toreal(o); - cl := toreal(c); - if (op = 0) or (cl = 0) then exit; - if back then dd := cl - op - else dd := 1/op - 1/cl; - dd := dd * toreal(size); - if back xor buys then dd := -dd; - dd := dd * strtoint(amnt) - toreal(intr); - plslom := rtostr(dd); -end; - -function chkprc; -var op, cl: real; - bk, sb: boolean; -begin - op := toreal(o); - cl := toreal(c); - bk := (q = 'EUR') or (q = 'GBP'); - sb := (b = 'Buy'); - chkprc := (op >= cl) xor (bk xor sb); -end; - -end. \ No newline at end of file diff --git a/Addons/ULZBinTree.pas b/Addons/ULZBinTree.pas deleted file mode 100644 index b5c9233..0000000 --- a/Addons/ULZBinTree.pas +++ /dev/null @@ -1,420 +0,0 @@ -unit ULZBinTree; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses ULZInWindow, KOL; - -type - TArrayOfInteger = array [0..0] of Integer; - PArrayOfInteger = ^TArrayOfInteger; - -type PLZBinTree = ^TLZBinTree; - TLZBinTree = object(TLZInWindow) - public - cyclicBufferPos:integer; - cyclicBufferSize:integer; - matchMaxLen:integer; - - son: PArrayOfInteger;//array of integer; - hash: array of integer; - - cutValue:integer; - hashMask:integer; - hashSizeSum:integer; - - HASH_ARRAY:boolean; - - - kNumHashDirectBytes:integer; - kMinMatchCheck:integer; - kFixHashSize:integer; - constructor Create; - procedure SetType(const AnumHashBytes:integer); - procedure _Init;virtual; - procedure MovePos;virtual; - function _Create(const AhistorySize,AkeepAddBufferBefore,AmatchMaxLen,AkeepAddBufferAfter:integer):boolean; - function GetMatches(var Adistances:array of integer):integer; - procedure Skip(Anum:integer); - procedure NormalizeLinks(var Aitems:array of integer;const AnumItems,AsubValue:integer); - procedure Normalize; - procedure SetCutValue(const AcutValue:integer); - end; - -implementation - -const kHash2Size = 1 shl 10; - kHash3Size = 1 shl 16; - kBT2HashSize = 1 shl 16; - kStartMaxLen = 1; - kHash3Offset = kHash2Size; - kEmptyHashValue = 0; - kMaxValForNormalize = (1 shl 30) - 1; - -var CRCTable: array [0..255] of integer; - -constructor TLZBinTree.Create; -begin -inherited Create; -cyclicBufferSize:=0; -cutValue:=$FF; -hashSizeSum:=0; -HASH_ARRAY:=true; -kNumHashDirectBytes:=0; -kMinMatchCheck:=4; -kFixHashsize:=kHash2Size + kHash3Size; -end; - -procedure TLZBinTree.SetType(const AnumHashBytes:integer); -begin -HASH_ARRAY := (AnumHashBytes > 2); -if HASH_ARRAY then begin - kNumHashDirectBytes := 0; - kMinMatchCheck := 4; - kFixHashSize := kHash2Size + kHash3Size; - end - else begin - kNumHashDirectBytes := 2; - kMinMatchCheck := 2 + 1; - kFixHashSize := 0; - end; -end; - -procedure TLZBinTree._Init; -var i:integer; -begin -inherited _init; -for i := 0 to hashSizeSum - 1 do - hash[i] := kEmptyHashValue; -cyclicBufferPos := 0; -ReduceOffsets(-1); -end; - -procedure TLZBinTree.MovePos; -begin -inc(cyclicBufferPos); -if cyclicBufferPos >= cyclicBufferSize then - cyclicBufferPos := 0; -inherited MovePos; -if pos = kMaxValForNormalize then - Normalize; -end; - -function TLZBinTree._Create(const AhistorySize,AkeepAddBufferBefore,AmatchMaxLen,AkeepAddBufferAfter:integer):boolean; -var windowReservSize:integer; - _cyclicBufferSize:integer; - hs:integer; -begin -if (AhistorySize > kMaxValForNormalize - 256) then begin - result:=false; - exit; - end; -cutValue := 16 + (AmatchMaxLen shr 1); - -windowReservSize := (AhistorySize + AkeepAddBufferBefore + AmatchMaxLen + AkeepAddBufferAfter) div 2 + 256; - -inherited _Create(AhistorySize + AkeepAddBufferBefore, AmatchMaxLen + AkeepAddBufferAfter, windowReservSize); - -self.matchMaxLen := AmatchMaxLen; - -_cyclicBufferSize := AhistorySize + 1; -if self.cyclicBufferSize <> _cyclicBufferSize then begin - self.cyclicBufferSize:=_cyclicBufferSize; - son:= AllocMem(_cyclicBufferSize * 2); -// GetMem(son,_cyclicBufferSize * 2); -// setlength(son,_cyclicBufferSize * 2); - end; - -hs := kBT2HashSize; - -if HASH_ARRAY then begin - hs := AhistorySize - 1; - hs := hs or (hs shr 1); - hs := hs or (hs shr 2); - hs := hs or (hs shr 4); - hs := hs or (hs shr 8); - hs := hs shr 1; - hs := hs or $FFFF; - if (hs > (1 shl 24)) then - hs := hs shr 1; - hashMask := hs; - inc(hs); - hs := hs + kFixHashSize; - end; -if (hs <> hashSizeSum) then begin - hashSizeSum := hs; - setlength(hash,hashSizeSum); - end; -result:=true; -end; - -function TLZBinTree.GetMatches(var Adistances:array of integer):integer; -var lenLimit:integer; - offset,matchMinPos,cur,maxlen,hashvalue,hash2value,hash3value:integer; - temp,curmatch,curmatch2,curmatch3,ptr0,ptr1,len0,len1,count:integer; - delta,cyclicpos,pby1,len:integer; -begin -if pos + matchMaxLen <= streamPos then - lenLimit := matchMaxLen - else begin - lenLimit := streamPos - pos; - if lenLimit < kMinMatchCheck then begin - MovePos(); - result:=0; - exit; - end; - end; - -offset := 0; -if (pos > cyclicBufferSize) then - matchMinPos:=(pos - cyclicBufferSize) - else matchMinPos:=0; -cur := bufferOffset + pos; -maxLen := kStartMaxLen; // to avoid items for len < hashSize; -hash2Value := 0; -hash3Value := 0; - -if HASH_ARRAY then begin - temp := CrcTable[bufferBase[cur] and $FF] xor (bufferBase[cur + 1] and $FF); - hash2Value := temp and (kHash2Size - 1); - temp := temp xor ((bufferBase[cur + 2] and $FF) shl 8); - hash3Value := temp and (kHash3Size - 1); - hashValue := (temp xor (CrcTable[bufferBase[cur + 3] and $FF] shl 5)) and hashMask; - end else - hashValue := ((bufferBase[cur] and $FF) xor ((bufferBase[cur + 1] and $FF) shl 8)); - -curMatch := hash[kFixHashSize + hashValue]; -if HASH_ARRAY then begin - curMatch2 := hash[hash2Value]; - curMatch3 := hash[kHash3Offset + hash3Value]; - hash[hash2Value] := pos; - hash[kHash3Offset + hash3Value] := pos; - if curMatch2 > matchMinPos then - if bufferBase[bufferOffset + curMatch2] = bufferBase[cur] then begin - maxLen := 2; - Adistances[offset] := maxLen; - inc(offset); - Adistances[offset] := pos - curMatch2 - 1; - inc(offset); - end; - if curMatch3 > matchMinPos then - if bufferBase[bufferOffset + curMatch3] = bufferBase[cur] then begin - if curMatch3 = curMatch2 then - offset := offset - 2; - maxLen := 3; - Adistances[offset] := maxlen; - inc(offset); - Adistances[offset] := pos - curMatch3 - 1; - inc(offset); - curMatch2 := curMatch3; - end; - if (offset <> 0) and (curMatch2 = curMatch) then begin - offset := offset - 2; - maxLen := kStartMaxLen; - end; - end; - -hash[kFixHashSize + hashValue] := pos; - -ptr0 := (cyclicBufferPos shl 1) + 1; -ptr1 := (cyclicBufferPos shl 1); - -len0 := kNumHashDirectBytes; -len1 := len0; - -if kNumHashDirectBytes <> 0 then begin - if (curMatch > matchMinPos) then begin - if (bufferBase[bufferOffset + curMatch + kNumHashDirectBytes] <> bufferBase[cur + kNumHashDirectBytes]) then begin - maxLen := kNumHashDirectBytes; - Adistances[offset] := maxLen; - inc(offset); - Adistances[offset] := pos - curMatch - 1; - inc(offset); - end; - end; - end; - -count := cutValue; - -while (true) do begin - if (curMatch <= matchMinPos) or (count = 0) then begin - son[ptr1] := kEmptyHashValue; - son[ptr0] := son[ptr1]; - break; - end; - dec(count); - delta := pos - curMatch; - if delta<=cyclicBufferPos then - cyclicpos:=(cyclicBufferPos - delta) shl 1 - else cyclicpos:=(cyclicBufferPos - delta + cyclicBufferSize) shl 1; - - pby1 := bufferOffset + curMatch; - len := min(len0, len1); - if bufferBase[pby1 + len] = bufferBase[cur + len] then begin - inc(len); - while (len <> lenLimit) do begin - if (bufferBase[pby1 + len] <> bufferBase[cur + len]) then - break; - inc(len); - end; - if maxLen < len then begin - maxLen := len; - Adistances[offset] := maxlen; - inc(offset); - Adistances[offset] := delta - 1; - inc(offset); - if (len = lenLimit) then begin - son[ptr1] := son[cyclicPos]; - son[ptr0] := son[cyclicPos + 1]; - break; - end; - end; - end; - if (bufferBase[pby1 + len] and $FF) < (bufferBase[cur + len] and $FF) then begin - son[ptr1] := curMatch; - ptr1 := cyclicPos + 1; - curMatch := son[ptr1]; - len1 := len; - end else begin - son[ptr0] := curMatch; - ptr0 := cyclicPos; - curMatch := son[ptr0]; - len0 := len; - end; - end; -MovePos; -result:=offset; -end; - -procedure TLZBinTree.Skip(Anum:integer); -var lenLimit,matchminpos,cur,hashvalue,temp,hash2value,hash3value,curMatch:integer; - ptr0,ptr1,len,len0,len1,count,delta,cyclicpos,pby1:integer; -begin -repeat - if pos + matchMaxLen <= streamPos then - lenLimit := matchMaxLen - else begin - lenLimit := streamPos - pos; - if lenLimit < kMinMatchCheck then begin - MovePos(); - dec(Anum); - continue; - end; - end; - - if pos>cyclicBufferSize then - matchminpos:=(pos - cyclicBufferSize) - else matchminpos:=0; - cur := bufferOffset + pos; - - if HASH_ARRAY then begin - temp := CrcTable[bufferBase[cur] and $FF] xor (bufferBase[cur + 1] and $FF); - hash2Value := temp and (kHash2Size - 1); - hash[hash2Value] := pos; - temp := temp xor ((bufferBase[cur + 2] and $FF) shl 8); - hash3Value := temp and (kHash3Size - 1); - hash[kHash3Offset + hash3Value] := pos; - hashValue := (temp xor (CrcTable[bufferBase[cur + 3] and $FF] shl 5)) and hashMask; - end else - hashValue := ((bufferBase[cur] and $FF) xor ((bufferBase[cur + 1] and $FF) shl 8)); - - curMatch := hash[kFixHashSize + hashValue]; - hash[kFixHashSize + hashValue] := pos; - - ptr0 := (cyclicBufferPos shl 1) + 1; - ptr1 := (cyclicBufferPos shl 1); - - len0 := kNumHashDirectBytes; - len1 := kNumHashDirectBytes; - - count := cutValue; - while true do begin - if (curMatch <= matchMinPos) or (count = 0) then begin - son[ptr1] := kEmptyHashValue; - son[ptr0] := son[ptr1]; - break; - end else dec(count); - - delta := pos - curMatch; - if (delta <= cyclicBufferPos) then - cyclicpos:=(cyclicBufferPos - delta) shl 1 - else cyclicpos:=(cyclicBufferPos - delta + cyclicBufferSize) shl 1; - - pby1 := bufferOffset + curMatch; - len := min(len0, len1); - if bufferBase[pby1 + len] = bufferBase[cur + len] then begin - inc(len); - while (len <> lenLimit) do begin - if bufferBase[pby1 + len] <> bufferBase[cur + len] then - break; - inc(len); - end; - if len = lenLimit then begin - son[ptr1] := son[cyclicPos]; - son[ptr0] := son[cyclicPos + 1]; - break; - end; - end; - if ((bufferBase[pby1 + len] and $FF) < (bufferBase[cur + len] and $FF)) then begin - son[ptr1] := curMatch; - ptr1 := cyclicPos + 1; - curMatch := son[ptr1]; - len1 := len; - end else begin - son[ptr0] := curMatch; - ptr0 := cyclicPos; - curMatch := son[ptr0]; - len0 := len; - end; - end; - MovePos; - dec(Anum); - until Anum=0; -end; - -procedure TLZBinTree.NormalizeLinks(var Aitems:array of integer;const AnumItems,AsubValue:integer); -var i,value:integer; -begin -for i:=0 to AnumItems-1 do begin - value := Aitems[i]; - if value <= AsubValue then - value := kEmptyHashValue - else value := value - AsubValue; - Aitems[i] := value; - end; -end; - -procedure TLZBinTree.Normalize; -var subvalue:integer; -begin -subValue := pos - cyclicBufferSize; -NormalizeLinks(son^, cyclicBufferSize * 2, subValue); -NormalizeLinks(hash, hashSizeSum, subValue); -ReduceOffsets(subValue); -end; - -procedure TLZBinTree.SetCutValue(const Acutvalue:integer); -begin -self.cutValue:=Acutvalue; -end; - -procedure InitCRC; -var i,r,j:integer; -begin -for i := 0 to 255 do begin - r := i; - for j := 0 to 7 do - if ((r and 1) <> 0) then - r := (r shr 1) xor integer($EDB88320) - else - r := r shr 1; - CrcTable[i] := r; - end; -end; - -initialization -InitCRC; -end. diff --git a/Addons/ULZInWindow.pas b/Addons/ULZInWindow.pas deleted file mode 100644 index 9a9f46d..0000000 --- a/Addons/ULZInWindow.pas +++ /dev/null @@ -1,170 +0,0 @@ -unit ULZInWindow; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL; - -type TLZInWindow= object(TObj) - public - bufferBase: array of byte;// pointer to buffer with data - stream:PStream; - posLimit:integer; // offset (from _buffer) of first byte when new block reading must be done - streamEndWasReached:boolean; // if (true) then _streamPos shows real end of stream - - pointerToLastSafePosition:integer; - - bufferOffset:integer; - - blockSize:integer; // Size of Allocated memory block - pos:integer; // offset (from _buffer) of curent byte - keepSizeBefore:integer; // how many BYTEs must be kept in buffer before _pos - keepSizeAfter:integer; // how many BYTEs must be kept buffer after _pos - streamPos:integer; // offset (from _buffer) of first not read byte from Stream - - procedure MoveBlock; - procedure ReadBlock; - procedure _Free; - procedure _Create(const AkeepSizeBefore, AkeepSizeAfter, AkeepSizeReserv:integer); - procedure SetStream(const Astream:PStream); - procedure ReleaseStream; - procedure _Init;virtual; - procedure MovePos;virtual; - function GetIndexByte(const Aindex:integer):byte; - // index + limit have not to exceed _keepSizeAfter; - function GetMatchLen(const Aindex:integer;Adistance,Alimit:integer):integer; - function GetNumAvailableBytes:integer; - procedure ReduceOffsets(const AsubValue:integer); - end; - -implementation - -procedure TLZInWindow.MoveBlock; -var offset,numbytes,i:integer; -begin -offset := bufferOffset + pos - keepSizeBefore; -// we need one additional byte, since MovePos moves on 1 byte. -if (offset > 0) then - dec(offset); - -numBytes := bufferOffset + streamPos - offset; - -// check negative offset ???? -for i := 0 to numBytes -1 do - bufferBase[i] := bufferBase[offset + i]; -bufferOffset := bufferOffset - offset; -end; - -procedure TLZInWindow.ReadBlock; -var size,numreadbytes,pointerToPostion:integer; -begin -if streamEndWasReached then - exit; -while (true) do begin - size := (0 - bufferOffset) + blockSize - streamPos; - if size = 0 then - exit; - numReadBytes := stream.Read(bufferBase[bufferOffset + streamPos], size); - if (numReadBytes = 0) then begin - posLimit := streamPos; - pointerToPostion := bufferOffset + posLimit; - if (pointerToPostion > pointerToLastSafePosition) then - posLimit := pointerToLastSafePosition - bufferOffset; - streamEndWasReached := true; - exit; - end; - streamPos := streamPos + numReadBytes; - if (streamPos >= pos + keepSizeAfter) then - posLimit := streamPos - keepSizeAfter; - end; -end; - -procedure TLZInWindow._Free; -begin -setlength(bufferBase,0); -end; - -procedure TLZInWindow._Create(const AkeepSizeBefore, AkeepSizeAfter, AkeepSizeReserv:integer); -var _blocksize:integer; -begin -self.keepSizeBefore := AkeepSizeBefore; -self.keepSizeAfter := AkeepSizeAfter; -_blocksize := AkeepSizeBefore + AkeepSizeAfter + AkeepSizeReserv; -if (length(bufferBase) = 0) or (self.blockSize <> _blocksize) then begin - _Free; - self.blockSize := _blocksize; - setlength(bufferBase,self.blockSize); - end; -pointerToLastSafePosition := self.blockSize - AkeepSizeAfter; -end; - -procedure TLZInWindow.SetStream(const Astream:PStream); -begin -self.stream:=Astream; -end; - -procedure TLZInWindow.ReleaseStream; -begin -stream:=nil; -end; - -procedure TLZInWindow._Init; -begin -bufferOffset := 0; -pos := 0; -streamPos := 0; -streamEndWasReached := false; -ReadBlock; -end; - -procedure TLZInWindow.MovePos; -var pointerToPostion:integer; -begin -inc(pos); -if pos > posLimit then begin - pointerToPostion := bufferOffset + pos; - if pointerToPostion > pointerToLastSafePosition then - MoveBlock; - ReadBlock; - end; -end; - -function TLZInWindow.GetIndexByte(const Aindex:integer):byte; -begin -result:=bufferBase[bufferOffset + pos + Aindex]; -end; - -function TLZInWindow.GetMatchLen(const Aindex:integer;Adistance,Alimit:integer):integer; -var pby,i:integer; -begin -if streamEndWasReached then - if (pos + Aindex) + Alimit > streamPos then - Alimit := streamPos - (pos + Aindex); -inc(Adistance); -// Byte *pby = _buffer + (size_t)_pos + Aindex; -pby := bufferOffset + pos + Aindex; - -i:=0; -while (inil then m_LowCoder[i].free; - if m_MidCoder[i]<>nil then m_MidCoder[i].free; - end; -inherited; -end; - -procedure TLZMALenDecoder._Create(const numPosStates:integer); -begin -while m_NumPosStates < numPosStates do begin - New(m_LowCoder[m_NumPosStates], Create(ULZMABase.kNumLowLenBits)); - New(m_MidCoder[m_NumPosStates], Create(ULZMABase.kNumMidLenBits)); - inc(m_NumPosStates); - end; -end; - -procedure TLZMALenDecoder._Init; -var posState:integer; -begin -URangeDecoder.InitBitModels(m_Choice); -for posState := 0 to m_NumPosStates-1 do begin - m_LowCoder[posState]._Init; - m_MidCoder[posState]._Init; - end; -m_HighCoder._Init; -end; - -function TLZMALenDecoder.Decode(const rangeDecoder:PRangeDecoder;const posState:integer):integer; -var symbol:integer; -begin -if (rangeDecoder.DecodeBit(m_Choice, 0) = 0) then begin - result:=m_LowCoder[posState].Decode(rangeDecoder); - exit; - end; -symbol := ULZMABase.kNumLowLenSymbols; -if (rangeDecoder.DecodeBit(m_Choice, 1) = 0) then - symbol := symbol + m_MidCoder[posState].Decode(rangeDecoder) - else symbol := symbol + ULZMABase.kNumMidLenSymbols + m_HighCoder.Decode(rangeDecoder); -result:=symbol; -end; - -procedure TLZMADecoder2._Init; -begin -URangeDecoder.InitBitModels(m_Decoders); -end; - -function TLZMADecoder2.DecodeNormal(const ArangeDecoder:PRangeDecoder):byte; -var symbol:integer; -begin -symbol := 1; -repeat - symbol := (symbol shl 1) or ArangeDecoder.DecodeBit(m_Decoders, symbol); - until not (symbol < $100); -result:=symbol; -end; - -function TLZMADecoder2.DecodeWithMatchByte(const ArangeDecoder:PRangeDecoder;AmatchByte:byte):byte; -var symbol:integer; - matchbit:integer; - bit:integer; -begin -symbol := 1; -repeat - matchBit := (AmatchByte shr 7) and 1; - AmatchByte := AmatchByte shl 1; - bit := ArangeDecoder.DecodeBit(m_Decoders, ((1 + matchBit) shl 8) + symbol); - symbol := (symbol shl 1) or bit; - if (matchBit <> bit) then begin - while (symbol < $100) do begin - symbol := (symbol shl 1) or ArangeDecoder.DecodeBit(m_Decoders, symbol); - end; - break; - end; - until not (symbol < $100); -result:=symbol; -end; - -procedure TLZMALiteralDecoder._Create(const AnumPosBits, AnumPrevBits:integer); -var numStates,i:integer; -begin -if (length(m_Coders) <> 0) and (m_NumPrevBits = AnumPrevBits) and (m_NumPosBits = AnumPosBits) then - exit; -m_NumPosBits := AnumPosBits; -m_PosMask := (1 shl AnumPosBits) - 1; -m_NumPrevBits := AnumPrevBits; -numStates := 1 shl (m_NumPrevBits + m_NumPosBits); -setlength(m_Coders,numStates); -for i :=0 to numStates-1 do - New(m_Coders[i], Create); -end; - -destructor TLZMALiteralDecoder.Destroy; -var i:integer; -begin -for i :=low(m_Coders) to high(m_Coders) do - if m_Coders[i]<>nil then m_Coders[i].Free; -inherited; -end; - -procedure TLZMALiteralDecoder._Init; -var numStates,i:integer; -begin -numStates := 1 shl (m_NumPrevBits + m_NumPosBits); -for i := 0 to numStates -1 do - m_Coders[i]._Init; -end; - -function TLZMALiteralDecoder.GetDecoder(const Apos:integer;const AprevByte:byte):PLZMADecoder2; -begin -result:=m_Coders[((Apos and m_PosMask) shl m_NumPrevBits) + ((AprevByte and $FF) shr (8 - m_NumPrevBits))]; -end; - -constructor TLZMADecoder.Create; -var i:integer; -begin -FOnProgress:=nil; -New(m_OutWindow, Create); -New(m_RangeDecoder, Create); -New(m_PosAlignDecoder, Create(ULZMABase.kNumAlignBits)); -New(m_LenDecoder, Create); -New(m_RepLenDecoder, Create); -New(m_LiteralDecoder, Create); -m_DictionarySize:= -1; -m_DictionarySizeCheck:= -1; -for i := 0 to ULZMABase.kNumLenToPosStates -1 do - New(m_PosSlotDecoder[i], Create(ULZMABase.kNumPosSlotBits)); -end; - -destructor TLZMADecoder.Destroy; -var i:integer; -begin -m_OutWindow.Free; -m_RangeDecoder.Free; -m_PosAlignDecoder.Free; -m_LenDecoder.Free; -m_RepLenDecoder.Free; -m_LiteralDecoder.Free; -for i := 0 to ULZMABase.kNumLenToPosStates -1 do - m_PosSlotDecoder[i].Free; -end; - -function TLZMADecoder.SetDictionarySize(const dictionarySize:integer):boolean; -begin -if dictionarySize < 0 then - result:=false - else begin - if m_DictionarySize <> dictionarySize then begin - m_DictionarySize := dictionarySize; - m_DictionarySizeCheck := max(m_DictionarySize, 1); - m_OutWindow._Create(max(m_DictionarySizeCheck, (1 shl 12))); - end; - result:=true; - end; -end; - -function TLZMADecoder.SetLcLpPb(const lc,lp,pb:integer):boolean; -var numPosStates:integer; -begin -if (lc > ULZMABase.kNumLitContextBitsMax) or (lp > 4) or (pb > ULZMABase.kNumPosStatesBitsMax) then begin - result:=false; - exit; - end; -m_LiteralDecoder._Create(lp, lc); -numPosStates := 1 shl pb; -m_LenDecoder._Create(numPosStates); -m_RepLenDecoder._Create(numPosStates); -m_PosStateMask := numPosStates - 1; -result:=true; -end; - -procedure TLZMADecoder._Init; -var i:integer; -begin -m_OutWindow._Init(false); - -URangeDecoder.InitBitModels(m_IsMatchDecoders); -URangeDecoder.InitBitModels(m_IsRep0LongDecoders); -URangeDecoder.InitBitModels(m_IsRepDecoders); -URangeDecoder.InitBitModels(m_IsRepG0Decoders); -URangeDecoder.InitBitModels(m_IsRepG1Decoders); -URangeDecoder.InitBitModels(m_IsRepG2Decoders); -URangeDecoder.InitBitModels(m_PosDecoders); - -m_LiteralDecoder._Init(); -for i := 0 to ULZMABase.kNumLenToPosStates -1 do - m_PosSlotDecoder[i]._Init; -m_LenDecoder._Init; -m_RepLenDecoder._Init; -m_PosAlignDecoder._Init; -m_RangeDecoder._Init; -end; - -function TLZMADecoder.Code(const inStream,outStream:PStream;outSize:int64):boolean; -var state,rep0,rep1,rep2,rep3:integer; - nowPos64:int64; - prevByte:byte; - posState:integer; - decoder2:PLZMADecoder2; - len,distance,posSlot,numDirectBits:integer; - lpos:int64; - progint:int64; -begin -DoProgress(LPAMax,outSize); -m_RangeDecoder.SetStream(inStream); -m_OutWindow.SetStream(outStream); -_Init; - -state := ULZMABase.StateInit; -rep0 := 0; rep1 := 0; rep2 := 0; rep3 := 0; - -nowPos64 := 0; -prevByte := 0; -progint:=outsize div CodeProgressInterval; -lpos:=progint; -while (outSize < 0) or (nowPos64 < outSize) do begin - if (nowPos64 >=lpos) then begin - DoProgress(LPAPos,nowPos64); - lpos:=lpos+progint; - end; - posState := nowPos64 and m_PosStateMask; - if (m_RangeDecoder.DecodeBit(m_IsMatchDecoders, (state shl ULZMABase.kNumPosStatesBitsMax) + posState) = 0) then begin - decoder2 := m_LiteralDecoder.GetDecoder(nowPos64, prevByte); - if not ULZMABase.StateIsCharState(state) then - prevByte := decoder2.DecodeWithMatchByte(m_RangeDecoder, m_OutWindow.GetByte(rep0)) - else prevByte := decoder2.DecodeNormal(m_RangeDecoder); - m_OutWindow.PutByte(prevByte); - state := ULZMABase.StateUpdateChar(state); - inc(nowPos64); - end else begin - if (m_RangeDecoder.DecodeBit(m_IsRepDecoders, state) = 1) then begin - len := 0; - if (m_RangeDecoder.DecodeBit(m_IsRepG0Decoders, state) = 0) then begin - if (m_RangeDecoder.DecodeBit(m_IsRep0LongDecoders, (state shl ULZMABase.kNumPosStatesBitsMax) + posState) = 0) then begin - state := ULZMABase.StateUpdateShortRep(state); - len := 1; - end; - end else begin - if m_RangeDecoder.DecodeBit(m_IsRepG1Decoders, state) = 0 then - distance := rep1 - else begin - if (m_RangeDecoder.DecodeBit(m_IsRepG2Decoders, state) = 0) then - distance := rep2 - else begin - distance := rep3; - rep3 := rep2; - end; - rep2 := rep1; - end; - rep1 := rep0; - rep0 := distance; - end; - if len = 0 then begin - len := m_RepLenDecoder.Decode(m_RangeDecoder, posState) + ULZMABase.kMatchMinLen; - state := ULZMABase.StateUpdateRep(state); - end; - end else begin - rep3 := rep2; - rep2 := rep1; - rep1 := rep0; - len := ULZMABase.kMatchMinLen + m_LenDecoder.Decode(m_RangeDecoder, posState); - state := ULZMABase.StateUpdateMatch(state); - posSlot := m_PosSlotDecoder[ULZMABase.GetLenToPosState(len)].Decode(m_RangeDecoder); - if posSlot >= ULZMABase.kStartPosModelIndex then begin - numDirectBits := (posSlot shr 1) - 1; - rep0 := ((2 or (posSlot and 1)) shl numDirectBits); - if posSlot < ULZMABase.kEndPosModelIndex then - rep0 := rep0 + UBitTreeDecoder.ReverseDecode(m_PosDecoders, - rep0 - posSlot - 1, m_RangeDecoder, numDirectBits) - else begin - rep0 := rep0 + (m_RangeDecoder.DecodeDirectBits( - numDirectBits - ULZMABase.kNumAlignBits) shl ULZMABase.kNumAlignBits); - rep0 := rep0 + m_PosAlignDecoder.ReverseDecode(m_RangeDecoder); - if rep0 < 0 then begin - if rep0 = -1 then - break; - result:=false; - exit; - end; - end; - end else rep0 := posSlot; - end; - if (rep0 >= nowPos64) or (rep0 >= m_DictionarySizeCheck) then begin - m_OutWindow.Flush(); - result:=false; - exit; - end; - m_OutWindow.CopyBlock(rep0, len); - nowPos64 := nowPos64 + len; - prevByte := m_OutWindow.GetByte(0); - end; -end; -m_OutWindow.Flush(); -m_OutWindow.ReleaseStream(); -m_RangeDecoder.ReleaseStream(); -DoProgress(LPAPos,nowPos64); -result:=true; -end; - -function TLZMADecoder.SetDecoderProperties(const properties:array of byte):boolean; -var val,lc,remainder,lp,pb,dictionarysize,i:integer; -begin -if length(properties) < 5 then begin - result:=false; - exit; - end; -val := properties[0] and $FF; -lc := val mod 9; -remainder := val div 9; -lp := remainder mod 5; -pb := remainder div 5; -dictionarySize := 0; -for i := 0 to 3 do - dictionarySize := dictionarysize + ((properties[1 + i]) and $FF) shl (i * 8); - if (not SetLcLpPb(lc, lp, pb)) then begin - result:=false; - exit; - end; -result:=SetDictionarySize(dictionarySize); -end; - -procedure TLZMADecoder.DoProgress(const Action:TLZMAProgressAction;const Value:integer); -begin -if assigned(fonprogress) then - fonprogress(action,value); -end; - -end. diff --git a/Addons/ULZMAEncoder.pas b/Addons/ULZMAEncoder.pas deleted file mode 100644 index 3cef884..0000000 --- a/Addons/ULZMAEncoder.pas +++ /dev/null @@ -1,1518 +0,0 @@ -unit ULZMAEncoder; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses UBitTreeEncoder,ULZMABase,ULZBinTree,URangeEncoder,KOL,ULZMACommon; - -const EMatchFinderTypeBT2 = 0; - EMatchFinderTypeBT4 = 1; - kIfinityPrice:integer = $FFFFFFF; - kDefaultDictionaryLogSize = 22; - kNumFastBytesDefault = $20; - kNumLenSpecSymbols = ULZMABase.kNumLowLenSymbols + ULZMABase.kNumMidLenSymbols; - kNumOpts = 1 shl 12; - kPropSize = 5; - -type PLZMAEncoder2=^TLZMAEncoder2; - PLZMALiteralEncoder=^TLZMALiteralEncoder; - PLZMAOptimal=^TLZMAOptimal; - PLZMALenPriceTableEncoder=^TLZMALenPriceTableEncoder; - - PLZMAEncoder=^TLZMAEncoder; - TLZMAEncoder=object(TObj) - private - FOnProgress:TLZMAProgress; - procedure DoProgress(const Action:TLZMAProgressAction;const Value:integer); - public - g_FastPos:array [0..1 shl 11-1] of byte; - _state:integer; - _previousByte:byte; - _repDistances:array [0..ULZMABase.kNumRepDistances-1] of integer; - - _optimum: array [0..kNumOpts-1] of PLZMAOptimal; - _matchFinder:PLZBinTree; - _rangeEncoder:PRangeEncoder; - - _isMatch:array [0..ULZMABase.kNumStates shl ULZMABase.kNumPosStatesBitsMax-1]of smallint; - _isRep:array [0..ULZMABase.kNumStates-1] of smallint; - _isRepG0:array [0..ULZMABase.kNumStates-1] of smallint; - _isRepG1:array [0..ULZMABase.kNumStates-1] of smallint; - _isRepG2:array [0..ULZMABase.kNumStates-1] of smallint; - _isRep0Long:array [0..ULZMABase.kNumStates shl ULZMABase.kNumPosStatesBitsMax-1]of smallint; - - _posSlotEncoder:array [0..ULZMABase.kNumLenToPosStates-1] of PBitTreeEncoder; // kNumPosSlotBits - - _posEncoders:array [0..ULZMABase.kNumFullDistances-ULZMABase.kEndPosModelIndex-1]of smallint; - _posAlignEncoder:PBitTreeEncoder; - - _lenEncoder:PLZMALenPriceTableEncoder; - _repMatchLenEncoder:PLZMALenPriceTableEncoder; - - _literalEncoder:PLZMALiteralEncoder; - - _matchDistances:array [0..ULZMABase.kMatchMaxLen*2+1] of integer; - - _numFastBytes:integer; - _longestMatchLength:integer; - _numDistancePairs:integer; - - _additionalOffset:integer; - - _optimumEndIndex:integer; - _optimumCurrentIndex:integer; - - _longestMatchWasFound:boolean; - - _posSlotPrices:array [0..1 shl (ULZMABase.kNumPosSlotBits+ULZMABase.kNumLenToPosStatesBits)-1] of integer; - _distancesPrices:array [0..ULZMABase.kNumFullDistances shl ULZMABase.kNumLenToPosStatesBits-1] of integer; - _alignPrices:array [0..ULZMABase.kAlignTableSize-1] of integer; - _alignPriceCount:integer; - - _distTableSize:integer; - - _posStateBits:integer; - _posStateMask:integer; - _numLiteralPosStateBits:integer; - _numLiteralContextBits:integer; - - _dictionarySize:integer; - _dictionarySizePrev:integer; - _numFastBytesPrev:integer; - - nowPos64:int64; - _finished:boolean; - _inStream:PStream; - - _matchFinderType:integer; - _writeEndMark:boolean; - - _needReleaseMFStream:boolean; - - reps:array [0..ULZMABase.kNumRepDistances-1]of integer; - repLens:array [0..ULZMABase.kNumRepDistances-1] of integer; - backRes:integer; - processedInSize:int64; - processedOutSize:int64; - finished:boolean; - properties:array [0..kPropSize] of byte; - tempPrices:array [0..ULZMABase.kNumFullDistances-1]of integer; - _matchPriceCount:integer; - constructor Create; - destructor Destroy;virtual; - function GetPosSlot(const pos:integer):integer; - function GetPosSlot2(const pos:integer):integer; - procedure BaseInit; - procedure _Create; - procedure SetWriteEndMarkerMode(const AwriteEndMarker:boolean); - procedure _Init; - function ReadMatchDistances:integer; - procedure MovePos(const num:integer); - function GetRepLen1Price(const state,posState:integer):integer; - function GetPureRepPrice(const repIndex, state, posState:integer):integer; - function GetRepPrice(const repIndex, len, state, posState:integer):integer; - function GetPosLenPrice(const pos, len, posState:integer):integer; - function Backward(cur:integer):integer; - function GetOptimum(position:integer):integer; - function ChangePair(const smallDist, bigDist:integer):boolean; - procedure WriteEndMarker(const posState:integer); - procedure Flush(const nowPos:integer); - procedure ReleaseMFStream; - procedure CodeOneBlock(var inSize,outSize:int64;var Afinished:boolean); - procedure FillDistancesPrices; - procedure FillAlignPrices; - procedure SetOutStream(const outStream:PStream); - procedure ReleaseOutStream; - procedure ReleaseStreams; - procedure SetStreams(const inStream, outStream:PStream;const inSize, outSize:int64); - procedure Code(const inStream, outStream:PStream;const inSize, outSize:int64); - procedure WriteCoderProperties(const outStream:PStream); - function SetAlgorithm(const algorithm:integer):boolean; - function SetDictionarySize(dictionarySize:Cardinal):boolean; - function SeNumFastBytes(const numFastBytes:integer):boolean; - function SetMatchFinder(const matchFinderIndex:integer):boolean; - function SetLcLpPb(const lc,lp,pb:integer):boolean; - procedure SetEndMarkerMode(const endMarkerMode:boolean); - property OnProgress:TLZMAProgress read FOnProgress write FOnProgress; - end; - - TLZMALiteralEncoder=object(TObj) - public - m_Coders: array of PLZMAEncoder2; - m_NumPrevBits:integer; - m_NumPosBits:integer; - m_PosMask:integer; - procedure _Create(const numPosBits,numPrevBits:integer); - destructor Destroy;virtual; - procedure _Init; - function GetSubCoder(const pos:integer;const prevByte:byte):PLZMAEncoder2; - end; - - TLZMAEncoder2=object(TObj) - public - m_Encoders: array[0..$300-1] of smallint; - procedure _Init; - procedure Encode(const rangeEncoder:PRangeEncoder;const symbol:byte); - procedure EncodeMatched(const rangeEncoder:PRangeEncoder;const matchByte,symbol:byte); - function GetPrice(const matchMode:boolean;const matchByte,symbol:byte):integer; - end; - - TLZMALenEncoder=object(TObj) - public - _choice:array[0..1] of smallint; - _lowCoder: array [0..ULZMABase.kNumPosStatesEncodingMax-1] of PBitTreeEncoder; - _midCoder: array [0..ULZMABase.kNumPosStatesEncodingMax-1] of PBitTreeEncoder; - _highCoder:PBitTreeEncoder; - constructor Create; - destructor Destroy;virtual; - procedure _Init(const numPosStates:integer); - procedure Encode(const rangeEncoder:PRangeEncoder;symbol:integer;const posState:integer);virtual; - procedure SetPrices(const posState,numSymbols:integer;var prices:array of integer;const st:integer); - end; - - TLZMALenPriceTableEncoder=object(TLZMALenEncoder) - public - _prices: array [0..ULZMABase.kNumLenSymbols shl ULZMABase.kNumPosStatesBitsEncodingMax-1] of integer; - _tableSize:integer; - _counters: array [0..ULZMABase.kNumPosStatesEncodingMax-1] of integer; - procedure SetTableSize(const tableSize:integer); - function GetPrice(const symbol,posState:integer):integer; - procedure UpdateTable(const posState:integer); - procedure UpdateTables(const numPosStates:integer); - procedure Encode(const rangeEncoder:PRangeEncoder;symbol:integer;const posState:integer);virtual; - end; - - TLZMAOptimal=object(TObj) - public - State:integer; - - Prev1IsChar:boolean; - Prev2:boolean; - - PosPrev2:integer; - BackPrev2:integer; - - Price:integer; - PosPrev:integer; - BackPrev:integer; - - Backs0:integer; - Backs1:integer; - Backs2:integer; - Backs3:integer; - - procedure MakeAsChar; - procedure MakeAsShortRep; - function IsShortRep:boolean; - end; - -implementation - -constructor TLZMAEncoder.Create; -var kFastSlots,c,slotFast,j,k:integer; -begin -kFastSlots := 22; -c := 2; -g_FastPos[0] := 0; -g_FastPos[1] := 1; -for slotFast := 2 to kFastSlots -1 do begin - k := (1 shl ((slotFast shr 1) - 1)); - for j := 0 to k -1 do begin - g_FastPos[c] := slotFast; - inc(c); - end; - end; -_state := ULZMABase.StateInit(); -_matchFinder:=nil; -New(_rangeEncoder, Create); -New(_posAlignEncoder, Create(ULZMABase.kNumAlignBits)); -New(_lenEncoder, Create); -New(_repMatchLenEncoder, Create); -New(_literalEncoder, Create); -_numFastBytes:= kNumFastBytesDefault; -_distTableSize:= (kDefaultDictionaryLogSize * 2); -_posStateBits:= 2; -_posStateMask:= (4 - 1); -_numLiteralPosStateBits:= 0; -_numLiteralContextBits:= 3; - -_dictionarySize:= (1 shl kDefaultDictionaryLogSize); -_dictionarySizePrev:= -1; -_numFastBytesPrev:= -1; -_matchFinderType:= EMatchFinderTypeBT4; -_writeEndMark:= false; - -_needReleaseMFStream:= false; -end; - -destructor TLZMAEncoder.Destroy; -var i:integer; -begin -_rangeEncoder.Free; -_posAlignEncoder.Free; -_lenEncoder.Free; -_repMatchLenEncoder.Free; -_literalEncoder.Free; -if _matchFinder<>nil then _matchFinder.Free; -for i := 0 to kNumOpts -1 do - _optimum[i].Free; -for i := 0 to ULZMABase.kNumLenToPosStates -1 do - _posSlotEncoder[i].Free; -end; - -procedure TLZMAEncoder._Create; -var bt:PLZBinTree; - numHashBytes,i:integer; -begin -if _matchFinder = nil then begin - New(bt, Create); - numHashBytes:= 4; - if _matchFinderType = EMatchFinderTypeBT2 then - numHashBytes := 2; - bt.SetType(numHashBytes); - _matchFinder := bt; - end; -_literalEncoder._Create(_numLiteralPosStateBits, _numLiteralContextBits); - -if (_dictionarySize = _dictionarySizePrev) and (_numFastBytesPrev = _numFastBytes) then - exit; -_matchFinder._Create(_dictionarySize, kNumOpts, _numFastBytes, ULZMABase.kMatchMaxLen + 1); -_dictionarySizePrev := _dictionarySize; -_numFastBytesPrev := _numFastBytes; - -for i := 0 to kNumOpts -1 do - New(_optimum[i], Create); -for i := 0 to ULZMABase.kNumLenToPosStates -1 do - New(_posSlotEncoder[i], Create(ULZMABase.kNumPosSlotBits)); -end; - -function TLZMAEncoder.GetPosSlot(const pos:integer):integer; -begin -if (pos < (1 shl 11)) then - result:=g_FastPos[pos] -else if (pos < (1 shl 21)) then - result:=(g_FastPos[pos shr 10] + 20) -else result:=(g_FastPos[pos shr 20] + 40); -end; - -function TLZMAEncoder.GetPosSlot2(const pos:integer):integer; -begin -if (pos < (1 shl 17)) then - result:=(g_FastPos[pos shr 6] + 12) -else if (pos < (1 shl 27)) then - result:=(g_FastPos[pos shr 16] + 32) -else result:=(g_FastPos[pos shr 26] + 52); -end; - -procedure TLZMAEncoder.BaseInit; -var i:integer; -begin -_state := ulzmaBase.StateInit; -_previousByte := 0; -for i := 0 to ULZMABase.kNumRepDistances -1 do - _repDistances[i] := 0; -end; - -procedure TLZMAEncoder.SetWriteEndMarkerMode(const AwriteEndMarker:boolean); -begin -_writeEndMark := AwriteEndMarker; -end; - -procedure TLZMAEncoder._Init; -var i:integer; -begin -BaseInit; -_rangeEncoder._Init; - -URangeEncoder.InitBitModels(_isMatch); -URangeEncoder.InitBitModels(_isRep0Long); -URangeEncoder.InitBitModels(_isRep); -URangeEncoder.InitBitModels(_isRepG0); -URangeEncoder.InitBitModels(_isRepG1); -URangeEncoder.InitBitModels(_isRepG2); -URangeEncoder.InitBitModels(_posEncoders); - - -_literalEncoder._Init(); -for i := 0 to ULZMABase.kNumLenToPosStates -1 do - _posSlotEncoder[i]._Init; - -_lenEncoder._Init(1 shl _posStateBits); -_repMatchLenEncoder._Init(1 shl _posStateBits); - -_posAlignEncoder._Init; - -_longestMatchWasFound := false; -_optimumEndIndex := 0; -_optimumCurrentIndex := 0; -_additionalOffset := 0; -end; - -function TLZMAEncoder.ReadMatchDistances:integer; -var lenRes:integer; -begin -lenRes := 0; -_numDistancePairs := _matchFinder.GetMatches(_matchDistances); - -if _numDistancePairs > 0 then begin - lenRes := _matchDistances[_numDistancePairs - 2]; - if lenRes = _numFastBytes then - lenRes := lenRes + _matchFinder.GetMatchLen(lenRes - 1, _matchDistances[_numDistancePairs - 1], ULZMABase.kMatchMaxLen - lenRes); - end; -inc(_additionalOffset); -result:=lenRes; -end; - -procedure TLZMAEncoder.MovePos(const num:integer); -begin -if num > 0 then begin - _matchFinder.Skip(num); - _additionalOffset := _additionalOffset + num; - end; -end; - -function TLZMAEncoder.GetRepLen1Price(const state,posState:integer):integer; -begin -result:=RangeEncoder.GetPrice0(_isRepG0[state]) + - RangeEncoder.GetPrice0(_isRep0Long[(state shl ULZMABase.kNumPosStatesBitsMax) + posState]); -end; - -function TLZMAEncoder.GetPureRepPrice(const repIndex, state, posState:integer):integer; -var price:integer; -begin -if repIndex = 0 then begin - price := RangeEncoder.GetPrice0(_isRepG0[state]); - price := price + RangeEncoder.GetPrice1(_isRep0Long[(state shl ULZMABase.kNumPosStatesBitsMax) + posState]); - end else begin - price := RangeEncoder.GetPrice1(_isRepG0[state]); - if repIndex = 1 then - price := price + RangeEncoder.GetPrice0(_isRepG1[state]) - else begin - price := price + RangeEncoder.GetPrice1(_isRepG1[state]); - price := price + RangeEncoder.GetPrice(_isRepG2[state], repIndex - 2); - end; - end; -result:=price; -end; - -function TLZMAEncoder.GetRepPrice(const repIndex, len, state, posState:integer):integer; -var price:integer; -begin -price := _repMatchLenEncoder.GetPrice(len - ULZMABase.kMatchMinLen, posState); -result := price + GetPureRepPrice(repIndex, state, posState); -end; - -function TLZMAEncoder.GetPosLenPrice(const pos, len, posState:integer):integer; -var price,lenToPosState:integer; -begin -lenToPosState := ULZMABase.GetLenToPosState(len); -if pos < ULZMABase.kNumFullDistances then - price := _distancesPrices[(lenToPosState * ULZMABase.kNumFullDistances) + pos] - else price := _posSlotPrices[(lenToPosState shl ULZMABase.kNumPosSlotBits) + GetPosSlot2(pos)] + - _alignPrices[pos and ULZMABase.kAlignMask]; -result := price + _lenEncoder.GetPrice(len - ULZMABase.kMatchMinLen, posState); -end; - -function TLZMAEncoder.Backward(cur:integer):integer; -var posMem,backMem,posPrev,backCur:integer; -begin -_optimumEndIndex := cur; -posMem := _optimum[cur].PosPrev; -backMem := _optimum[cur].BackPrev; -repeat - if _optimum[cur].Prev1IsChar then begin - _optimum[posMem].MakeAsChar; - _optimum[posMem].PosPrev := posMem - 1; - if _optimum[cur].Prev2 then begin - _optimum[posMem - 1].Prev1IsChar := false; - _optimum[posMem - 1].PosPrev := _optimum[cur].PosPrev2; - _optimum[posMem - 1].BackPrev := _optimum[cur].BackPrev2; - end; - end; - posPrev := posMem; - backCur := backMem; - - backMem := _optimum[posPrev].BackPrev; - posMem := _optimum[posPrev].PosPrev; - - _optimum[posPrev].BackPrev := backCur; - _optimum[posPrev].PosPrev := cur; - cur := posPrev; - until not (cur > 0); -backRes := _optimum[0].BackPrev; -_optimumCurrentIndex := _optimum[0].PosPrev; -result:=_optimumCurrentIndex; -end; - -function TLZMAEncoder.GetOptimum(position:integer):integer; -var lenRes,lenMain,numDistancePairs,numAvailableBytes,repMaxIndex,i:integer; - matchPrice,repMatchPrice,shortRepPrice,lenEnd,len,repLen,price:integer; - curAndLenPrice,normalMatchPrice,Offs,distance,cur,newLen:integer; - posPrev,state,pos,curPrice,curAnd1Price,numAvailableBytesFull:integer; - lenTest2,t,state2,posStateNext,nextRepMatchPrice,offset:integer; - startLen,repIndex,lenTest,lenTestTemp,curAndLenCharPrice:integer; - nextMatchPrice,curBack:integer; - optimum,opt,nextOptimum:PLZMAOptimal; - currentByte,matchByte,posState:byte; - nextIsChar:boolean; -begin -if (_optimumEndIndex <> _optimumCurrentIndex) then begin - lenRes := _optimum[_optimumCurrentIndex].PosPrev - _optimumCurrentIndex; - backRes := _optimum[_optimumCurrentIndex].BackPrev; - _optimumCurrentIndex := _optimum[_optimumCurrentIndex].PosPrev; - result:=lenRes; - exit; - end;//if optimumendindex -_optimumCurrentIndex := 0; -_optimumEndIndex := 0; - -if not _longestMatchWasFound then begin - lenMain := ReadMatchDistances(); - end else begin //if not longest - lenMain := _longestMatchLength; - _longestMatchWasFound := false; - end;//if not longest else -numDistancePairs := _numDistancePairs; - -numAvailableBytes := _matchFinder.GetNumAvailableBytes + 1; -if numAvailableBytes < 2 then begin - backRes := -1; - result:=1; - exit; - end;//if numavailable -{if numAvailableBytes > ULZMABase.kMatchMaxLen then - numAvailableBytes := ULZMABase.kMatchMaxLen;} - -repMaxIndex := 0; -for i := 0 to ULZMABase.kNumRepDistances-1 do begin - reps[i] := _repDistances[i]; - repLens[i] := _matchFinder.GetMatchLen(0 - 1, reps[i], ULZMABase.kMatchMaxLen); - if repLens[i] > repLens[repMaxIndex] then - repMaxIndex := i; - end;//for i -if repLens[repMaxIndex] >= _numFastBytes then begin - backRes := repMaxIndex; - lenRes := repLens[repMaxIndex]; - MovePos(lenRes - 1); - result:=lenRes; - exit; - end;//if replens[] - -if lenMain >= _numFastBytes then begin - backRes := _matchDistances[numDistancePairs - 1] + ULZMABase.kNumRepDistances; - MovePos(lenMain - 1); - result:=lenMain; - exit; - end;//if lenMain - -currentByte := _matchFinder.GetIndexByte(0 - 1); -matchByte := _matchFinder.GetIndexByte(0 - _repDistances[0] - 1 - 1); - -if (lenMain < 2) and (currentByte <> matchByte) and (repLens[repMaxIndex] < 2) then begin - backRes := -1; - result:=1; - exit; - end;//if lenmain<2 - -_optimum[0].State := _state; - -posState := (position and _posStateMask); - -_optimum[1].Price := RangeEncoder.GetPrice0(_isMatch[(_state shl ULZMABase.kNumPosStatesBitsMax) + posState]) + - _literalEncoder.GetSubCoder(position, _previousByte).GetPrice(not ULZMABase.StateIsCharState(_state), matchByte, currentByte); -_optimum[1].MakeAsChar(); - -matchPrice := RangeEncoder.GetPrice1(_isMatch[(_state shl ULZMABase.kNumPosStatesBitsMax) + posState]); -repMatchPrice := matchPrice + RangeEncoder.GetPrice1(_isRep[_state]); - -if matchByte = currentByte then begin - shortRepPrice := repMatchPrice + GetRepLen1Price(_state, posState); - if shortRepPrice < _optimum[1].Price then begin - _optimum[1].Price := shortRepPrice; - _optimum[1].MakeAsShortRep; - end;//if shortrepprice - end;//if matchbyte - -if lenMain >= repLens[repMaxIndex] then lenEnd:=lenMain - else lenEnd:=repLens[repMaxIndex]; - -if lenEnd < 2 then begin - backRes := _optimum[1].BackPrev; - result:=1; - exit; - end;//if lenend<2 - -_optimum[1].PosPrev := 0; - -_optimum[0].Backs0 := reps[0]; -_optimum[0].Backs1 := reps[1]; -_optimum[0].Backs2 := reps[2]; -_optimum[0].Backs3 := reps[3]; - -len := lenEnd; -repeat - _optimum[len].Price := kIfinityPrice; - dec(len); - until not (len >= 2); - -for i := 0 to ULZMABase.kNumRepDistances -1 do begin - repLen := repLens[i]; - if repLen < 2 then - continue; - price := repMatchPrice + GetPureRepPrice(i, _state, posState); - repeat - curAndLenPrice := price + _repMatchLenEncoder.GetPrice(repLen - 2, posState); - optimum := _optimum[repLen]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := 0; - optimum.BackPrev := i; - optimum.Prev1IsChar := false; - end;//if curandlenprice - dec(replen); - until not (repLen >= 2); - end;//for i - -normalMatchPrice := matchPrice + RangeEncoder.GetPrice0(_isRep[_state]); - -if repLens[0] >= 2 then len:=repLens[0] + 1 - else len:=2; - -if len <= lenMain then begin - offs := 0; - while len > _matchDistances[offs] do - offs := offs + 2; - while (true) do begin - distance := _matchDistances[offs + 1]; - curAndLenPrice := normalMatchPrice + GetPosLenPrice(distance, len, posState); - optimum := _optimum[len]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := 0; - optimum.BackPrev := distance + ULZMABase.kNumRepDistances; - optimum.Prev1IsChar := false; - end;//if curlenandprice - if len = _matchDistances[offs] then begin - offs := offs + 2; - if offs = numDistancePairs then - break; - end;//if len=_match - inc(len); - end;//while (true) - end;//if len<=lenmain - -cur := 0; - -while (true) do begin - inc(cur); - if cur = lenEnd then begin - result:=Backward(cur); - exit; - end;//if cur=lenEnd - newLen := ReadMatchDistances; - numDistancePairs := _numDistancePairs; - if newLen >= _numFastBytes then begin - _longestMatchLength := newLen; - _longestMatchWasFound := true; - result:=Backward(cur); - exit; - end;//if newlen=_numfast - inc(position); - posPrev := _optimum[cur].PosPrev; - if _optimum[cur].Prev1IsChar then begin - dec(posPrev); - if _optimum[cur].Prev2 then begin - state := _optimum[_optimum[cur].PosPrev2].State; - if _optimum[cur].BackPrev2 < ULZMABase.kNumRepDistances then - state := ULZMABase.StateUpdateRep(state) - else state := ULZMABase.StateUpdateMatch(state); - end//if _optimum[cur].Prev2 - else state := _optimum[posPrev].State; - state := ULZMABase.StateUpdateChar(state); - end//if _optimum[cur].Prev1IsChar - else state := _optimum[posPrev].State; - if posPrev = cur - 1 then begin - if _optimum[cur].IsShortRep then - state := ULZMABase.StateUpdateShortRep(state) - else state := ULZMABase.StateUpdateChar(state); - end //if posPrev = cur - 1 - else begin - if _optimum[cur].Prev1IsChar and _optimum[cur].Prev2 then begin - posPrev := _optimum[cur].PosPrev2; - pos := _optimum[cur].BackPrev2; - state := ULZMABase.StateUpdateRep(state); - end//if _optimum[cur].Prev1IsChar - else begin - pos := _optimum[cur].BackPrev; - if pos < ULZMABase.kNumRepDistances then - state := ULZMABase.StateUpdateRep(state) - else state := ULZMABase.StateUpdateMatch(state); - end;//if else _optimum[cur].Prev1IsChar - opt := _optimum[posPrev]; - if pos < ULZMABase.kNumRepDistances then begin - if pos = 0 then begin - reps[0] := opt.Backs0; - reps[1] := opt.Backs1; - reps[2] := opt.Backs2; - reps[3] := opt.Backs3; - end//if pos=0 - else if pos = 1 then begin - reps[0] := opt.Backs1; - reps[1] := opt.Backs0; - reps[2] := opt.Backs2; - reps[3] := opt.Backs3; - end //if pos=1 - else if pos = 2 then begin - reps[0] := opt.Backs2; - reps[1] := opt.Backs0; - reps[2] := opt.Backs1; - reps[3] := opt.Backs3; - end//if pos=2 - else begin - reps[0] := opt.Backs3; - reps[1] := opt.Backs0; - reps[2] := opt.Backs1; - reps[3] := opt.Backs2; - end;//else if pos= - end// if pos < ULZMABase.kNumRepDistances - else begin - reps[0] := (pos - ULZMABase.kNumRepDistances); - reps[1] := opt.Backs0; - reps[2] := opt.Backs1; - reps[3] := opt.Backs2; - end;//if else pos < ULZMABase.kNumRepDistances - end;//if else posPrev = cur - 1 - _optimum[cur].State := state; - _optimum[cur].Backs0 := reps[0]; - _optimum[cur].Backs1 := reps[1]; - _optimum[cur].Backs2 := reps[2]; - _optimum[cur].Backs3 := reps[3]; - curPrice := _optimum[cur].Price; - - currentByte := _matchFinder.GetIndexByte(0 - 1); - matchByte := _matchFinder.GetIndexByte(0 - reps[0] - 1 - 1); - - posState := (position and _posStateMask); - - curAnd1Price := curPrice + - RangeEncoder.GetPrice0(_isMatch[(state shl ULZMABase.kNumPosStatesBitsMax) + posState]) + - _literalEncoder.GetSubCoder(position, _matchFinder.GetIndexByte(0 - 2)). - GetPrice(not ULZMABase.StateIsCharState(state), matchByte, currentByte); - - nextOptimum := _optimum[cur + 1]; - - nextIsChar := false; - if curAnd1Price < nextOptimum.Price then begin - nextOptimum.Price := curAnd1Price; - nextOptimum.PosPrev := cur; - nextOptimum.MakeAsChar; - nextIsChar := true; - end;//if curand1price - - matchPrice := curPrice + RangeEncoder.GetPrice1(_isMatch[(state shl ULZMABase.kNumPosStatesBitsMax) + posState]); - repMatchPrice := matchPrice + RangeEncoder.GetPrice1(_isRep[state]); - - if (matchByte = currentByte) and - (not ((nextOptimum.PosPrev < cur) and (nextOptimum.BackPrev = 0))) then begin - shortRepPrice := repMatchPrice + GetRepLen1Price(state, posState); - if shortRepPrice <= nextOptimum.Price then begin - nextOptimum.Price := shortRepPrice; - nextOptimum.PosPrev := cur; - nextOptimum.MakeAsShortRep; - nextIsChar := true; - end;//if shortRepPrice <= nextOptimum.Price - end;//if (matchByte = currentByte) and - - numAvailableBytesFull := _matchFinder.GetNumAvailableBytes + 1; - numAvailableBytesFull := min(kNumOpts - 1 - cur, numAvailableBytesFull); - numAvailableBytes := numAvailableBytesFull; - - if numAvailableBytes < 2 then - continue; - if numAvailableBytes > _numFastBytes then - numAvailableBytes := _numFastBytes; - if (not nextIsChar) and (matchByte <> currentByte) then begin - // try Literal + rep0 - t := min(numAvailableBytesFull - 1, _numFastBytes); - lenTest2 := _matchFinder.GetMatchLen(0, reps[0], t); - if lenTest2 >= 2 then begin - state2 := ULZMABase.StateUpdateChar(state); - - posStateNext := (position + 1) and _posStateMask; - nextRepMatchPrice := curAnd1Price + - RangeEncoder.GetPrice1(_isMatch[(state2 shl ULZMABase.kNumPosStatesBitsMax) + posStateNext]) + - RangeEncoder.GetPrice1(_isRep[state2]); - begin - offset := cur + 1 + lenTest2; - while lenEnd < offset do begin - inc(lenEnd); - _optimum[lenEnd].Price := kIfinityPrice; - end;//while lenend - curAndLenPrice := nextRepMatchPrice + GetRepPrice( - 0, lenTest2, state2, posStateNext); - optimum := _optimum[offset]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := cur + 1; - optimum.BackPrev := 0; - optimum.Prev1IsChar := true; - optimum.Prev2 := false; - end;//if curandlenprice - end;//none - end;//if lentest - end;//if not nextischar and ... - - startLen := 2; // speed optimization - - for repIndex := 0 to ULZMABase.kNumRepDistances -1 do begin - lenTest := _matchFinder.GetMatchLen(0 - 1, reps[repIndex], numAvailableBytes); - if lenTest < 2 then - continue; - lenTestTemp := lenTest; - repeat - while lenEnd < cur + lenTest do begin - inc(lenEnd); - _optimum[lenEnd].Price := kIfinityPrice; - end;//while lenEnd - curAndLenPrice := repMatchPrice + GetRepPrice(repIndex, lenTest, state, posState); - optimum := _optimum[cur + lenTest]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := cur; - optimum.BackPrev := repIndex; - optimum.Prev1IsChar := false; - end;//if curandlen - dec(lenTest); - until not (lenTest >= 2); - lenTest := lenTestTemp; - - if repIndex = 0 then - startLen := lenTest + 1; - - // if (_maxMode) - if lenTest < numAvailableBytesFull then begin - t := min(numAvailableBytesFull - 1 - lenTest, _numFastBytes); - lenTest2 := _matchFinder.GetMatchLen(lenTest, reps[repIndex], t); - if lenTest2 >= 2 then begin - state2 := ULZMABase.StateUpdateRep(state); - - posStateNext := (position + lenTest) and _posStateMask; - curAndLenCharPrice := - repMatchPrice + GetRepPrice(repIndex, lenTest, state, posState) + - RangeEncoder.GetPrice0(_isMatch[(state2 shl ULZMABase.kNumPosStatesBitsMax) + posStateNext]) + - _literalEncoder.GetSubCoder(position + lenTest, - _matchFinder.GetIndexByte(lenTest - 1 - 1)).GetPrice(true, - _matchFinder.GetIndexByte(lenTest - 1 - (reps[repIndex] + 1)), - _matchFinder.GetIndexByte(lenTest - 1)); - state2 := ULZMABase.StateUpdateChar(state2); - posStateNext := (position + lenTest + 1) and _posStateMask; - nextMatchPrice := curAndLenCharPrice + RangeEncoder.GetPrice1(_isMatch[(state2 shl ULZMABase.kNumPosStatesBitsMax) + posStateNext]); - nextRepMatchPrice := nextMatchPrice + RangeEncoder.GetPrice1(_isRep[state2]); - - // for(; lenTest2 >= 2; lenTest2--) - begin - offset := lenTest + 1 + lenTest2; - while lenEnd < cur + offset do begin - inc(lenEnd); - _optimum[lenEnd].Price := kIfinityPrice; - end;//while lenEnd - curAndLenPrice := nextRepMatchPrice + GetRepPrice(0, lenTest2, state2, posStateNext); - optimum := _optimum[cur + offset]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := cur + lenTest + 1; - optimum.BackPrev := 0; - optimum.Prev1IsChar := true; - optimum.Prev2 := true; - optimum.PosPrev2 := cur; - optimum.BackPrev2 := repIndex; - end;//if curAndLenPrice < optimum.Price - end;//none - end;//if lenTest2 >= 2 - end;//if lenTest < numAvailableBytesFull - end;//for repIndex - - if newLen > numAvailableBytes then begin - newLen := numAvailableBytes; - numDistancePairs := 0; - while newLen > _matchDistances[numDistancePairs] do - numDistancePairs := numDistancePairs + 2; - _matchDistances[numDistancePairs] := newLen; - numDistancePairs := numDistancePairs + 2; - end;//if newLen > numAvailableBytes - if newLen >= startLen then begin - normalMatchPrice := matchPrice + RangeEncoder.GetPrice0(_isRep[state]); - while lenEnd < cur + newLen do begin - inc(lenEnd); - _optimum[lenEnd].Price := kIfinityPrice; - end;//while lenEnd - - offs := 0; - while startLen > _matchDistances[offs] do - offs := offs + 2; - - lenTest := startLen; - while (true) do begin - curBack := _matchDistances[offs + 1]; - curAndLenPrice := normalMatchPrice + GetPosLenPrice(curBack, lenTest, posState); - optimum := _optimum[cur + lenTest]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := cur; - optimum.BackPrev := curBack + ULZMABase.kNumRepDistances; - optimum.Prev1IsChar := false; - end;//if curAndLenPrice < optimum.Price - - if lenTest = _matchDistances[offs] then begin - if lenTest < numAvailableBytesFull then begin - t := min(numAvailableBytesFull - 1 - lenTest, _numFastBytes); - lenTest2 := _matchFinder.GetMatchLen(lenTest, curBack, t); - if lenTest2 >= 2 then begin - state2 := ULZMABase.StateUpdateMatch(state); - - posStateNext := (position + lenTest) and _posStateMask; - curAndLenCharPrice := curAndLenPrice + - RangeEncoder.GetPrice0(_isMatch[(state2 shl ULZMABase.kNumPosStatesBitsMax) + posStateNext]) + - _literalEncoder.GetSubCoder(position + lenTest, - _matchFinder.GetIndexByte(lenTest - 1 - 1)). - GetPrice(true, - _matchFinder.GetIndexByte(lenTest - (curBack + 1) - 1), - _matchFinder.GetIndexByte(lenTest - 1)); - state2 := ULZMABase.StateUpdateChar(state2); - posStateNext := (position + lenTest + 1) and _posStateMask; - nextMatchPrice := curAndLenCharPrice + RangeEncoder.GetPrice1(_isMatch[(state2 shl ULZMABase.kNumPosStatesBitsMax) + posStateNext]); - nextRepMatchPrice := nextMatchPrice + RangeEncoder.GetPrice1(_isRep[state2]); - - offset := lenTest + 1 + lenTest2; - while lenEnd < cur + offset do begin - inc(lenEnd); - _optimum[lenEnd].Price := kIfinityPrice; - end;//while lenEnd - curAndLenPrice := nextRepMatchPrice + GetRepPrice(0, lenTest2, state2, posStateNext); - optimum := _optimum[cur + offset]; - if curAndLenPrice < optimum.Price then begin - optimum.Price := curAndLenPrice; - optimum.PosPrev := cur + lenTest + 1; - optimum.BackPrev := 0; - optimum.Prev1IsChar := true; - optimum.Prev2 := true; - optimum.PosPrev2 := cur; - optimum.BackPrev2 := curBack + ULZMABase.kNumRepDistances; - end;//if curAndLenPrice < optimum.Price - end;//if lenTest2 >= 2 - end;//lenTest < numAvailableBytesFull - offs :=offs + 2; - if offs = numDistancePairs then - break; - end;//if lenTest = _matchDistances[offs] - inc(lenTest); - end;//while(true) - end;//if newLen >= startLen - end;//while (true) -end; - -function TLZMAEncoder.ChangePair(const smallDist, bigDist:integer):boolean; -var kDif:integer; -begin -kDif := 7; -result:= (smallDist < (1 shl (32 - kDif))) and (bigDist >= (smallDist shl kDif)); -end; - -procedure TLZMAEncoder.WriteEndMarker(const posState:integer); -var len,posSlot,lenToPosState,footerBits,posReduced:integer; -begin -if not _writeEndMark then - exit; - -_rangeEncoder.Encode(_isMatch, (_state shl ULZMABase.kNumPosStatesBitsMax) + posState, 1); -_rangeEncoder.Encode(_isRep, _state, 0); -_state := ULZMABase.StateUpdateMatch(_state); -len := ULZMABase.kMatchMinLen; -_lenEncoder.Encode(_rangeEncoder, len - ULZMABase.kMatchMinLen, posState); -posSlot := (1 shl ULZMABase.kNumPosSlotBits) - 1; -lenToPosState := ULZMABase.GetLenToPosState(len); -_posSlotEncoder[lenToPosState].Encode(_rangeEncoder, posSlot); -footerBits := 30; -posReduced := (1 shl footerBits) - 1; -_rangeEncoder.EncodeDirectBits(posReduced shr ULZMABase.kNumAlignBits, footerBits - ULZMABase.kNumAlignBits); -_posAlignEncoder.ReverseEncode(_rangeEncoder, posReduced and ULZMABase.kAlignMask); -end; - -procedure TLZMAEncoder.Flush(const nowPos:integer); -begin -ReleaseMFStream; -WriteEndMarker(nowPos and _posStateMask); -_rangeEncoder.FlushData(); -_rangeEncoder.FlushStream(); -end; - -procedure TLZMAEncoder.CodeOneBlock(var inSize,outSize:int64;var Afinished:boolean); -var progressPosValuePrev:int64; - posState,len,pos,complexState,distance,i,posSlot,lenToPosState:integer; - footerBits,baseVal,posReduced:integer; - curByte,matchByte:byte; - subcoder:PLZMAEncoder2; -begin -inSize := 0; -outSize := 0; -Afinished := true; - -if _inStream <>nil then begin - _matchFinder.SetStream(_inStream); - _matchFinder._Init; - _needReleaseMFStream := true; - _inStream := nil; - end; - -if _finished then - exit; -_finished := true; - -progressPosValuePrev := nowPos64; -if nowPos64 = 0 then begin - if _matchFinder.GetNumAvailableBytes = 0 then begin - Flush(nowPos64); - exit; - end; - - ReadMatchDistances; - posState := integer(nowPos64) and _posStateMask; - _rangeEncoder.Encode(_isMatch, (_state shl ULZMABase.kNumPosStatesBitsMax) + posState, 0); - _state := ULZMABase.StateUpdateChar(_state); - curByte := _matchFinder.GetIndexByte(0 - _additionalOffset); - _literalEncoder.GetSubCoder(integer(nowPos64), _previousByte).Encode(_rangeEncoder, curByte); - _previousByte := curByte; - dec(_additionalOffset); - inc(nowPos64); - end; -if _matchFinder.GetNumAvailableBytes = 0 then begin - Flush(integer(nowPos64)); - exit; - end; -while true do begin - len := GetOptimum(integer(nowPos64)); - pos := backRes; - posState := integer(nowPos64) and _posStateMask; - complexState := (_state shl ULZMABase.kNumPosStatesBitsMax) + posState; - if (len = 1) and (pos = -1) then begin - _rangeEncoder.Encode(_isMatch, complexState, 0); - curByte := _matchFinder.GetIndexByte(0 - _additionalOffset); - subCoder := _literalEncoder.GetSubCoder(integer(nowPos64), _previousByte); - if not ULZMABase.StateIsCharState(_state) then begin - matchByte := _matchFinder.GetIndexByte(0 - _repDistances[0] - 1 - _additionalOffset); - subCoder.EncodeMatched(_rangeEncoder, matchByte, curByte); - end else subCoder.Encode(_rangeEncoder, curByte); - _previousByte := curByte; - _state := ULZMABase.StateUpdateChar(_state); - end else begin - _rangeEncoder.Encode(_isMatch, complexState, 1); - if pos < ULZMABase.kNumRepDistances then begin - _rangeEncoder.Encode(_isRep, _state, 1); - if pos = 0 then begin - _rangeEncoder.Encode(_isRepG0, _state, 0); - if len = 1 then - _rangeEncoder.Encode(_isRep0Long, complexState, 0) - else _rangeEncoder.Encode(_isRep0Long, complexState, 1); - end else begin - _rangeEncoder.Encode(_isRepG0, _state, 1); - if pos = 1 then - _rangeEncoder.Encode(_isRepG1, _state, 0) - else begin - _rangeEncoder.Encode(_isRepG1, _state, 1); - _rangeEncoder.Encode(_isRepG2, _state, pos - 2); - end; - end; - if len = 1 then - _state := ULZMABase.StateUpdateShortRep(_state) - else begin - _repMatchLenEncoder.Encode(_rangeEncoder, len - ULZMABase.kMatchMinLen, posState); - _state := ULZMABase.StateUpdateRep(_state); - end; - distance := _repDistances[pos]; - if pos <> 0 then begin - for i := pos downto 1 do - _repDistances[i] := _repDistances[i - 1]; - _repDistances[0] := distance; - end; - end else begin - _rangeEncoder.Encode(_isRep, _state, 0); - _state := ULZMABase.StateUpdateMatch(_state); - _lenEncoder.Encode(_rangeEncoder, len - ULZMABase.kMatchMinLen, posState); - pos := pos - ULZMABase.kNumRepDistances; - posSlot := GetPosSlot(pos); - lenToPosState := ULZMABase.GetLenToPosState(len); - _posSlotEncoder[lenToPosState].Encode(_rangeEncoder, posSlot); - - if posSlot >= ULZMABase.kStartPosModelIndex then begin - footerBits := integer((posSlot shr 1) - 1); - baseVal := ((2 or (posSlot and 1)) shl footerBits); - posReduced := pos - baseVal; - - if posSlot < ULZMABase.kEndPosModelIndex then - UBitTreeEncoder.ReverseEncode(_posEncoders, - baseVal - posSlot - 1, _rangeEncoder, footerBits, posReduced) - else begin - _rangeEncoder.EncodeDirectBits(posReduced shr ULZMABase.kNumAlignBits, footerBits - ULZMABase.kNumAlignBits); - _posAlignEncoder.ReverseEncode(_rangeEncoder, posReduced and ULZMABase.kAlignMask); - inc(_alignPriceCount); - end; - end; - distance := pos; - for i := ULZMABase.kNumRepDistances - 1 downto 1 do - _repDistances[i] := _repDistances[i - 1]; - _repDistances[0] := distance; - inc(_matchPriceCount); - end; - _previousByte := _matchFinder.GetIndexByte(len - 1 - _additionalOffset); - end; -_additionalOffset := _additionalOffset - len; -nowPos64 := nowPos64 + len; -if _additionalOffset = 0 then begin - // if (!_fastMode) - if _matchPriceCount >= (1 shl 7) then - FillDistancesPrices; - if _alignPriceCount >= ULZMABase.kAlignTableSize then - FillAlignPrices; - inSize := nowPos64; - outSize := _rangeEncoder.GetProcessedSizeAdd; - if _matchFinder.GetNumAvailableBytes = 0 then begin - Flush(integer(nowPos64)); - exit; - end; - -if (nowPos64 - progressPosValuePrev >= (1 shl 12)) then begin - _finished := false; - Afinished := false; - exit; - end; -end; -end; -end; - -procedure TLZMAEncoder.ReleaseMFStream; -begin -if (_matchFinder <>nil) and _needReleaseMFStream then begin - _matchFinder.ReleaseStream; - _needReleaseMFStream := false; - end; -end; - -procedure TLZMAEncoder.SetOutStream(const outStream:PStream); -begin -_rangeEncoder.SetStream(outStream); -end; - -procedure TLZMAEncoder.ReleaseOutStream; -begin -_rangeEncoder.ReleaseStream; -end; - -procedure TLZMAEncoder.ReleaseStreams; -begin -ReleaseMFStream; -ReleaseOutStream; -end; - -procedure TLZMAEncoder.SetStreams(const inStream, outStream:PStream;const inSize, outSize:int64); -begin -_inStream := inStream; -_finished := false; -_Create(); -SetOutStream(outStream); -_Init(); - -// if (!_fastMode) -FillDistancesPrices; -FillAlignPrices; - -_lenEncoder.SetTableSize(_numFastBytes + 1 - ULZMABase.kMatchMinLen); -_lenEncoder.UpdateTables(1 shl _posStateBits); -_repMatchLenEncoder.SetTableSize(_numFastBytes + 1 - ULZMABase.kMatchMinLen); -_repMatchLenEncoder.UpdateTables(1 shl _posStateBits); - -nowPos64 := 0; -end; - -procedure TLZMAEncoder.Code(const inStream, outStream:PStream;const inSize, outSize:int64); -var lpos:int64; - progint:int64; - inputsize:int64; -begin -if insize=-1 then - inputsize:=instream.Size-instream.Position - else inputsize:=insize; -progint:=inputsize div CodeProgressInterval; -lpos:=progint; - -_needReleaseMFStream := false; -DoProgress(LPAMax,inputsize); -try - SetStreams(inStream, outStream, inSize, outSize); - while true do begin - CodeOneBlock(processedInSize, processedOutSize, finished); - if finished then begin - DoProgress(LPAPos,inputsize); - exit; - end; - if (processedInSize>=lpos) then begin - DoProgress(LPAPos,processedInSize); - lpos:=lpos+progint; - end; - end; - finally - ReleaseStreams(); - end; -end; - -procedure TLZMAEncoder.WriteCoderProperties(const outStream:PStream); -var i:integer; -begin -properties[0] := (_posStateBits * 5 + _numLiteralPosStateBits) * 9 + _numLiteralContextBits; -for i := 0 to 3 do - properties[1 + i] := (_dictionarySize shr (8 * i)); -outStream.write(properties, kPropSize); -end; - -procedure TLZMAEncoder.FillDistancesPrices; -var i,posSlot,footerBits,baseVal,lenToPosState,st,st2:integer; - encoder:PBitTreeEncoder; -begin -for i := ULZMABase.kStartPosModelIndex to ULZMABase.kNumFullDistances -1 do begin - posSlot := GetPosSlot(i); - footerBits := integer((posSlot shr 1) - 1); - baseVal := (2 or (posSlot and 1)) shl footerBits; - tempPrices[i] := ReverseGetPrice(_posEncoders, - baseVal - posSlot - 1, footerBits, i - baseVal); - end; - -for lenToPosState := 0 to ULZMABase.kNumLenToPosStates -1 do begin - encoder := _posSlotEncoder[lenToPosState]; - - st := (lenToPosState shl ULZMABase.kNumPosSlotBits); - for posSlot := 0 to _distTableSize -1 do - _posSlotPrices[st + posSlot] := encoder.GetPrice(posSlot); - for posSlot := ULZMABase.kEndPosModelIndex to _distTableSize -1 do - _posSlotPrices[st + posSlot] := _posSlotPrices[st + posSlot] + ((((posSlot shr 1) - 1) - ULZMABase.kNumAlignBits) shl kNumBitPriceShiftBits); - - st2 := lenToPosState * ULZMABase.kNumFullDistances; - for i := 0 to ULZMABase.kStartPosModelIndex -1 do - _distancesPrices[st2 + i] := _posSlotPrices[st + i]; - for i := ULZMABase.kStartPosModelIndex to ULZMABase.kNumFullDistances-1 do - _distancesPrices[st2 + i] := _posSlotPrices[st + GetPosSlot(i)] + tempPrices[i]; - end; -_matchPriceCount := 0; -end; - -procedure TLZMAEncoder.FillAlignPrices; -var i:integer; -begin -for i := 0 to ULZMABase.kAlignTableSize -1 do - _alignPrices[i] := _posAlignEncoder.ReverseGetPrice(i); -_alignPriceCount := 0; -end; - -function TLZMAEncoder.SetAlgorithm(const algorithm:integer):boolean; -begin -{ - _fastMode = (algorithm == 0); - _maxMode = (algorithm >= 2); -} -result:=true; -end; - -function TLZMAEncoder.SetDictionarySize(dictionarySize:Cardinal):boolean; -var kDicLogSizeMaxCompress,dicLogSize:integer; -begin -kDicLogSizeMaxCompress := 29; -if (dictionarySize < (1 shl ULZMABase.kDicLogSizeMin)) or (dictionarySize > (1 shl kDicLogSizeMaxCompress)) then begin - result:=false; - exit; - end; -_dictionarySize := dictionarySize; -dicLogSize := 0; -while dictionarySize > (1 shl dicLogSize) do - inc(dicLogSize); -_distTableSize := dicLogSize * 2; -result:=true; -end; - -function TLZMAEncoder.SeNumFastBytes(const numFastBytes:integer):boolean; -begin -if (numFastBytes < 5) or (numFastBytes > ULZMABase.kMatchMaxLen) then begin - result:=false; - exit; - end; -_numFastBytes := numFastBytes; -result:=true; -end; - -function TLZMAEncoder.SetMatchFinder(const matchFinderIndex:integer):boolean; -var matchFinderIndexPrev:integer; -begin -if (matchFinderIndex < 0) or (matchFinderIndex > 2) then begin - result:=false; - exit; - end; -matchFinderIndexPrev := _matchFinderType; -_matchFinderType := matchFinderIndex; -if (_matchFinder <> nil) and (matchFinderIndexPrev <> _matchFinderType) then begin - _dictionarySizePrev := -1; - _matchFinder := nil; - end; -result:=true; -end; - -function TLZMAEncoder.SetLcLpPb(const lc,lp,pb:integer):boolean; -begin -if (lp < 0) or (lp > ULZMABase.kNumLitPosStatesBitsEncodingMax) or - (lc < 0) or (lc > ULZMABase.kNumLitContextBitsMax) or - (pb < 0) or (pb > ULZMABase.kNumPosStatesBitsEncodingMax) then begin - result:=false; - exit; - end; -_numLiteralPosStateBits := lp; -_numLiteralContextBits := lc; -_posStateBits := pb; -_posStateMask := ((1) shl _posStateBits) - 1; -result:=true; -end; - -procedure TLZMAEncoder.SetEndMarkerMode(const endMarkerMode:boolean); -begin -_writeEndMark := endMarkerMode; -end; - -procedure TLZMAEncoder2._Init; -begin -URangeEncoder.InitBitModels(m_Encoders); -end; - -procedure TLZMAEncoder2.Encode(const rangeEncoder:PRangeEncoder;const symbol:byte); -var context:integer; - bit,i:integer; -begin -context := 1; -for i := 7 downto 0 do begin - bit := ((symbol shr i) and 1); - rangeEncoder.Encode(m_Encoders, context, bit); - context := (context shl 1) or bit; - end; -end; - -procedure TLZMAEncoder2.EncodeMatched(const rangeEncoder:PRangeEncoder;const matchByte,symbol:byte); -var context,i,bit,state,matchbit:integer; - same:boolean; -begin -context := 1; -same := true; -for i := 7 downto 0 do begin - bit := ((symbol shr i) and 1); - state := context; - if same then begin - matchBit := ((matchByte shr i) and 1); - state :=state + ((1 + matchBit) shl 8); - same := (matchBit = bit); - end; - rangeEncoder.Encode(m_Encoders, state, bit); - context := (context shl 1) or bit; - end; -end; - -function TLZMAEncoder2.GetPrice(const matchMode:boolean;const matchByte,symbol:byte):integer; -var price,context,i,matchbit,bit:integer; -begin -price := 0; -context := 1; -i := 7; -if matchMode then - while i>=0 do begin - matchBit := (matchByte shr i) and 1; - bit := (symbol shr i) and 1; - price := price + RangeEncoder.GetPrice(m_Encoders[((1 + matchBit) shl 8) + context], bit); - context := (context shl 1) or bit; - if (matchBit <> bit) then begin - dec(i); - break; - end; - dec(i); - end; -while i>=0 do begin - bit := (symbol shr i) and 1; - price := price + RangeEncoder.GetPrice(m_Encoders[context], bit); - context := (context shl 1) or bit; - dec(i); - end; -result:=price; -end; - -procedure TLZMALiteralEncoder._Create(const numPosBits,numPrevBits:integer); -var numstates:integer; - i:integer; -begin -if (length(m_Coders)<>0) and (m_NumPrevBits = numPrevBits) and (m_NumPosBits = numPosBits) then - exit; -m_NumPosBits := numPosBits; -m_PosMask := (1 shl numPosBits) - 1; -m_NumPrevBits := numPrevBits; -numStates := 1 shl (m_NumPrevBits + m_NumPosBits); -setlength(m_coders,numStates); -for i := 0 to numStates-1 do - New(m_Coders[i],Create); -end; - -destructor TLZMALiteralEncoder.Destroy; -var i:integer; -begin -for i:=low(m_Coders) to high(m_Coders) do - if m_Coders[i]<>nil then m_Coders[i].Free; -inherited; -end; - -procedure TLZMALiteralEncoder._Init; -var numstates,i:integer; -begin -numStates := 1 shl (m_NumPrevBits + m_NumPosBits); -for i := 0 to numStates-1 do - m_Coders[i]._Init; -end; - -function TLZMALiteralEncoder.GetSubCoder(const pos:integer;const prevByte:byte):PLZMAEncoder2; -begin -result:=m_Coders[((pos and m_PosMask) shl m_NumPrevBits) + ((prevByte and $FF) shr (8 - m_NumPrevBits))]; -end; - -constructor TLZMALenEncoder.Create; -var posState:integer; -begin -New(_highCoder, Create(ULZMABase.kNumHighLenBits)); -for posState := 0 to ULZMABase.kNumPosStatesEncodingMax-1 do begin - New(_lowCoder[posState], Create(ULZMABase.kNumLowLenBits)); - New(_midCoder[posState], Create(ULZMABase.kNumMidLenBits)); - end; -end; - -destructor TLZMALenEncoder.Destroy; -var posState:integer; -begin -_highCoder.Free; -for posState := 0 to ULZMABase.kNumPosStatesEncodingMax-1 do begin - _lowCoder[posState].Free; - _midCoder[posState].Free; - end; -inherited; -end; - -procedure TLZMALenEncoder._Init(const numPosStates:integer); -var posState:integer; -begin -URangeEncoder.InitBitModels(_choice); - -for posState := 0 to numPosStates -1 do begin - _lowCoder[posState]._Init; - _midCoder[posState]._Init; - end; -_highCoder._Init; -end; - -procedure TLZMALenEncoder.Encode(const rangeEncoder:PRangeEncoder;symbol:integer;const posState:integer); -begin -if (symbol < ULZMABase.kNumLowLenSymbols) then begin - rangeEncoder.Encode(_choice, 0, 0); - _lowCoder[posState].Encode(rangeEncoder, symbol); - end else begin - symbol := symbol - ULZMABase.kNumLowLenSymbols; - rangeEncoder.Encode(_choice, 0, 1); - if symbol < ULZMABase.kNumMidLenSymbols then begin - rangeEncoder.Encode(_choice, 1, 0); - _midCoder[posState].Encode(rangeEncoder, symbol); - end else begin - rangeEncoder.Encode(_choice, 1, 1); - _highCoder.Encode(rangeEncoder, symbol - ULZMABase.kNumMidLenSymbols); - end; - end; -end; - -procedure TLZMALenEncoder.SetPrices(const posState,numSymbols:integer;var prices:array of integer;const st:integer); -var a0,a1,b0,b1,i:integer; -begin -a0 := RangeEncoder.GetPrice0(_choice[0]); -a1 := RangeEncoder.GetPrice1(_choice[0]); -b0 := a1 + RangeEncoder.GetPrice0(_choice[1]); -b1 := a1 + RangeEncoder.GetPrice1(_choice[1]); -i:=0; -while i= numSymbols then - exit; - prices[st + i] := a0 + _lowCoder[posState].GetPrice(i); - inc(i); - end; -while i < ULZMABase.kNumLowLenSymbols + ULZMABase.kNumMidLenSymbols do begin - if i >= numSymbols then - exit; - prices[st + i] := b0 + _midCoder[posState].GetPrice(i - ULZMABase.kNumLowLenSymbols); - inc(i); - end; -while i < numSymbols do begin - prices[st + i] := b1 + _highCoder.GetPrice(i - ULZMABase.kNumLowLenSymbols - ULZMABase.kNumMidLenSymbols); - inc(i); - end; -end; - -procedure TLZMALenPriceTableEncoder.SetTableSize(const tableSize:integer); -begin -_tableSize := tableSize; -end; - -function TLZMALenPriceTableEncoder.GetPrice(const symbol,posState:integer):integer; -begin -result:=_prices[posState * ULZMABase.kNumLenSymbols + symbol] -end; - -procedure TLZMALenPriceTableEncoder.UpdateTable(const posState:integer); -begin -SetPrices(posState, _tableSize, _prices, posState * ULZMABase.kNumLenSymbols); -_counters[posState] := _tableSize; -end; - -procedure TLZMALenPriceTableEncoder.UpdateTables(const numPosStates:integer); -var posState:integer; -begin -for posState := 0 to numPosStates -1 do - UpdateTable(posState); -end; - -procedure TLZMALenPriceTableEncoder.Encode(const rangeEncoder:PRangeEncoder;symbol:integer;const posState:integer); -begin -inherited Encode(rangeEncoder, symbol, posState); -dec(_counters[posState]); -if (_counters[posState] = 0) then - UpdateTable(posState); -end; - -procedure TLZMAOptimal.MakeAsChar; -begin -BackPrev := -1; -Prev1IsChar := false; -end; - -procedure TLZMAOptimal.MakeAsShortRep; -begin -BackPrev := 0; -Prev1IsChar := false; -end; - -function TLZMAOptimal.IsShortRep:boolean; -begin -result:=BackPrev = 0; -end; - -procedure TLZMAEncoder.DoProgress(const Action:TLZMAProgressAction;const Value:integer); -begin -if assigned(fonprogress) then - fonprogress(action,value); -end; - -end. diff --git a/Addons/ULZOutWindow.pas b/Addons/ULZOutWindow.pas deleted file mode 100644 index 2e87bd0..0000000 --- a/Addons/ULZOutWindow.pas +++ /dev/null @@ -1,107 +0,0 @@ -unit ULZOutWindow; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL; - -type PLZOutWindow = ^TLZOutWindow; - TLZOutWindow=object(TObj) - public - buffer: array of byte; - pos:integer; - windowSize:integer; - streamPos:integer; - stream:PStream; - procedure _Create(const AwindowSize:integer); - procedure SetStream(const Astream:PStream); - procedure ReleaseStream; - procedure _Init(const Asolid:boolean); - procedure Flush; - procedure CopyBlock(const Adistance:integer; Alen:integer); - procedure PutByte(const Ab:byte); - function GetByte(const Adistance:integer):byte; - end; - -implementation - -procedure TLZOutWindow._Create(const AwindowSize:integer); -begin -if (length(buffer)=0) or (self.windowSize <> AwindowSize) then - setlength(buffer,AwindowSize); -self.windowSize := AwindowSize; -pos := 0; -streamPos := 0; -end; - -procedure TLZOutWindow.SetStream(const Astream:PStream); -begin -ReleaseStream; -self.stream:=Astream; -end; - -procedure TLZOutWindow.ReleaseStream; -begin -flush; -self.stream:=nil; -end; - -procedure TLZOutWindow._Init(const Asolid:boolean); -begin -if not Asolid then begin - streamPos:=0; - Pos:=0; - end; -end; - -procedure TLZOutWindow.Flush; -var size:integer; -begin -size := pos - streamPos; -if (size = 0) then - exit; -stream.write(buffer[streamPos], size); -if (pos >= windowSize) then - pos := 0; -streamPos := pos; -end; - -procedure TLZOutWindow.CopyBlock(const Adistance:integer;Alen:integer); -var _pos:integer; -begin -_pos := self.pos - Adistance - 1; -if _pos < 0 then - _pos := _pos + windowSize; -while Alen<>0 do begin - if _pos >= windowSize then - _pos := 0; - buffer[self.pos] := buffer[_pos]; - inc(self.pos); - inc(_pos); - if self.pos >= windowSize then - Flush(); - dec(Alen); - end; -end; - -procedure TLZOutWindow.PutByte(const Ab:byte); -begin -buffer[pos] := Ab; -inc(pos); -if (pos >= windowSize) then - Flush(); -end; - -function TLZOutWindow.GetByte(const Adistance:integer):byte; -var _pos:integer; -begin -_pos := self.pos - Adistance - 1; -if (_pos < 0) then - _pos := _pos + windowSize; -result:=buffer[_pos]; -end; - -end. diff --git a/Addons/URangeDecoder.pas b/Addons/URangeDecoder.pas deleted file mode 100644 index 09fe828..0000000 --- a/Addons/URangeDecoder.pas +++ /dev/null @@ -1,100 +0,0 @@ -unit URangeDecoder; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL,ULZMACommon; - -type PRangeDecoder = ^TRangeDecoder; - TRangeDecoder=object(TObj) - public - Range,Code:integer; - Stream:PStream; - procedure SetStream(const AStream:PStream); - procedure ReleaseStream; - procedure _Init; - function DecodeDirectBits(const AnumTotalBits:integer):integer; - function DecodeBit(var Aprobs: array of smallint;const Aindex:integer):integer; - end; - -procedure InitBitModels(var Aprobs: array of smallint); - -implementation - -const kTopMask = not ((1 shl 24) - 1); - kNumBitModelTotalBits = 11; - kBitModelTotal = (1 shl kNumBitModelTotalBits); - kNumMoveBits = 5; - -procedure TRangeDecoder.SetStream(const AStream:PStream); -begin -self.Stream:=AStream; -end; - -procedure TRangeDecoder.ReleaseStream; -begin -stream:=nil; -end; - -procedure TRangeDecoder._Init; -var i:integer; -begin -code:=0; -Range:=-1; -for i:=0 to 4 do begin - code:=(code shl 8) or byte(ReadByte(stream)); - end; -end; - -function TRangeDecoder.DecodeDirectBits(const AnumTotalBits:integer):integer; -var i,t:integer; -begin -result:=0; -for i := AnumTotalBits downto 1 do begin - range:=range shr 1; - t := ((Code - Range) shr 31); - Code := Code - Range and (t - 1); - result := (result shl 1) or (1 - t); - if ((Range and kTopMask) = 0) then begin - Code := (Code shl 8) or ReadByte(stream); - Range := Range shl 8; - end; - end; -end; - -function TRangeDecoder.DecodeBit(var Aprobs: array of smallint;const Aindex:integer):integer; -var prob,newbound:integer; -begin -prob:=Aprobs[Aindex]; -newbound:=(Range shr kNumBitModelTotalBits) * prob; -if (integer((integer(Code) xor integer($80000000))) < integer((integer(newBound) xor integer($80000000)))) then begin - Range := newBound; - Aprobs[Aindex] := (prob + ((kBitModelTotal - prob) shr kNumMoveBits)); - if ((Range and kTopMask) = 0) then begin - Code := (Code shl 8) or ReadByte(stream); - Range := Range shl 8; - end; - result:=0; - end else begin - Range := Range - newBound; - Code := Code - newBound; - Aprobs[Aindex] := (prob - ((prob) shr kNumMoveBits)); - if ((Range and kTopMask) = 0) then begin - Code := (Code shl 8) or ReadByte(stream); - Range := Range shl 8; - end; - result:=1; - end; -end; - -procedure InitBitModels(var Aprobs: array of smallint); -var i:integer; -begin -for i:=0 to length(Aprobs)-1 do - Aprobs[i] := kBitModelTotal shr 1; -end; - -end. diff --git a/Addons/URangeEncoder.pas b/Addons/URangeEncoder.pas deleted file mode 100644 index 952a68c..0000000 --- a/Addons/URangeEncoder.pas +++ /dev/null @@ -1,175 +0,0 @@ -unit URangeEncoder; - -{$IFDEF FPC} -{$MODE Delphi} -{$ENDIF} - -interface - -uses KOL,ULZMACommon; - -const kNumBitPriceShiftBits = 6; - kTopMask = not ((1 shl 24) - 1); - kNumBitModelTotalBits = 11; - kBitModelTotal = (1 shl kNumBitModelTotalBits); - kNumMoveBits = 5; - kNumMoveReducingBits = 2; - -type PRangeEncoder = ^TRangeEncoder; - TRangeEncoder=object(TObj) - private - ProbPrices: array [0..kBitModelTotal shr kNumMoveReducingBits-1] of integer; - public - Stream:PStream; - Low,Position:int64; - Range,cacheSize,cache:integer; - procedure SetStream(const Astream:PStream); - procedure ReleaseStream; - procedure _Init; - procedure FlushData; - procedure FlushStream; - procedure ShiftLow; - procedure EncodeDirectBits(const v,AnumTotalBits:integer); - function GetProcessedSizeAdd:int64; - procedure Encode(var Aprobs: array of smallint;const Aindex,Asymbol:integer); - constructor Create; - function GetPrice(const AProb,Asymbol:integer):integer; - function GetPrice0(const AProb:integer):integer; - function GetPrice1(const AProb:integer):integer; - end; - -var RangeEncoder:PRangeEncoder; - -procedure InitBitModels(var probs:array of smallint); - -implementation - -procedure TRangeEncoder.SetStream(const Astream:PStream); -begin -self.Stream:=AStream; -end; - -procedure TRangeEncoder.ReleaseStream; -begin -stream:=nil; -end; - -procedure TRangeEncoder._Init; -begin -position := 0; -Low := 0; -Range := -1; -cacheSize := 1; -cache := 0; -end; - -procedure TRangeEncoder.FlushData; -var i:integer; -begin -for i:=0 to 4 do - ShiftLow(); -end; - -procedure TRangeEncoder.FlushStream; -begin -//stream.flush; -end; - -procedure TRangeEncoder.ShiftLow; -var LowHi:integer; - temp:integer; -begin -LowHi := (Low shr 32); -if (LowHi <> 0) or (Low < int64($FF000000)) then begin - position := position + cacheSize; - temp := cache; - repeat - WriteByte(stream,temp + LowHi); - temp := $FF; - dec(cacheSize); - until(cacheSize = 0); - cache := (Low shr 24); - end; -inc(cacheSize); -Low := (Low and integer($FFFFFF)) shl 8; -end; - -procedure TRangeEncoder.EncodeDirectBits(const v,AnumTotalBits:integer); -var i:integer; -begin -for i := AnumTotalBits - 1 downto 0 do begin - Range := Range shr 1; - if (((v shr i) and 1) = 1) then - Low := Low + Range; - if ((Range and kTopMask) = 0) then begin - Range := range shl 8; - ShiftLow; - end; - end; -end; - -function TRangeEncoder.GetProcessedSizeAdd:int64; -begin -result:=cacheSize + position + 4; -end; - -procedure InitBitModels(var probs:array of smallint); -var i:integer; -begin -for i := 0 to length(probs) -1 do - probs[i] := kBitModelTotal shr 1; -end; - -procedure TRangeEncoder.Encode(var Aprobs: array of smallint;const Aindex,Asymbol:integer); -var prob,newbound:integer; -begin -prob := Aprobs[Aindex]; -newBound := (Range shr kNumBitModelTotalBits) * prob; -if (Asymbol = 0) then begin - Range := newBound; - Aprobs[Aindex] := (prob + ((kBitModelTotal - prob) shr kNumMoveBits)); - end else begin - Low := Low + (newBound and int64($FFFFFFFF)); - Range := Range - newBound; - Aprobs[Aindex] := (prob - ((prob) shr kNumMoveBits)); - end; -if ((Range and kTopMask) = 0) then begin - Range := Range shl 8; - ShiftLow; - end; -end; - -constructor TRangeEncoder.Create; -var kNumBits:integer; - i,j,start,_end:integer; -begin -kNumBits := (kNumBitModelTotalBits - kNumMoveReducingBits); -for i := kNumBits - 1 downto 0 do begin - start := 1 shl (kNumBits - i - 1); - _end := 1 shl (kNumBits - i); - for j := start to _end -1 do - ProbPrices[j] := (i shl kNumBitPriceShiftBits) + - (((_end - j) shl kNumBitPriceShiftBits) shr (kNumBits - i - 1)); - end; -end; - -function TRangeEncoder.GetPrice(const AProb,Asymbol:integer):integer; -begin -result:=ProbPrices[(((AProb - Asymbol) xor ((-Asymbol))) and (kBitModelTotal - 1)) shr kNumMoveReducingBits]; -end; - -function TRangeEncoder.GetPrice0(const AProb:integer):integer; -begin -result:= ProbPrices[AProb shr kNumMoveReducingBits]; -end; - -function TRangeEncoder.GetPrice1(const AProb:integer):integer; -begin -result:= ProbPrices[(kBitModelTotal - AProb) shr kNumMoveReducingBits]; -end; - -initialization -New(RangeEncoder, Create); -finalization -RangeEncoder.Free; -end. diff --git a/Addons/USrv.pas b/Addons/USrv.pas deleted file mode 100644 index b968895..0000000 --- a/Addons/USrv.pas +++ /dev/null @@ -1,301 +0,0 @@ -Unit USrv; - -interface -uses Windows, Classes, Graphics, Controls, Messages, Dialogs, - SysUtils; - -const WM_GETIMAGE = WM_USER + $0429; - -function BitmapToRegion(Bitmap: TBitmap): HRGN; -function CopyToBitmap(Control: TControl; Bitmap: TBitmap; Anyway: boolean): boolean; -procedure CopyParentImage(Control: TControl; Dest: TCanvas); -procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect; - dwROP: dword); overload; -procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer; - dwROP: dword); overload; -procedure AjustBitmap(const M: TBitmap; S, C: TColor); -procedure FadeBitmap(const M: TBitmap; C: TColor; D: byte); -function IncColor(C: TColor; D: integer): TColor; - -implementation - -function BitmapToRegion(Bitmap: TBitmap): HRGN; -var - X, Y: Integer; - XStart: Integer; - TransC: TColor; - R: HRGN; -begin - Result := 0; - with Bitmap do begin - TransC := Canvas.Pixels[0, 0]; - for Y := 0 to Height - 1 do begin - X := 0; - while X < Width do begin - while (X < Width) and (Canvas.Pixels[X, Y] = TransC) do Inc(X); - if X >= Width then Break; - XStart := X; - while (X < Width) and (Canvas.Pixels[X, Y] <> TransC) do Inc(X); - R := CreateRectRgn(XStart, Y, X, Y + 1); - if Result = 0 then Result := R - else begin - CombineRgn(Result, Result, R, RGN_OR); - DeleteObject(R); - end; - end; - end; - end; -end; - -function CopyToBitmap; -var x, y: integer; -begin - Result := False; - if Control = nil then exit; - x := BitMap.Width - 2; - y := BitMap.Height - 2; - if (Anyway) or - (x + 2 <> Control.Width) or - (y + 2 <> Control.Height) or - (BitMap.Canvas.Pixels[x, y] = $FFFFFF) or - (BitMap.Canvas.Pixels[x, y] = $000000) then begin - BitMap.Width := Control.Width; - BitMap.Height := Control.Height; - CopyParentImage(Control, BitMap.Canvas); - Result := True; - end; -end; - -type - TParentControl = class(TWinControl); - -procedure CopyParentImage(Control: TControl; Dest: TCanvas); -var - I, Count, X, Y, SaveIndex: Integer; - DC: HDC; - R, SelfR, CtlR: TRect; -begin - if (Control = nil) or (Control.Parent = nil) then Exit; - Count := Control.Parent.ControlCount; - DC := Dest.Handle; - with Control.Parent do ControlState := ControlState + [csPaintCopy]; - try - with Control do begin - SelfR := Bounds(Left, Top, Width, Height); - X := -Left; Y := -Top; - end; - { Copy parent control image } - SaveIndex := SaveDC(DC); - try - if TParentControl(Control.Parent).Perform( - WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin - SetViewportOrgEx(DC, X, Y, nil); - IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth, - Control.Parent.ClientHeight); - with TParentControl(Control.Parent) do begin - Perform(WM_ERASEBKGND, DC, 0); - PaintWindow(DC); - end; - end; - finally - RestoreDC(DC, SaveIndex); - end; - { Copy images of graphic controls } - for I := 0 to Count - 1 do begin - if Control.Parent.Controls[I] = Control then continue - else if (Control.Parent.Controls[I] <> nil) and - (Control.Parent.Controls[I] is TGraphicControl) then - begin - with TGraphicControl(Control.Parent.Controls[I]) do begin - CtlR := Bounds(Left, Top, Width, Height); - if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin - ControlState := ControlState + [csPaintCopy]; - SaveIndex := SaveDC(DC); - try - if Perform( - WM_GETIMAGE, DC, integer(@SelfR)) <> $29041961 then begin -{ SaveIndex := SaveDC(DC);} - SetViewportOrgEx(DC, Left + X, Top + Y, nil); - IntersectClipRect(DC, 0, 0, Width, Height); - Perform(WM_PAINT, DC, 0); - end; - finally - RestoreDC(DC, SaveIndex); - ControlState := ControlState - [csPaintCopy]; - end; - end; - end; - end; - end; - finally - with Control.Parent do ControlState := ControlState - [csPaintCopy]; - end; -end; - -procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; r: TRect; - dwROP: dword); overload; -begin - RestoreImage(DestDC, SrcBitmap, r.Left, r.Top, - r.Right - r.Left, r.Bottom - r.Top, dwROP); -end; - -procedure RestoreImage(DestDC: HDC; SrcBitmap: TBitmap; l, t, w, h: integer; - dwROP: dword); overload; -var x, y: integer; -begin - x := l + w div 2; - y := t + h div 2; - if (SrcBitmap.Canvas.Pixels[x, y] <> $FFFFFF) and - (SrcBitMap.Canvas.Pixels[x, y] <> $000000) then begin - x := l; - y := t; - if y + h > SrcBitMap.Height then begin - y := SrcBitMap.Height - h; - end; - bitblt(DestDC, l, t, w, h, - SrcBitMap.Canvas.Handle, x, y, dwROP); - end; -end; - - procedure SplitColor(C: TColor; var r, g, b: integer); - begin - b := (c and $FF0000) shr 16; - g := (c and $00FF00) shr 08; - r := (c and $0000FF) shr 00; - end; - -procedure AjustBitmap; -var i, j: integer; - t: TBitmap; - r, - g, - b, - r2, - g2, - b2: integer; - p: PRGBTriple; - - function CalcColor(c1, c2, c3: integer): integer; - begin - if c1 = c3 then begin - Result := c2; - exit; - end; - - if c1 = 0 then begin - Result := 0; - exit; - end; - -{ Result := 255 * c1 div c3 - c1 * (255 - c1) * (255 - c2) div c3 div (255 - c3); - exit;} - - Result := c1 * c2 div c3; - if c2 = 0 then Result := c1 * 150 div 255; - if Result > 255 then Result := 255; - if Result < 50 then Result := Result + 50; -{ exit; - a := trunc(x1 * 3); - a := c1 * (255 - c1) * c2 * (255 - c2) div c3 div (255 - c3); - a := 255 * 255 - 4 * a; - try - x1 := Trunc((255 - sqrt(a)) / 2); - x2 := Trunc((255 + sqrt(a)) / 2); - if x1 > x2 then Result := Trunc(x1) - else Result := Trunc(x2); - except - Result := 0; - end;} - end; - -begin - if s = c then exit; - if m.Width = 0 then exit; - if m.Height = 0 then exit; - t := TBitmap.Create; - m.PixelFormat := pf24bit; - t.Assign(m); - SplitColor(ColorToRGB(s), r, g, b); - if r = 0 then r := 1; - if g = 0 then g := 1; - if b = 0 then b := 1; - SplitColor(ColorToRGB(c), r2, g2, b2); - for j := 0 to t.Height - 1 do begin - p := t.scanline[j]; - for i := 0 to t.Width - 1 do begin - p.rgbtRed := CalcColor(p.rgbtRed, r2, r); - p.rgbtGreen := CalcColor(p.rgbtGreen, g2, g); - p.rgbtBlue := CalcColor(p.rgbtBlue, b2, b); - inc(p); - end; - end; - m.Assign(t); - t.Free; -end; - -procedure FadeBitmap; -var i, j: integer; - t: TBitmap; - r, - g, - b: integer; - p: PRGBTriple; - - function CalcColor(o: byte; c: byte; b: byte): byte; - var d: byte; - begin - Result := c; - if o > c then begin - d := $FF - c; - if d > b then d := b; - Result := c + c * d div 255; - end else - if o < c then begin - d := c; - if d > b then d := b; - Result := c - c * d div 255; - end; - end; - -begin - if m.Width = 0 then exit; - if m.Height = 0 then exit; - t := TBitmap.Create; - m.PixelFormat := pf24bit; - t.Assign(m); - SplitColor(ColorToRGB(c), r, g, b); - if r = 0 then r := 1; - if g = 0 then g := 1; - if b = 0 then b := 1; - for j := 0 to t.Height - 1 do begin - p := t.scanline[j]; - for i := 0 to t.Width - 1 do begin - p.rgbtRed := CalcColor(p.rgbtRed, r, d); - p.rgbtGreen := CalcColor(p.rgbtGreen, g, d); - p.rgbtBlue := CalcColor(p.rgbtBlue, b, d); - inc(p); - end; - end; - m.Assign(t); - t.Free; -end; - -function IncColor; -var T: TColor; - P: PRGBTriple; -begin - T := ColorToRGB(C); - p := @T; - if D > 0 then begin - if p.rgbtBlue < 255 - D then p.rgbtBlue := p.rgbtBlue + D else p.rgbtBlue := 255; - if p.rgbtRed < 255 - D then p.rgbtRed := p.rgbtRed + D else p.rgbtRed := 255; - if p.rgbtGreen < 255 - D then p.rgbtGreen := p.rgbtGreen + D else p.rgbtGreen := 255; - end else begin - if p.rgbtBlue > D then p.rgbtBlue := p.rgbtBlue - D else p.rgbtBlue := 000; - if p.rgbtRed > D then p.rgbtRed := p.rgbtRed - D else p.rgbtRed := 000; - if p.rgbtGreen > D then p.rgbtGreen := p.rgbtGreen - D else p.rgbtGreen := 000; - end; - Result := T; -end; - -end. diff --git a/Addons/UStr.pas b/Addons/UStr.pas deleted file mode 100644 index 37a30b2..0000000 --- a/Addons/UStr.pas +++ /dev/null @@ -1,258 +0,0 @@ -unit UStr; - -interface - -function space ( n:integer):string ; -function replicate(ch:char; n:integer):string ; -function trim (str:string;c:boolean=false):string ; -function alike (a,b:string;var d, p: integer): boolean; -function center (str:string;n:integer):string ; -function UpSt ( s:string ):string; -function LoSt ( s:string ):string; -function lpad ( s:string;n:integer;c:char):string; -function rpad ( s:string;n:integer;c:char):string; -function addbackslash(p : string) : string; -function match (sm : string; var st: string) : boolean; -function lines (p, l, s : longint) : string; -function LoCase (c : char) : char; -function JustPathName(PathName : string) : string; -function JustFileName(PathName : string) : string; -function JustName (PathName : string) : string; -function CRC16 (s : string) : system.word; - -implementation - -function space; -var i : integer; -tempstr : string; - begin - tempstr:=''; - for i:=1 to n do tempstr:=tempstr+' '; - space:=tempstr; - end; - -function replicate; -var i : integer; -tempstr : string; - begin - tempstr:=''; - for i:=1 to n do tempstr:=tempstr+ch; - replicate:=tempstr; - end; - -function trim; -var i,j : integer; - s : string; -begin - trim := ''; - s := str; - if length(str) > 1 then begin - i := length(str); - j := 1; - while (j <= i) and (str[j] = ' ') do inc(j); - if j > i then begin - result := ''; - exit; - end; - while (str[i] = ' ') do dec(i); - s := copy(str, j, i - j + 1); - end; - if c and (length(s) > 3) then begin - repeat - i := pos(' ', s); - if i > 0 then begin - s := copy(s, 1, i - 1) + copy(s, i + 1, length(s) - i); - end; - until i = 0; - end; - if c then result := LoSt(s) - else result := s; -end; - -function alike; -var e, f: integer; -begin - result := false; - p := 0; - e := length(a); - f := length(b); - if e + f = 0 then begin - result := true; - d := 100; - exit; - end; - if (e = 0) or (f = 0) then begin - d := 0; - exit; - end; - while (p < e) and (p < f) do begin - inc(p); - if a[p] <> b[p] then begin - dec(p); - break; - end; - end; - d := 200 * p div (e + f); - if p * 2 > (e + f) div 2 then begin - result := true; - end; -end; - -function center; -var tempstr : string; - j : integer; - begin - j := n - length(trim(str)); - if j > 0 then tempstr := space(j - j div 2) + trim(str) + space(j div 2) - else tempstr := trim(str); - center := tempstr; - end; - -function UpSt; -var t : string; - i : integer; -begin - t := s; - for i := 1 to length(s) do t[i] := UpCase(s[i]); - UpSt := t; -end; - -function LoSt; -var t : string; - i : integer; -begin - t := s; - for i := 1 to length(s) do t[i] := LoCase(s[i]); - LoSt := t; -end; - -function lpad; -begin - lpad := replicate(c, n - length(s)) + s; -end; - -function rpad; -begin - rpad := s + replicate(c, n - length(s)); -end; - - function addbackslash; - begin - if length(p) > 0 then - if p[length(p)] = '\' then addbackslash := p - else addbackslash := p + '\' - else addbackslash := p; - end; - -function match(sm : string; var st: string) : boolean; -var p : integer; - _sm, - _st : string; -begin - match := false; - if (length(sm) > 0) and (length(st) > 0) then begin - _sm := UpSt(sm); - _st := UpSt(st); - while pos(_sm, _st) > 0 do begin - match := true; - p := pos(_sm, _st); - _st := copy(_st, 1, p - 1) + copy(_st, p + length(_sm), 250); - st := copy( st, 1, p - 1) + copy( st, p + length( sm), 250); - end; - end; -end; - -function lines; -var o : string; - i : longint; - n : longint; -begin - if l > 0 then begin - i := p * s div l; - n := p * s * 2 div l; - o := replicate('Û', i); - if n > i * 2 then o := o + 'Ý'; - lines := o + space(s - length(o)); - end else lines := ''; -end; - -function LoCase; -var t : char; -begin - if (c >= 'A') and (c <= 'Z') then t := chr(ord(c) + 32) - else t := c; - LoCase := t; -end; - - function JustPathname(PathName : string) : string; - {-Return just the drive:directory portion of a pathname} - var - I : Word; - begin - I := Succ(Word(Length(PathName))); - repeat - Dec(I); - until (PathName[I] in ['\',':',#0]) or (I = 1); - - if I = 1 then - {Had no drive or directory name} - JustPathname := '' - else if I = 1 then - {Either the root directory of default drive or invalid pathname} - JustPathname := PathName[1] - else if (PathName[I] = '\') then begin - if PathName[Pred(I)] = ':' then - {Root directory of a drive, leave trailing backslash} - JustPathname := Copy(PathName, 1, I) - else - {Subdirectory, remove the trailing backslash} - JustPathname := Copy(PathName, 1, Pred(I)); - end else - {Either the default directory of a drive or invalid pathname} - JustPathname := Copy(PathName, 1, I); - end; - - function JustFilename(PathName : string) : string; - {-Return just the filename of a pathname} - var - I : Word; - begin - I := Succ(Word(Length(PathName))); - repeat - Dec(I); - until (I = 0) or (PathName[I] in ['\', ':', #0]); - JustFilename := Copy(PathName, Succ(I), 64); - end; - - function JustName(PathName : string) : string; - {-Return just the name (no extension, no path) of a pathname} - var - DotPos : Byte; - begin - PathName := JustFileName(PathName); - DotPos := Pos('.', PathName); - if DotPos > 0 then - PathName := Copy(PathName, 1, DotPos-1); - JustName := PathName; - end; - - -function CRC16(s : string) : system.word; { By Kevin Cooney } -var - crc : longint; - t,r : byte; -begin - crc := 0; - for t := 1 to length(s) do - begin - crc := (crc xor (ord(s[t]) shl 8)); - for r := 1 to 8 do - if (crc and $8000)>0 then - crc := ((crc shl 1) xor $1021) - else - crc := (crc shl 1); - end; - CRC16 := (crc and $FFFF); -end; - -end. diff --git a/Addons/UWrd.pas b/Addons/UWrd.pas deleted file mode 100644 index 9fdf6ce..0000000 --- a/Addons/UWrd.pas +++ /dev/null @@ -1,101 +0,0 @@ -unit UWrd; - -interface - -function words (str:string;d:char ):integer; -function wordn (str:string;d:char;n:integer):string ; -function wordd (str:string;d:char;n:integer):string ; -function wordp (str:string;d:char;n:integer):integer; -function wordi ( wrd,str:string;d:cHar):boolean; -function wordf (str:string;d:char;n:integer):string ; - -implementation - -function words; -var tempstr : string; - ins : boolean; - i,j : integer; -begin - tempstr := d + str + d; - ins := false; - j := 0; - for i := 1 to length(tempstr) do begin - if ins then - if tempstr[i] =d then ins:=false - else begin end - else - if tempstr[i]<>d then begin - inc(j);ins:=true; - end; - end; - words:=j; -end; - -function wordn; -var i,j:integer; -tempstr:string; -begin - i:=words(str, d); - if id do inc(j); - wordn:=copy(str,i,j-i); -end; - -function wordd; -var i,j:integer; - sss:string; -tempstr:string; -begin - i:=words(str, d); - if id do inc(j); - sss :=copy(str,1,i-1); - wordd:=sss+copy(str,j+1,length(tempstr)-j); -end; - -function wordp; -var i:integer; -begin - i:=words(str, d); - if i < n then begin - wordp := 0; - exit; - end; - i:=1; - while words(copy(str,1,i), d) 0) and (i < length(str)) then - wordf := copy(str, i, length(str) - i + 1); -end; - -end. diff --git a/Addons/reader.pas b/Addons/reader.pas deleted file mode 100644 index 0e8331e..0000000 --- a/Addons/reader.pas +++ /dev/null @@ -1,255 +0,0 @@ -unit reader; - -interface - -function compare(_ts, _ms : string) : boolean; -procedure setvar ( vn, vv : string); -function getvar ( vn : string) : string; -function parstr : string; -procedure setglo ( vn, vv : string); -function getglo ( vn : string) : string; -function parse ( vn : string; al : boolean) : string; -procedure freeglob; - -implementation - -uses UStr, Serv, UWrd; - -type - trec = record - name : string[12]; - valu : string[255]; - next : pointer; - end; - -var - fvar, - fglo : pointer; - vrec, - vglo, - rrec : ^trec; - v, - z : string; - -function compare; -label fail, succ; -var i, - j, - n : integer; - ts, - ms : string; - -procedure freelist; -begin - vrec := fvar; - while vrec <> nil do begin - rrec := vrec; - vrec := vrec^.next; - freemem(rrec, sizeof(trec)); - end; - fvar := nil; -end; - -begin - ts := _ts; - ms := _ms; - i := 1; - j := 1; - compare := true; - freelist; - repeat - if (i > length(ts)) and (j > length(ms)) then goto succ; - if (i > length(ts)) or (j > length(ms)) then goto fail; - if ts[i] = ms[j] then begin - inc(i); - inc(j); - if j > length(ms) then goto succ; - end else - if ts[i] = '?' then begin - inc(i); - inc(j); - end else - if ts[i] = '*' then begin - inc(i); - if i > length(ts) then goto succ; - z := copy(ts, i, 255); - if pos('*', z) > 0 then z := copy(z, 1, pos('*', z) - 1); - if pos('?', z) > 0 then z := copy(z, 1, pos('?', z) - 1); - if pos('%', z) > 0 then z := copy(z, 1, pos('%', z) - 1); - while (j <= length(ms)) and (copy(ms, j, length(z)) <> z) do begin - while (j < length(ms)) and (ms[j] <> ts[i]) do inc(j); - if j > length(ms) then goto fail; - if copy(ms, j, length(z)) <> z then inc(j); - end; - end else - if ts[i] = '%' then begin - inc(i); - n := i; - while (i <= length(ts)) and (ts[i] <> '%') do inc(i); - if i > length(ts) then goto fail; - v := copy(ts, n, i - n); - v := upst(v); - inc(i); - n := j; - if i <= length(ts) then begin - while (j <= length(ms)) and (ms[j] <> ts[i]) do inc(j); - if j > length(ms) then goto fail; - end else begin - j := length(ms) + 1; - end; - z := copy(ms, n, j - n); - if fvar = nil then begin - getmem(fvar, sizeof(trec)); - vrec := fvar; - end else begin - getmem(vrec^.next, sizeof(trec)); - vrec := vrec^.next; - end; - fillchar(vrec^, sizeof(trec), #0); - vrec^.name := v; - vrec^.valu := z; - if fglo = nil then begin - getmem(fglo, sizeof(trec)); - vglo := fglo; - rrec := fglo; - fillchar(vglo^, sizeof(trec), #0); - end else begin - rrec := fglo; - while (rrec <> nil) and (rrec^.name <> v) do begin - vglo := rrec; - rrec := rrec^.next; - end; - if rrec = nil then begin - getmem(vglo^.next, sizeof(trec)); - vglo := vglo^.next; - rrec := vglo; - fillchar(vglo^, sizeof(trec), #0); - end; - end; - rrec^.name := v; - rrec^.valu := z; - end else begin - if (i > 1) and (j > i) then - if compare(ts, copy(ms, j, length(ms) - j + 1)) then goto succ - else goto fail - else goto fail; - end; - until false; -fail: - compare := false; - freelist; - exit; -succ: - exit; -end; - -procedure setvar; -begin - vglo := fvar; - while vglo <> Nil do begin - if vglo^.name = UpSt(vn) then break; - vglo := vglo^.next; - end; - if vglo = Nil then vglo := NewEList(fvar, sizeof(trec), false); - vglo^.name := UpSt(vn); - vglo^.valu := vv; -end; - -function getvar; -var - tv : string; -begin - getvar := ''; - vrec := fvar; - tv := vn; - tv := upst(tv); - while vrec <> nil do begin - if vrec^.name = tv then begin - getvar := vrec^.valu; - exit; - end; - vrec := vrec^.next; - end; -end; - -procedure setglo; -begin - vglo := fglo; - while vglo <> Nil do begin - if vglo^.name = UpSt(vn) then break; - vglo := vglo^.next; - end; - if vglo = Nil then vglo := NewEList(fglo, sizeof(trec), false); - vglo^.name := UpSt(vn); - vglo^.valu := vv; -end; - -function getglo; -var - tv : string; -begin - getglo := ''; - vglo := fglo; - tv := vn; - tv := upst(tv); - while vglo <> nil do begin - if vglo^.name = tv then begin - getglo := vglo^.valu; - exit; - end; - vglo := vglo^.next; - end; -end; - -procedure freeglob; -begin - vglo := fglo; - while vglo <> nil do begin - rrec := vglo; - vglo := vglo^.next; - freemem(rrec, sizeof(trec)); - end; - fglo := nil; -end; - -function parstr; -var - tv : string; -begin - tv := ''; - vrec := fvar; - while vrec <> nil do begin - tv := tv + ' ' + vrec^.valu; - vrec := vrec^.next; - end; - parstr := tv; -end; - -function parse; -var i, - p : integer; - s : string; - rs : string; -begin - s := ''; - i := 0; - repeat - inc(i); - rs := wordn(vn, '%', i + 1); - rs := getglo(rs); - s := s + wordn(vn, '%', i); - p := wordp(vn, '%', i + 1); - if p > 0 then begin - if al then s := copy(s, 1, p - 2); - if al then s := s + space(p - 2 - length(s)); - end; - s := s + rs; - if rs <> '' then inc(i); - until i > words(vn, '%'); - parse := s; -end; - -begin - fvar := nil; - fglo := nil; -end.