Photo CD Demo 1/Demo.bin/formats/gif/atari/stgif.arc/COMPRESS.MOD

Modula Implementation | 1987-06-09 | 10.8 KB | 368 lines

IMPLEMENTATION MODULE Compressor;

(*$S-,$T-*)

(*-----------------------------------------------------------------------*)
(* Copyright (c) 1987                                                    *)
(* by CompuServe Inc., Columbus, Ohio.  All Rights Reserved              *)
(*-----------------------------------------------------------------------*)


(*
 * VERSION: 1.0
 *
 * ABSTRACT:
 *
 *      This module implements the Lempel-Ziv adaptive compression
 *      algorithm as given in the June 1984 issue of IEEE Computer,
 *      "A Technique for High-Performance Data Compression" by Terry
 *      A. Welch.
 *
 *      The compression algorithm builds a string translation table that maps
 *      substrings from the input string into fixed-length codes.  These codes
 *      are used by the expansion algorithm to rebuild the compressor's table
 *      and reconstruct the original data stream.  In it's simplest form, the
 *      algorithm can be stated as:
 *
 *              "if <w>k is in the table, then <w> is in the table"
 *
 *      <w> is a code which represents a string in the table.  When a new
 *      character k is read in, the table is searched for <w>k.  If this
 *      combination is found, <w> is set to the code for that combination
 *      and the next character is read in.  Otherwise, this combination is
 *      added to the table, the code <w> is written to the output stream and
 *      <w> is set to k.
 *
 *      The expansion algorithm builds an identical table by parsing each
 *      received code into a prefix string and suffix character.  The suffix
 *      character is pushed onto the stack and the prefix string translated
 *      again until it is a single character.  This completes the expansion.
 *      The expanded code is then output by popping the stack and a new entry
 *      is made in the table.
 *
 *      The algorithm used here has one additional feature.  The output codes
 *      are variable length.  They start at a specified number of bits.  Once
 *      the number of codes exceeds the current code size, the number of bits
 *      in the code is incremented.  When the table is completely full, a
 *      clear code is transmitted for the expander and the table is reset.
 *      This program uses a maximum code size of 12 bits for a total of 4096
 *      codes.
 *
 *      The expander realizes that the code size is changing when it's table
 *      size reaches the maximum for the current code size.  At this point,
 *      the code size in increased.  Remember that the expander's table is
 *      identical to the compressor's table at any point in the original data
 *      stream.
 *
 *      The compressed data stream is structured as follows:
 *              first byte denoting the minimum code size
 *              one or more counted byte strings. The first byte contains the
 *              length of the string. A null string denotes "end of data"
 *
 *      This format permits a compressed data stream to be embedded within a
 *      non-compressed context.
 *
 * ENVIRONMENT: LogiTech, TDI
 *
 * AUTHOR: Steve Wilhite, CREATION DATE: 4-Jan-87
 *
 * REVISION HISTORY:
 *
 *)

(* LogiTech

FROM SYSTEM IMPORT
    TSIZE, SETREG, CODE, AX, CX, DI, ES, ADDRESS, ADR;
*)
(* TDI *)

FROM SYSTEM IMPORT
    SETREG, CODE, ADR,
    TSIZE;

FROM Storage IMPORT
    ALLOCATE, DEALLOCATE;

FROM Shifter IMPORT
    ShiftLeft;

FROM ErrorCodes IMPORT
    Normal, EndOfFile, NoMemory, BadArgs;


CONST LargestCode = 4095;
CONST TableSize = 5003;

TYPE CodeEntry =
    RECORD
        AddedByte: CHAR;
        PriorCode: CARDINAL;
        CodeId: CARDINAL;
    END;

TYPE CodeTableType = ARRAY [0 .. TableSize - 1] OF CodeEntry;

VAR Read: ReadProc;
VAR Write: WriteProc;
VAR Status: CARDINAL;
VAR ClearCode, EOFCode, CodeSize, MaxCode: CARDINAL;
VAR CodeTable: POINTER TO CodeTableType;
VAR NextEntry: CARDINAL;
VAR BitOffset: CARDINAL;
VAR CodeBuffer: ARRAY [0 .. 258] OF CHAR;

(*.page*)(*.sbttl CompressData *)

PROCEDURE CompressData (minCodeSize: CARDINAL;
                        read: ReadProc;
                        write: WriteProc): CARDINAL;
BEGIN
    Read := read;
    Write := write;
    ALLOCATE(CodeTable, TSIZE(CodeTableType));

    IF CodeTable = NIL THEN
        RETURN NoMemory;
    END;

    CompressTheData(minCodeSize);
    DEALLOCATE(CodeTable, TSIZE(CodeTableType));
    RETURN Status;
END CompressData;

(*.page*)(*.sbttl CompressTheData *)

PROCEDURE CompressTheData(MinCodeSize: CARDINAL);

    VAR SuffixChar: CHAR;
    VAR PrefixCode: CARDINAL;
    VAR H, D: CARDINAL;
