Some my thoughts about compress algorithm in NAV

Yaroslav_Gaponov

Hi All

This my simple single-pass compress algorithm. Of course it not very effective, but it working...

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.
  }
}