OBJECT Codeunit 40000 Compress/Expand Mgt. { OBJECT-PROPERTIES { Date=21-10-08; Time=[11:41:34 ]; Modified=Yes; Version List=; } PROPERTIES { OnRun=BEGIN MESSAGE('Compress ration %1',compress('c:\\test.txt',STRSUBSTNO('c:\\test.arc'),TRUE)); expand('c:\\test.arc','c:\\test2.txt',TRUE); END; } CODE { VAR [email protected] : ARRAY [256] OF Text[1024]; [email protected] : Integer; [email protected] : Integer; [email protected] : BigInteger; [email protected] : Integer; [email protected] : Integer; LOCAL PROCEDURE [email protected]([email protected] : BigInteger;[email protected] : Integer) result : Text[64]; VAR [email protected] : Integer; BEGIN FOR i := 1 TO size DO BEGIN result := FORMAT(value MOD 2) + result; value := value DIV 2; END; END; LOCAL PROCEDURE [email protected]([email protected] : Text[64];[email protected] : Integer) result : BigInteger; VAR [email protected] : Integer; BEGIN FOR i := 1 TO size DO result := result * 2 + str2int(FORMAT(value[i])); END; LOCAL PROCEDURE [email protected]([email protected] : Text[250]) result : BigInteger; BEGIN EVALUATE(result,value); END; LOCAL PROCEDURE [email protected](); VAR [email protected] : Integer; BEGIN // some parameters which depended from file... _max_len := 11; _range_bits := 5; _max_limits := 1; _max_bits := 6; FOR i := 0 TO 255 DO abc[i + 1] := bit2str(i,8); // spead up some calcs _power2 := POWER(2,_range_bits-1); END; PROCEDURE [email protected]([email protected] : Text[250];[email protected] : Text[250];[email protected] : Boolean) Result : Decimal; VAR [email protected] : File; [email protected] : File; [email protected] : Char; [email protected] : Integer; [email protected] : Text[1024]; [email protected] : Char; [email protected] : BigInteger; [email protected] : Boolean; [email protected] : Dialog; [email protected] : Integer; BEGIN fin.TEXTMODE(FALSE); fin.OPEN(input); fout.TEXTMODE(FALSE); fout.CREATE(output); initialize(); IF progress THEN w.OPEN('[email protected]@@@@@@@@@@@@@@@@@@@@@@@@@@@\' + 'Ratio #2#########%'); WHILE fin.POS < fin.LEN DO BEGIN IF fin.POS > 0 THEN Result := ROUND(_result_len * 100 / fin.POS,0.01); IF progress THEN BEGIN w.UPDATE(1,ROUND(10000 * fin.POS / fin.LEN,1)); w.UPDATE(2,Result); END; fin.READ(ch); strbuf := strbuf + abc[ch + 1]; WHILE STRLEN(strbuf) >= 8 DO BEGIN chrbuf := str2bit(COPYSTR(strbuf,1,8),8); strbuf := DELSTR(strbuf,1,8); fout.WRITE(chrbuf); _result_len := _result_len + 1; END; IF STRLEN(abc[ch + 1]) > _max_bits THEN _limits := _limits + 1; chop := FALSE; FOR i := 0 TO 255 DO IF STRLEN(abc[i + 1]) > _max_len THEN chop := TRUE; IF chop THEN initialize() ELSE IF _limits > _max_limits THEN BEGIN _limits := 0; FOR i := 0 TO 255 DO IF (i >= (ch - _power2 + 1)) AND (i <= (ch + _power2)) THEN abc[i + 1] := '0' + bit2str(i - ch + _power2 - 1,_range_bits) ELSE abc[i + 1] := '1' + abc[i + 1]; END; END; IF STRLEN(strbuf) > 0 THEN BEGIN WHILE STRLEN(strbuf) < 8 DO strbuf := strbuf + '0'; chrbuf := str2bit(strbuf,8); fout.WRITE(chrbuf); _result_len := _result_len + 1; END; fin.CLOSE; fout.CLOSE; IF progress THEN w.CLOSE; END; PROCEDURE [email protected]([email protected] : Text[250];[email protected] : Text[250];[email protected] : Boolean); VAR [email protected] : File; [email protected] : File; [email protected] : Char; [email protected] : Integer; [email protected] : Text[1024]; [email protected] : Char; [email protected] : Integer; [email protected] : Boolean; [email protected] : Integer; [email protected] : Boolean; [email protected] : Dialog; [email protected] : Integer; BEGIN fin.TEXTMODE(FALSE); fin.OPEN(input); fout.TEXTMODE(FALSE); fout.CREATE(output); initialize(); IF progress THEN w.OPEN('[email protected]@@@@@@@@@@@@@@@@@@@@@@@@@@@'); WHILE fin.POS < fin.LEN DO BEGIN IF progress THEN w.UPDATE(1,ROUND(10000 * fin.POS / fin.LEN,1)); fin.READ(ch); strbuf := strbuf + bit2str(ch,8); REPEAT found := FALSE; FOR j := 1 TO STRLEN(strbuf) DO FOR i := 0 TO 255 DO IF abc[i + 1] = COPYSTR(strbuf,1,j) THEN BEGIN chrbuf := i; fout.WRITE(chrbuf); strbuf := DELSTR(strbuf,1,j); IF STRLEN(abc[chrbuf + 1]) > _max_bits THEN _limits := _limits + 1; chop := FALSE; FOR k := 0 TO 255 DO IF STRLEN(abc[k + 1]) > _max_len THEN chop := TRUE; IF chop THEN initialize() ELSE IF _limits > _max_limits THEN BEGIN _limits := 0; FOR k := 0 TO 255 DO IF (k >= (chrbuf - _power2 + 1)) AND (k <= (chrbuf + _power2)) THEN abc[k + 1] := '0' + bit2str(k - chrbuf + _power2 - 1,_range_bits) ELSE abc[k + 1] := '1' + abc[k + 1]; END; found := TRUE; END; UNTIL NOT found; END; fin.CLOSE; fout.CLOSE; IF progress THEN w.CLOSE; END; BEGIN { Compress/Extend Mgt. Codeunit - Yaroslav Gaponov ([email protected]) Single-pass compress algorithm. } END. } }