BEGIN
    BitOffset := 0;

    IF (MinCodeSize < 2) OR (MinCodeSize > 9) THEN
        IF MinCodeSize = 1 THEN
            MinCodeSize := 2;
        ELSE
            Status := BadArgs;
            RETURN;
        END;
    END;

    InitTable(MinCodeSize);
    Status := Write(CHR(MinCodeSize));

    IF Status # Normal THEN
        RETURN;
    END;

    WriteCode(ClearCode);

    IF Status # Normal THEN
        RETURN;
    END;

    Status := Read(SuffixChar);

    IF Status = Normal THEN
        PrefixCode := ORD(SuffixChar);
        Status := Read(SuffixChar);

        WHILE Status = Normal DO

            (* Search the string table for the active string.  The search uses
               hashing with secondary quadratic probing. *)

            H := (PrefixCode + ORD(SuffixChar)*32) MOD TableSize;
            D := 1;

            LOOP
                WITH CodeTable^[H] DO
                    IF CodeId = 0 THEN (* new entry *)
                        WriteCode(PrefixCode);

                        IF Status # Normal THEN
                            RETURN;
                        END;

                        D := NextEntry;

                        IF NextEntry <= LargestCode THEN
                            PriorCode := PrefixCode;
                            AddedByte := SuffixChar;
                            CodeId := NextEntry;
                            INC(NextEntry);
                        END;

                        IF D = MaxCode THEN
                            IF CodeSize < 12 THEN
                                CodeSize := CodeSize + 1;
                                MaxCode := 2*MaxCode;
                            ELSE
                                WriteCode(ClearCode);

                                IF Status # Normal THEN
                                    RETURN;
                                END;

                                InitTable(MinCodeSize);
                            END;
                        END;

                        PrefixCode := ORD(SuffixChar);
                        EXIT;
                    END;

                    IF (PriorCode = PrefixCode) AND (AddedByte = SuffixChar)
                    THEN
                        PrefixCode := CodeId;
                        EXIT;
                    END;
                END;

                (* Collision *)

                H := H + D;
                D := D + 2;

                IF H >= TableSize THEN
                    H := H - TableSize;
                END;
            END (*LOOP*);

            Status := Read(SuffixChar);
        END (*WHILE*);

        IF Status # EndOfFile THEN
            RETURN;
        END;

        WriteCode(PrefixCode);

        IF Status # Normal THEN
            RETURN;
        END;

    ELSIF Status # EndOfFile THEN
        RETURN;
    END (*IF*);

    WriteCode(EOFCode);

    IF Status # Normal THEN
        RETURN;
    END;

    (* Flush CodeBuffer to the output stream *)

    IF BitOffset > 0 THEN
        FlushBuffer((BitOffset + 7) DIV 8);

        IF Status # Normal THEN
            RETURN;
        END;
    END;

    Status := Write(0C);
END CompressTheData;

(*.page*)(*.sbttl InitTable *)

PROCEDURE InitTable (MinCodeSize: CARDINAL);

    VAR I: CARDINAL;
BEGIN
    CodeSize := MinCodeSize + 1;
    ClearCode := ShiftLeft(1, MinCodeSize);
    EOFCode := ClearCode + 1;
    NextEntry := ClearCode + 2;
    MaxCode := ShiftLeft(1, CodeSize);

    FOR I := 0 TO TableSize - 1 DO
        CodeTable^[I].CodeId := 0;
    END;
END InitTable;

(*.page*)(*.sbttl WriteCode *)

PROCEDURE WriteCode (Code: CARDINAL);

    VAR ByteOffset, BitsLeft: CARDINAL;
(*  VAR Temp: ADDRESS; (* LogiTech *)*)
BEGIN
    ByteOffset := BitOffset DIV 8;
    BitsLeft := BitOffset MOD 8;

    IF ByteOffset >= 254 THEN
        FlushBuffer(ByteOffset);

        IF Status # Normal THEN
            RETURN;
        END;

        CodeBuffer[0] := CodeBuffer[ByteOffset];
        BitOffset := BitsLeft;
        ByteOffset := 0;
    END;

    IF BitsLeft > 0 THEN
        (* 8086
        Temp := ADR(CodeBuffer[ByteOffset]);
        SETREG(AX, Code);
        SETREG(CX, BitsLeft);
        SETREG(DI, Temp.OFFSET);
        SETREG(ES, Temp.SEGMENT);
        CODE(033H, 0D2H,                (*      xor     DX,DX           *)
             0D1H, 0E0H,                (* L1:  shl     AX,1            *)
             0D1H, 0D2H,                (*      rcl     DX,1            *)
             0E2H, 0FAH,                (*      loop    L1              *)
             026H, 00AH, 005H,          (*      or      AL,ES:[DI]      *)
             0ABH,                      (*      stosw                   *)
             08AH, 0C2H,                (*      mov     AL,DL           *)
             0AAH);                     (*      stosb                   *)
        *)
        (* 68000 *)
        SETREG(0, LONGCARD(Code));      (*      move.w  Code,d0         *)
        SETREG(7, LONGCARD(BitsLeft));  (*      move.w  BitsLeft,d7     *)
        SETREG(8, ADR(CodeBuffer[ByteOffset]));
        CODE(0EFA8H);                   (*      lsl.l   d7,d0           *)
        CODE(08010H);                   (*      or.b    (a0),d0         *)
        CODE(010C0H);                   (*      move.b  d0,(a0)+        *)
        CODE(0E088H);                   (*      lsr.l   #8,d0           *)
        CODE(010C0H);                   (*      move.b  d0,(a0)+        *)
        CODE(0E088H);                   (*      lsr.l   #8,d0           *)
        CODE(010C0H);                   (*      move.b  d0,(a0)+        *)
    ELSE
        CodeBuffer[ByteOffset] := CHR(Code MOD 256);
        CodeBuffer[ByteOffset + 1] := CHR(Code DIV 256);
    END;

    INC(BitOffset, CodeSize);
    Status := Normal;
END WriteCode;

(*.page*)(*.sbttl FlushBuffer *)

PROCEDURE FlushBuffer(Count: CARDINAL);

    VAR I: CARDINAL;
BEGIN
    Status := Write(CHR(Count));

    IF Status # Normal THEN
        RETURN;
    END;

    FOR I := 0 TO Count - 1 DO
        Status := Write(CodeBuffer[I]);

        IF Status # Normal THEN
            RETURN;
        END;
    END;
END FlushBuffer;


END Compressor.