[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]

    {You won't get that sort of compression from my routines, but here
    they are anyway.  When testing, you'll get best compression if you
    use English and longish Strings.
    }
    Unit Compress;

    Interface

    Const
      CompressedStringArraySize = 500;  { err on the side of generosity }

    Type
      tCompressedStringArray = Array[1..CompressedStringArraySize] of Byte;

    Function GetCompressedString(Arr : tCompressedStringArray) : String;

    Procedure CompressString(st : String; Var Arr : tCompressedStringArray;
                             Var len : Integer);
      { converts st into a tCompressedStringArray of length len }

    Implementation

    Const
      FreqChar : Array[4..14] of Char = 'etaonirshdl';
      { can't be in [0..3] because two empty bits signify a space }

    Function GetCompressedString(Arr : tCompressedStringArray) : String;
    Var
      Shift : Byte;
      i : Integer;
      ch : Char;
      st : String;
      b : Byte;

      Function GetHalfNibble : Byte;
      begin
        GetHalfNibble := (Arr[i] shr Shift) and 3;
        if Shift = 0 then begin
          Shift := 6;
          inc(i);
        end else dec(Shift,2);
      end;

    begin
      st := '';
      i := 1;
      Shift := 6;
      Repeat
        b := GetHalfNibble;
        if b = 0 then
          ch := ' '
        else begin
          b := (b shl 2) or GetHalfNibble;
          if b = $F then begin
            b := GetHalfNibble shl 6;
            b := b or GetHalfNibble shl 4;
            b := b or GetHalfNibble shl 2;
            b := b or GetHalfNibble;
            ch := Char(b);
          end else
            ch := FreqChar[b];
        end;
        if ch <> #0 then st := st + ch;
      Until ch = #0;
      GetCompressedString := st;
    end;

    Procedure CompressString(st : String; Var Arr : tCompressedStringArray;
                             Var len : Integer);
    { converts st into a tCompressedStringArray of length len }
    Var
      i : Integer;
      Shift : Byte;

      Procedure OutHalfNibble(b : Byte);
      begin
        Arr[len] := Arr[len] or (b shl Shift);
        if Shift = 0 then begin
          Shift := 6;
          inc(len);
        end else dec(Shift,2);
      end;

      Procedure OutChar(ch : Char);
      Var
        i : Byte;
        bych : Byte Absolute ch;
      begin
        if ch = ' ' then
          OutHalfNibble(0)
        else begin
          i := 4;
          While (i<15) and (FreqChar[i]<>ch) do inc(i);
          OutHalfNibble(i shr 2);
          OutHalfNibble(i and 3);
          if i = $F then begin
            OutHalfNibble(bych shr 6);
            OutHalfNibble((bych shr 4) and 3);
            OutHalfNibble((bych shr 2) and 3);
            OutHalfNibble(bych and 3);
          end;
        end;
      end;

    begin
      len := 1;
      Shift := 6;
      fillChar(Arr,sizeof(Arr),0);
      For i := 1 to length(st) do OutChar(st[i]);
      OutChar(#0);  { end of compressed String signaled by #0 }
      if Shift = 6
        then dec(len);
    end;

    end.

[Back to ARCHIVES SWAG index] [Back to Main SWAG index] [Original]