home *** CD-ROM | disk | FTP | other *** search
/ Point Programming 1 / PPROG1.ISO / pascal / swag / archives.swg / 0003_String Compression.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-05-28  |  2.7 KB  |  117 lines
  1. {You won't get that sort of compression from my routines, but here
  2. they are anyway.  When testing, you'll get best compression if you
  3. use English and longish Strings.
  4. }
  5. Unit Compress;
  6.  
  7. Interface
  8.  
  9. Const
  10.   CompressedStringArraySize = 500;  { err on the side of generosity }
  11.  
  12. Type
  13.   tCompressedStringArray = Array[1..CompressedStringArraySize] of Byte;
  14.  
  15. Function GetCompressedString(Arr : tCompressedStringArray) : String;
  16.  
  17. Procedure CompressString(st : String; Var Arr : tCompressedStringArray;
  18.                          Var len : Integer);
  19.   { converts st into a tCompressedStringArray of length len }
  20.  
  21. Implementation
  22.  
  23. Const
  24.   FreqChar : Array[4..14] of Char = 'etaonirshdl';
  25.   { can't be in [0..3] because two empty bits signify a space }
  26.  
  27.  
  28. Function GetCompressedString(Arr : tCompressedStringArray) : String;
  29. Var
  30.   Shift : Byte;
  31.   i : Integer;
  32.   ch : Char;
  33.   st : String;
  34.   b : Byte;
  35.  
  36.   Function GetHalfNibble : Byte;
  37.   begin
  38.     GetHalfNibble := (Arr[i] shr Shift) and 3;
  39.     if Shift = 0 then begin
  40.       Shift := 6;
  41.       inc(i);
  42.     end else dec(Shift,2);
  43.   end;
  44.  
  45. begin
  46.   st := '';
  47.   i := 1;
  48.   Shift := 6;
  49.   Repeat
  50.     b := GetHalfNibble;
  51.     if b = 0 then
  52.       ch := ' '
  53.     else begin
  54.       b := (b shl 2) or GetHalfNibble;
  55.       if b = $F then begin
  56.         b := GetHalfNibble shl 6;
  57.         b := b or GetHalfNibble shl 4;
  58.         b := b or GetHalfNibble shl 2;
  59.         b := b or GetHalfNibble;
  60.         ch := Char(b);
  61.       end else
  62.         ch := FreqChar[b];
  63.     end;
  64.     if ch <> #0 then st := st + ch;
  65.   Until ch = #0;
  66.   GetCompressedString := st;
  67. end;
  68.  
  69. Procedure CompressString(st : String; Var Arr : tCompressedStringArray;
  70.                          Var len : Integer);
  71. { converts st into a tCompressedStringArray of length len }
  72. Var
  73.   i : Integer;
  74.   Shift : Byte;
  75.  
  76.   Procedure OutHalfNibble(b : Byte);
  77.   begin
  78.     Arr[len] := Arr[len] or (b shl Shift);
  79.     if Shift = 0 then begin
  80.       Shift := 6;
  81.       inc(len);
  82.     end else dec(Shift,2);
  83.   end;
  84.  
  85.   Procedure OutChar(ch : Char);
  86.   Var
  87.     i : Byte;
  88.     bych : Byte Absolute ch;
  89.   begin
  90.     if ch = ' ' then
  91.       OutHalfNibble(0)
  92.     else begin
  93.       i := 4;
  94.       While (i<15) and (FreqChar[i]<>ch) do inc(i);
  95.       OutHalfNibble(i shr 2);
  96.       OutHalfNibble(i and 3);
  97.       if i = $F then begin
  98.         OutHalfNibble(bych shr 6);
  99.         OutHalfNibble((bych shr 4) and 3);
  100.         OutHalfNibble((bych shr 2) and 3);
  101.         OutHalfNibble(bych and 3);
  102.       end;
  103.     end;
  104.   end;
  105.  
  106. begin
  107.   len := 1;
  108.   Shift := 6;
  109.   fillChar(Arr,sizeof(Arr),0);
  110.   For i := 1 to length(st) do OutChar(st[i]);
  111.   OutChar(#0);  { end of compressed String signaled by #0 }
  112.   if Shift = 6
  113.     then dec(len);
  114. end;
  115.  
  116. end.
  117.