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

    {
    Hello Thomas,

    On 26.06.94 you wrote in area PASCAL to subject "Arithmetic compression":
    TW> But where can we get a discription of this compression method ??
      Michael  Barnsley, Lyman Hurd, "Fractal Image Compression", AK Peters,
      1993
      Mark Nelson, "The Data Compression Book", M&T Books, 1991
      Ian  Witten,  Radford  Neal,  John Cleary, "Arithmetic Coding for Data
      Compression", CACM, Vol. 30, No.6, 1987

      Below  is a small source from the 1st book, translated into Pascal and
      adopted  to  work  on  the uppercase alphabet to demonstrate the basic
      principles.
      For  a  simple  explanation, the program uses the letters of the input
      string  to "drive" the starting point through the real interval 0.0 ..
      1.0
      By  this process, every possible input string stops at a unique point,
      that  is:  a  point  (better: a small interval section) represents the
      whole  string.  To  _decode_  it, you have to reverse the process: you
      start  at  the  given  end point and apply the reverse transformation,
      noting  which intervals you are touching at your voyage throughout the
      computation.
      Due  to the restricted arithmetic resolution of any computer language,
      the  max.  length of a string will be restricted, too (try it out with
      TYPE   REAL=EXTENDED,  for  example);  this  happens  when  the  value
      "underflows" the computers precision. }

    {$A+,B-,D+,E+,F-,G-,I+,L+,N+,O-,P+,Q-,R+,S+,T-,V+,X+,Y+}
    {$M 16384,0,655360}
    PROGRAM arithmeticCompression;
    USES CRT;
    CONST charSet:STRING='ABCDEFGHIJKLMNOPQRSTUVWXYZ ';
          size=27; {=Length(charSet)}
          p:ARRAY[1..size] OF REAL=  (* found empirically *)
           (
            6.1858296469E-02,
            1.1055412402E-02,
            2.6991022453E-02,
            2.6030374520E-02,
            9.2418577127E-02,
            2.1864028512E-02,
            1.4977615842E-02,
            2.8410764564E-02,
            5.5247871050E-02,
            1.3985123226E-03,
            3.8001321554E-03,
            3.2593032914E-02,
            2.1919756707E-02,
            5.2434924064E-02,
            5.7837905257E-02,
            2.0364674693E-02,
            1.0031075103E-03,
            4.9730779744E-02,
            4.8056280170E-02,
            7.2072478498E-02,
            2.0948493879E-02,
            8.2477728625E-03,
            1.0299101184E-02,
            4.7873173243E-03,
            1.3613601926E-02,
            2.7067980437E-03,
            2.3933136781E-01
           );
    VAR   psum:ARRAY[1..size] OF REAL;

     FUNCTION Encode(CONST s:STRING):REAL;
     VAR i,po:INTEGER;
         offset,len:REAL;
     BEGIN
      offset:=0.0;
      len:=1.0;
      FOR i:=1 TO Length(s) DO
       BEGIN
        po:=POS(s[i],charSet);
        IF po<>0
         THEN BEGIN
               offset:=offset+len*psum[po];
               len:=len*p[po]
              END
         ELSE BEGIN
               WRITELN('only input chars ',charSet,' allowed!');
               Halt(1)
              END;
       END;
      Encode:=offset+len/2;
     END;

     FUNCTION Decode(x:REAL; n:BYTE):STRING;
     VAR i,j:INTEGER;
         s:STRING;
     BEGIN
      IF (x<0.0) OR (x>1.0)
       THEN BEGIN
             WRITELN('must lie in the range [0..1]');
             Halt(1)
            END;
      FOR i:=1 TO n DO
       BEGIN
        j:=size;
        WHILE x<psum[j] DO DEC(j);
        s[i]:=charSet[j];
        x:=x-psum[j];
        x:=x/p[j];
       END;
      s[0]:=CHR(n);
      Decode:=s
     END;

    CONST
         inp='ARITHMETIC';
    VAR
        r:REAL;
        i,j:INTEGER;

    BEGIN

     FOR i:=1 TO size DO
      BEGIN
       psum[i]:=0.0;
       FOR j:=1 TO i-1 DO
        psum[i]:=psum[i]+p[j];
      END;

     ClrScr;
     WRITELN('encoding string    : ',inp);
     r:=Encode(inp);
     WRITELN('string is encoded by ',r);
     WRITELN('decoding of r gives: ',Decode(r,Length(inp)));

    END.

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