Power-Programmierung/CD1.mdf/modula2/library/modula1/huffman.mod

Text File | 1988-11-18 | 26KB | 1,066 lines

======
Editor's note: Remember to break the folowing modules into their own files
before attempting to compile them.  Delete "======" and comments inside them
======
Start BitStream.DEF
======

DEFINITION MODULE BitStream;

(* Used for bit-oriented I/O.  Minimal facilities. *)


EXPORT QUALIFIED connect, disconnect, EOS, read, write, bitStream,
        readChar, writeChar, readCard, writeCard;

TYPE bitStream;


PROCEDURE connect(fileName:ARRAY OF CHAR; read:BOOLEAN):bitStream;
(* Associates a file with a bitStream.  A given stream can be
   read from or written to, but not both.  On a Mac, this procedure
   uses the default drive. *)

PROCEDURE disconnect(bs:bitStream);
(* Disconnects stream from file. *)

PROCEDURE EOS(bs:bitStream):BOOLEAN;
(* TRUE at end of stream; for read streams only! *)

PROCEDURE read(bs:bitStream):BOOLEAN;
(* Reads a bit from the stream.  TRUE = 1, FALSE = 0 *)

PROCEDURE write(bs:bitStream; b:BOOLEAN);
(* Writes a bit to the stream. *)

PROCEDURE readChar(bs:bitStream):CHAR;
(* Reads eight consecutive bits and translates them into a CHAR.  This is
   somewhat implementation-dependent. *)

PROCEDURE writeChar(bs:bitStream; c:CHAR);
(* Writes the character as eight consecutive bits.  This is somewhat
   implementation-dependent. *)

PROCEDURE readCard(bs:bitStream):CARDINAL;
(* Reads 16 consecutive bits and translates them into a CARDINAL. *)

PROCEDURE writeCard(bs:bitStream; c:CARDINAL);
(* Writes the cardinal as 16 consecutive bits *)

END BitStream.

======
Start BitStream.MOD
======

IMPLEMENTATION MODULE BitStream;


(* Note: because Streams.WriteWord and Streams.ReadWord don't appear to
   work in MacModula-2, I do I/O with the character operations. A character
   code occupies bits 8-15 of a word. *)

FROM Streams IMPORT STREAM, StreamType, Connect, Disconnect, ReadChar,
        WriteChar;
IMPORT Streams;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM MyTerminal IMPORT fatal;

CONST maxBit = 15;  (* highest numbered bit in a BITSET *)
      lowCharBit = 8; (* first bit of a character *)

TYPE wordRange = [0..maxBit];
     charRange = [lowCharBit..maxBit];
     bitStream = POINTER TO bsRec;
     bsRec = RECORD
                stream:STREAM;
                read:BOOLEAN;
                curWord:BITSET;
                curBit:charRange;
             END;

PROCEDURE connect(fileName:ARRAY OF CHAR; read:BOOLEAN):bitStream;
VAR bs:bitStream;
    nullVol:ARRAY[0..0] OF CHAR;
    done:BOOLEAN;
BEGIN
    nullVol[0] := 0C;
    NEW(bs);
    bs^.read := read;
    IF read THEN
        Connect(bs^.stream, streamread,      (* open stream for reading *)
                fileName, nullVol, 1, (* use drive #1 *)
                FALSE,                (* don't create if nonexistent *)
                done);
        IF NOT done THEN
            fatal('cannot open file');
        END;
        bs^.curBit := maxBit;
    ELSE
        Connect(bs^.stream, streamwrite, fileName, nullVol, 1, TRUE, done);
        IF NOT done THEN
            fatal('cannot open file');
        END;
        bs^.curBit := lowCharBit;
        bs^.curWord := {};
    END;
    RETURN bs;
END connect;

PROCEDURE disconnect(bs:bitStream);
BEGIN
  WITH bs^ DO
    IF (NOT read) AND (curBit <> lowCharBit) THEN  (* flush the last word *)
        WriteChar(stream, CHAR(curWord));
    END;
    Disconnect(stream);
    DISPOSE(bs);
  END;
END disconnect;

PROCEDURE EOS(bs:bitStream):BOOLEAN;
BEGIN
  WITH bs^ DO
    IF read THEN
        RETURN (curBit = maxBit) AND Streams.EOS(stream);
    ELSE
        fatal('EOS called on write bit stream');
    END;
  END;
END EOS;

PROCEDURE read(bs:bitStream):BOOLEAN;
(* Init: curBit := maxBit.  curBit = "all bits to curBit have been read" *)
VAR c:CHAR;
BEGIN
    IF NOT bs^.read  THEN
        fatal('attempt to read a write bit stream');
    ELSE WITH bs^ DO
        IF curBit = maxBit THEN
            IF NOT Streams.EOS(stream) THEN
                ReadChar(stream, c);
                curWord := BITSET(c);
                curBit := lowCharBit;
            END;
        ELSE
            INC(curBit);
        END;
        RETURN curBit IN curWord;
    END; END;
END read;


PROCEDURE write(bs:bitStream; b:BOOLEAN);
(* init: curBit := lowCharBit, curWord := {}.
   curBit = "bit curBit is next to be written" *)
BEGIN
  WITH bs^ DO
    IF read THEN
        fatal('attempt to write a read bit stream');
    END;
    IF b THEN
        INCL(curWord, curBit);
    END;
    IF curBit = maxBit THEN
        WriteChar(stream, CHAR(curWord));
        curWord := {};
        curBit := lowCharBit;
    ELSE
        INC(curBit);
    END;
  END;
END write;

PROCEDURE readChar(bs:bitStream):CHAR;
(* Read 8 bits and make them into a character.  In MacModula-2,
   a CHAR variable is a word with bits 8-15 containing the ASCII code. *)
VAR i:charRange;
    char:BITSET;
BEGIN
    char := {};
    FOR i := lowCharBit TO maxBit DO
        IF read(bs) THEN
            INCL(char, i);
        END;
    END;
    RETURN CHAR(char);
END readChar;

PROCEDURE writeChar(bs:bitStream; c:CHAR);
(* see readChar for implementation details *)
VAR i:charRange;
BEGIN
    FOR i := lowCharBit TO maxBit DO
        write(bs, i IN BITSET(c));
    END;
END writeChar;

PROCEDURE readCard(bs:bitStream):CARDINAL;
VAR i:wordRange;
    card:BITSET;
BEGIN
    FOR i := 0 TO maxBit DO
        IF read(bs) THEN
            INCL(card, i);
        ELSE
            EXCL(card, i);
        END;
    END;
    RETURN CARDINAL(card);
END readCard;

PROCEDURE writeCard(bs:bitStream; c:CARDINAL);
VAR i:wordRange;
BEGIN
    FOR i := 0 TO maxBit DO
        write(bs, i IN BITSET(c));
    END;
END writeCard;

BEGIN
END BitStream.

======
Start CharStream.DEF
======

DEFINITION MODULE CharStream;

EXPORT QUALIFIED charStream, connect, disconnect, read, write, EOS;

TYPE
    charStream;


PROCEDURE connect(fileName:ARRAY OF CHAR; read:BOOLEAN):charStream;

PROCEDURE disconnect(cs:charStream);

PROCEDURE read(cs:charStream):CHAR;

PROCEDURE write(cs:charStream; c:CHAR);

PROCEDURE EOS(cs:charStream):BOOLEAN;

END CharStream.

======
Start CharStream.MOD
======

IMPLEMENTATION MODULE CharStream;

(* This module supports character I/O from files.  Its facilities are minimal.
   I wrote it using MacModula-2's Streams module; it should be easy to
   duplicate its behavior with whatever file system you have. *)

FROM Streams IMPORT STREAM, StreamType, Connect, Disconnect,
        ReadChar, WriteChar;
IMPORT Streams;
FROM MyTerminal IMPORT fatal;
FROM Storage IMPORT ALLOCATE, DEALLOCATE;

TYPE
    charStream = POINTER TO STREAM;


PROCEDURE connect(fileName:ARRAY OF CHAR; read:BOOLEAN):charStream;
VAR cs:charStream;
    nullVol: ARRAY[0..0] OF CHAR;
    done:BOOLEAN;
BEGIN
    nullVol[0] := 0C;
    NEW(cs);
    IF read THEN
        Connect(cs^, streamread,      (* open stream for reading *)
                fileName, nullVol, 1, (* use drive #1 *)
                FALSE,                (* don't create if nonexistent *)
                done);
        IF NOT done THEN
            fatal('cannot open file');
        END;
    ELSE
        Connect(cs^, streamwrite, fileName, nullVol, 1, TRUE, done);
        IF NOT done THEN
            fatal('cannot open file');
        END;
    END;
    RETURN cs;
END connect;

PROCEDURE disconnect(cs:charStream);
BEGIN
    Disconnect(cs^);
    DISPOSE(cs);
END disconnect;

PROCEDURE read(cs:charStream):CHAR;
VAR c:CHAR;
BEGIN
    ReadChar(cs^, c);
    RETURN c;
END read;

PROCEDURE write(cs:charStream; c:CHAR);
BEGIN
    WriteChar(cs^, c);
END write;

PROCEDURE EOS(cs:charStream):BOOLEAN;
BEGIN
    RETURN Streams.EOS(cs^);
END EOS;

BEGIN
END CharStream.

======
Start Compress.MOD
======

MODULE Compress;

(* File compression algorithm using Huffman coding.
   Based on "Data Compression with Huffman Coding," BYTE March 1986.
   Copyright 1986 by Jonathan Amsterdam.  All Rights Reserved.
*)

FROM CharStream IMPORT charStream;
IMPORT CharStream;
FROM BitStream IMPORT bitStream;
IMPORT BitStream;
FROM MyTerminal IMPORT ClearScreen, pause, WriteCard, WriteLn, WriteString,
    WriteLnString, Write;
FROM InOut IMPORT ReadString;
FROM Huffman IMPORT huffTree, huffman, readCode, writeCode, readTree,
        writeTree, codeSize;
FROM StringStuff IMPORT stringLen, stringCopy;
FROM RealInOut IMPORT FWriteReal;
(* FWriteReal writes real numbers in decimal format.  If your implementation
doesn't have it, substitute WriteReal. *)

CONST stringlen = 60;

VAR frequency:ARRAY CHAR OF CARDINAL;
    fileSize:CARDINAL;
    inFileName, outFileName: ARRAY[0..stringlen] OF CHAR;
    hTree:huffTree;


PROCEDURE doFreq;
(* Obtain frequency count from file *)
VAR cs:charStream;
BEGIN
    cs := CharStream.connect(inFileName, TRUE);        (* read file *)
    freqCount(cs);
    CharStream.disconnect(cs);
END doFreq;

PROCEDURE freqCount(cs:charStream);
VAR c:CHAR;
BEGIN
    FOR c := 0C TO CHR(HIGH(frequency)) DO
        frequency[c] := 0;
    END;
    c := CharStream.read(cs);
    WHILE NOT CharStream.EOS(cs) DO
        INC(frequency[c]);
        INC(fileSize);
        c := CharStream.read(cs);
    END;
END freqCount;


PROCEDURE doOutput;
(* Output encoded file *)
VAR inStream:charStream;
    outStream:bitStream;
    c:CHAR;
BEGIN
    inStream := CharStream.connect(inFileName, TRUE);
    outStream := BitStream.connect(outFileName, FALSE);
    BitStream.writeCard(outStream, fileSize);
    writeTree(outStream, hTree);
    c := CharStream.read(inStream);
    WHILE NOT CharStream.EOS(inStream) DO
        writeCode(outStream, hTree, c);
        c := CharStream.read(inStream);
    END;
    CharStream.disconnect(inStream);
    BitStream.disconnect(outStream);
END doOutput;



PROCEDURE computeStats;
(* Compute statistics on how much space was saved *)
VAR c:CHAR;
    origBits, compBits, nChars:CARDINAL;
    savings:REAL;
BEGIN
    origBits := fileSize * 8;
    compBits := 0;
    nChars := 0;
    FOR c := 0C TO CHR(HIGH(frequency)) DO
        IF frequency[c] <> 0 THEN
            INC(nChars);
            compBits := compBits + codeSize(hTree, c) * frequency[c];
        END;
    END;
    WriteString("number of different characters: ");
    WriteCard(nChars, 0); WriteLn;
    WriteString("original file size (bits): ");
    WriteCard(origBits, 0); WriteLn;
    WriteString("compressed f. size (bits): ");
    WriteCard(compBits, 0); WriteLn;
    WriteString("percent savings: ");
    savings := 1.0 - (FLOAT(compBits) / FLOAT(origBits));
    FWriteReal(savings * 100.0, 5); WriteLn;
    WriteString("compressed size, including bookkeeping: ");
    (* add 16 bits for character, count, 10n-1 bits for tree *)
    INC(compBits, 16 + 10*nChars -1);
    WriteCard(compBits, 0); WriteLn;
    WriteString("true percent savings: ");
    savings := 1.0 - (FLOAT(compBits) / FLOAT(origBits));
    FWriteReal(savings * 100.0, 5); WriteLn;
END computeStats;

PROCEDURE doOutfileName;
(* Make the name of the output file by appending ".P" to the input file's
   name *)
VAR len:CARDINAL;
BEGIN
    len := stringLen(inFileName);
    stringCopy(outFileName, inFileName);
    outFileName[len] := '.';
    outFileName[len+1] := 'P';
    outFileName[len+2] := 0C;
END doOutfileName;

BEGIN
    ClearScreen;
    WriteLnString("File Compression using Huffman Coding");
    WriteString("Input file: ");
    ReadString(inFileName);
    doOutfileName;
    doFreq;
    hTree := huffman(frequency);
    doOutput;
    computeStats;
    pause('done--');
END Compress.

======
Start Huffman.DEF
======

DEFINITION MODULE Huffman;

(* Implements the Huffman coding scheme and procedures for manipulating
   the code tree. *)

FROM BitStream IMPORT bitStream;

EXPORT QUALIFIED huffTree, huffman, writeCode, readCode, writeTree, readTree,
        codeSize;

TYPE huffTree;

PROCEDURE huffman(VAR frequency:ARRAY OF CARDINAL):huffTree;
(* construct a Huffman coding tree from the given character frequencies *)

PROCEDURE writeCode(bs:bitStream; ht:huffTree; c:CHAR);
(* Write the code for c onto bs, using ht. *)

PROCEDURE readCode(bs:bitStream; ht:huffTree):CHAR;
(* Read bits from bs until a full code is read; return the character *)

PROCEDURE writeTree(bs:bitStream; ht:huffTree);
(* Write the tree onto the stream *)

PROCEDURE readTree(bs:bitStream):huffTree;
(* Read a huffTree from the stream *)

PROCEDURE codeSize(ht:huffTree; c:CHAR):CARDINAL;
(* returns the length of the code for c *)

END Huffman.

======
Start Huffman.MOD
======

IMPLEMENTATION MODULE Huffman;

(* Huffman coding algorithm, as described in "Data Compression With Huffman
   Coding," BYTE, March 1986.
   Copyright Jonathan Amsterdam 1986, All Rights Reserved. *)

FROM Storage IMPORT ALLOCATE, DEALLOCATE;
FROM BitStream IMPORT bitStream;
IMPORT BitStream;
FROM MyTerminal IMPORT WriteString, WriteCard, WriteLn, fatal;
CONST maxChars = 256;

TYPE
    node = POINTER TO nodeRec;
    nodeRec = RECORD
                char:CHAR;
                freq:CARDINAL;
                child:ARRAY BOOLEAN OF node;
                parent:node;        (* used for encoding *)
              END;

    huffTree = POINTER TO htRec;
    htRec = RECORD
                tree:node;      (* the tree itself *)
                leaf:ARRAY CHAR OF node; (* index by character, for encoding *)
            END;


VAR tree:ARRAY[1..maxChars] OF node;    (* temporary list of trees *)
    nTrees:CARDINAL;

        (*** constructing the tree ***)

PROCEDURE huffman(VAR frequency:ARRAY OF CARDINAL):huffTree;
VAR ht:huffTree;
BEGIN
    ht := initHuffTree(frequency);
    initTrees(ht^.leaf);
    WHILE nTrees > 1 DO
        insert(combineNodes(removeSmallest(), removeSmallest()));
    END;
    ht^.tree := tree[1];
    RETURN ht;
END huffman;

PROCEDURE initHuffTree(VAR freq:ARRAY OF CARDINAL):huffTree;
VAR i:CARDINAL;
    ht:huffTree;
BEGIN
    ht := newHuffTree();
    FOR i := 0 TO HIGH(freq) DO
        IF freq[i] <> 0 THEN
            ht^.leaf[CHR(i)] := newNode(CHR(i), freq[i], NIL, NIL);
        END;
    END;
    RETURN ht;
END initHuffTree;


PROCEDURE initTrees(VAR leaf:ARRAY OF node);
VAR i:CARDINAL;
BEGIN
    nTrees := 0;
    FOR i := 0 TO HIGH(leaf) DO
        IF leaf[i] <> NIL THEN
            insert(leaf[i]);
        END;
    END;
END initTrees;

PROCEDURE removeSmallest():node;
VAR i, smallest:CARDINAL;
    smallestNode:node;
BEGIN
    smallest := 1;
    FOR i := 2 TO nTrees DO
        IF tree[i]^.freq < tree[smallest]^.freq THEN
            smallest := i;
        END;
    END;
    smallestNode := tree[smallest];
    tree[smallest] := tree[nTrees];
    DEC(nTrees);
    RETURN smallestNode;
END removeSmallest;

PROCEDURE insert(n:node);
BEGIN
    INC(nTrees);
    tree[nTrees] := n;
END insert;

            (*** code I/O ***)

PROCEDURE writeCode(bs:bitStream; ht:huffTree; c:CHAR);
(* Write the code for c onto bs, using ht. By using recursion, we can
   avoid explicitly retracing the path from the root to the leaf. *)

    PROCEDURE wrCode(n:node);
    BEGIN
        IF n^.parent <> NIL THEN
            wrCode(n^.parent);
            BitStream.write(bs, n = n^.parent^.child[TRUE]);
        END;
    END wrCode;

BEGIN
    IF ht^.leaf[c] = NIL THEN
        WriteString("no code for "); WriteCard(CARDINAL(c), 0); WriteLn;
        fatal('dying');
    END;
    wrCode(ht^.leaf[c]);
END writeCode;

PROCEDURE readCode(bs:bitStream; ht:huffTree):CHAR;
(* Read bits from bs until a full code is read; return the character *)

    PROCEDURE rdCode(n:node):CHAR;
    BEGIN
        IF leaf(n) THEN
            RETURN n^.char;
        ELSE
            RETURN rdCode(n^.child[BitStream.read(bs)]);
        END;
    END rdCode;

BEGIN
    RETURN rdCode(ht^.tree);
END readCode;

PROCEDURE writeTree(bs:bitStream; ht:huffTree);
(* Write the tree onto the stream.  It is encoded as follows:
   A 1 bit indicates an internal node.
   A 0 bit indicates a leaf; the next 8 bits are the character code.
   The tree is traversed by preorder traversal: first the root, then
   the left (FALSE) subtree, then the right (TRUE). *)

    PROCEDURE wrTree(n:node);
    BEGIN
        IF leaf(n) THEN
            BitStream.write(bs, FALSE);
            BitStream.writeChar(bs, n^.char);
        ELSE
            BitStream.write(bs, TRUE);
            wrTree(n^.child[FALSE]);
            wrTree(n^.child[TRUE]);
        END;
    END wrTree;

BEGIN
    wrTree(ht^.tree);
END writeTree;

PROCEDURE readTree(bs:bitStream):huffTree;
(* Read a huffTree from the stream. See writeTree for the encoding used.
   Frequency information is NOT preserved. *)
VAR ht:huffTree;

    PROCEDURE rdTree():node;
    VAR false, true, n:node;
    BEGIN
        IF BitStream.read(bs) THEN (* an internal node *)
            false := rdTree();
            true := rdTree();
            n := newNode(0C, 0, false, true);
            false^.parent := n;
            true^.parent := n;
            RETURN n;
        ELSE (* a leaf *)
            n := newNode(BitStream.readChar(bs), 0, NIL, NIL);
            ht^.leaf[n^.char] := n;
            RETURN n;
        END;
    END rdTree;

BEGIN
    ht := newHuffTree();
    ht^.tree := rdTree();
    RETURN ht;
END readTree;


            (*** huffTree allocation ***)

PROCEDURE newHuffTree():huffTree;
VAR c:CHAR;
    ht:huffTree;
BEGIN
    NEW(ht);
    FOR c := 0C TO CHR(HIGH(ht^.leaf)) DO
        ht^.leaf[c] := NIL;
    END;
    RETURN ht;
END newHuffTree;

            (*** node stuff ***)

PROCEDURE combineNodes(n1, n2:node):node;
(* used to combine nodes when constructing the coding tree *)
VAR n:node;
BEGIN
    n := newNode(0C, n1^.freq + n2^.freq, n1, n2);
    n1^.parent := n;
    n2^.parent := n;
    RETURN n;
END combineNodes;

PROCEDURE newNode(c:CHAR; f:CARDINAL; false, true:node):node;
VAR n:node;
BEGIN
    NEW(n);
    WITH n^ DO
        char := c;
        freq := f;
        child[FALSE] := false;
        child[TRUE] := true;
        parent := NIL;
    END;
    RETURN n;
END newNode;

PROCEDURE freeNode(n:node);
(* In the current implementation, this is never used *)
BEGIN
    IF n <> NIL THEN
        freeNode(n^.child[FALSE]);
        freeNode(n^.child[TRUE]);
        DISPOSE(n);
    END;
END freeNode;

PROCEDURE leaf(n:node):BOOLEAN;
BEGIN
    IF n = NIL THEN
        fatal('leaf: n NIL');
    END;
    RETURN n^.child[FALSE] = NIL;
END leaf;

PROCEDURE codeSize(ht:huffTree; c:CHAR):CARDINAL;
(* returns the length of the code for c *)
VAR i:CARDINAL;
    n:node;
BEGIN
    i := 0;
    n := ht^.leaf[c];
    WHILE n <> NIL DO
        INC(i);
        n := n^.parent;
    END;
    RETURN i-1;
END codeSize;

BEGIN
END Huffman.


======
Start MyTerminal.DEF
======

DEFINITION MODULE MyTerminal;

(* Some small but useful additions to the Terminal module. *)

EXPORT QUALIFIED WriteString, WriteLn, Write, Read, ClearScreen, Beep,
        WriteLnString, WriteInt, WriteCard, pause, fatal;

PROCEDURE WriteString(s:ARRAY OF CHAR);
PROCEDURE WriteLn;
PROCEDURE Write(c:CHAR);
PROCEDURE Read(VAR c:CHAR);
PROCEDURE ClearScreen;
PROCEDURE Beep;

PROCEDURE WriteLnString(s:ARRAY OF CHAR);
PROCEDURE WriteInt(i:INTEGER; spaces:CARDINAL);
PROCEDURE WriteCard(c, spaces:CARDINAL);

PROCEDURE pause(msg:ARRAY OF CHAR);
(* Prevents the screen from blanking and returning to the Finder until the
   user hits a key.  msg is typed out. *)

PROCEDURE fatal(msg:ARRAY OF CHAR);
(* Prints the message, does a pause, and HALTs. *)

END MyTerminal.


======
Start MyTerminal.MOD
======

IMPLEMENTATION MODULE MyTerminal;

(* Some small but useful additions to the Terminal module. *)

IMPORT Terminal;

VAR powerOfTen: ARRAY[0..4] OF CARDINAL;


PROCEDURE WriteLnString(s:ARRAY OF CHAR);
BEGIN
    Terminal.WriteString(s);
    Terminal.WriteLn;
END WriteLnString;

PROCEDURE WriteInt(i:INTEGER; spaces:CARDINAL);
BEGIN
    IF i < 0 THEN
        writeNum(CARDINAL(-i), spaces-1, TRUE);
    ELSE
        writeNum(CARDINAL(i), spaces, FALSE);
    END;
END WriteInt;

PROCEDURE WriteCard(c, spaces:CARDINAL);
BEGIN
    writeNum(c, spaces, FALSE);
END WriteCard;

PROCEDURE writeNum(c, spaces:CARDINAL; neg:BOOLEAN);
VAR p:CARDINAL;
    i:INTEGER;
BEGIN
    p := places(c);
    FOR i := 1 TO INTEGER(spaces) - INTEGER(p) DO
        Terminal.Write(' ');
    END;
    IF neg THEN
        Terminal.Write('-');
    END;
    FOR i := p-1 TO 0 BY -1 DO
        Terminal.Write(CHR((c DIV powerOfTen[i]) + ORD('0')));
        c := c MOD powerOfTen[i];
    END;
END writeNum;

PROCEDURE places(c:CARDINAL):CARDINAL;
(* Returns the number of places c takes to print; i.e. trunc(1+log10(c)). *)
VAR i:CARDINAL;
BEGIN
    FOR i := 4 TO 0 BY -1 DO
        IF (c DIV powerOfTen[i]) > 0 THEN
            RETURN i+1;
        END;
    END;
    RETURN 1;
END places;


PROCEDURE pause(msg:ARRAY OF CHAR);
(* Prevents the screen from blanking and returning to the Finder until the
   user hits a key.  msg is typed out. *)
VAR ch:CHAR;
BEGIN
    Terminal.WriteString(msg);
    Terminal.Read(ch);
END pause;

PROCEDURE fatal(msg:ARRAY OF CHAR);
BEGIN
    WriteLnString(msg);
    pause('Hit any key to die--');
    HALT;
END fatal;


            (*** Copies of Terminal procedures ***)

PROCEDURE WriteString(s:ARRAY OF CHAR);
BEGIN
    Terminal.WriteString(s);
END WriteString;

PROCEDURE WriteLn;
BEGIN
    Terminal.WriteLn;
END WriteLn;

PROCEDURE Write(c:CHAR);
BEGIN
    Terminal.Write(c);
END Write;

PROCEDURE Read(VAR c:CHAR);
BEGIN
    Terminal.Read(c);
END Read;

PROCEDURE ClearScreen;
BEGIN
    Terminal.ClearScreen;
END ClearScreen;

PROCEDURE Beep;
BEGIN
    Terminal.Beep;
END Beep;

BEGIN
    powerOfTen[0] := 1;
    powerOfTen[1] := 10;
    powerOfTen[2] := 100;
    powerOfTen[3] := 1000;
    powerOfTen[4] := 10000;
END MyTerminal.


======
Start StringStuff.DEF
======

DEFINITION MODULE StringStuff;

EXPORT QUALIFIED stringCap, charCap, stringLen, stringCopy, stringEqual;

PROCEDURE charCap(ch:CHAR):CHAR;

PROCEDURE stringCap(VAR s:ARRAY OF CHAR);

PROCEDURE stringLen(VAR s:ARRAY OF CHAR):CARDINAL;

PROCEDURE stringCopy(VAR s1:ARRAY OF CHAR; s2:ARRAY OF CHAR);

PROCEDURE stringEqual(s1, s2:ARRAY OF CHAR):BOOLEAN;

END StringStuff.


======
Start StringStuff.MOD
======


IMPLEMENTATION MODULE StringStuff;


PROCEDURE charCap(ch:CHAR):CHAR;
BEGIN
    IF (ch >= 'a') AND (ch <= 'z') THEN
        RETURN CAP(ch);
    ELSE
        RETURN ch;
    END;
END charCap;

PROCEDURE stringCap(VAR s:ARRAY OF CHAR);
VAR i:CARDINAL;
BEGIN
    FOR i := 0 TO stringLen(s) DO
        s[i] := charCap(s[i]);
    END;
END stringCap;

PROCEDURE stringLen(VAR s:ARRAY OF CHAR):CARDINAL;
VAR i:CARDINAL;
BEGIN
    FOR i := 0 TO HIGH(s) DO
        IF s[i] = 0C THEN
            RETURN i;
        END;
    END;
    RETURN HIGH(s)+1;
END stringLen;

PROCEDURE stringCopy(VAR s1:ARRAY OF CHAR; s2:ARRAY OF CHAR);
VAR i:CARDINAL;
BEGIN
    i := 0;
    LOOP
        IF i > HIGH(s1) THEN
            EXIT;
        ELSIF i > HIGH(s2) THEN
            s1[i] := 0C;
            EXIT;
        ELSE
            s1[i] := s2[i];
        END;
        INC(i);
    END;
END stringCopy;

PROCEDURE stringEqual(s1, s2:ARRAY OF CHAR):BOOLEAN;
VAR i:CARDINAL;
BEGIN
    FOR i := 0 TO HIGH(s1) DO
        IF i > HIGH(s2) THEN
            RETURN s1[i] = 0C;
        ELSIF s1[i] <> s2[i] THEN
            RETURN FALSE;
        ELSIF s1[i] = 0C THEN
            RETURN TRUE;
        END;
    END;
    RETURN TRUE;
END stringEqual;


BEGIN
END StringStuff.


======
Start Uncompress.MOD
======

MODULE Uncompress;

(* Takes files encoded by Compress and restores them to their original
   state.
   Copyright 1986 by Jonathan Amsterdam.  All Rights Reserved. *)

FROM CharStream IMPORT charStream;
IMPORT CharStream;
FROM BitStream IMPORT bitStream;
IMPORT BitStream;
FROM MyTerminal IMPORT ClearScreen, pause, WriteCard, WriteLn, WriteString,
    WriteLnString, Write;
FROM InOut IMPORT ReadString;
FROM Huffman IMPORT huffTree, huffman, readCode, readTree;
FROM StringStuff IMPORT stringLen, stringCopy;

CONST stringlen = 60;

VAR inFileName, outFileName: ARRAY[0..stringlen] OF CHAR;

PROCEDURE doUncompress;
VAR inStream:bitStream;
    outStream:charStream;
    fileSize, i:CARDINAL;  (* number of characters in file *)
    hTree:huffTree;
BEGIN
    inStream := BitStream.connect(inFileName, TRUE);
    outStream := CharStream.connect(outFileName, FALSE);
    fileSize := BitStream.readCard(inStream);
    hTree := readTree(inStream);
    FOR i := 1 TO fileSize DO
        CharStream.write(outStream, readCode(inStream, hTree));
    END;
    CharStream.disconnect(outStream);
    BitStream.disconnect(inStream);
END doUncompress;


PROCEDURE doFileNames;
VAR len:CARDINAL;
BEGIN
    len := stringLen(inFileName);
    stringCopy(outFileName, inFileName);
    inFileName[len] := '.';
    inFileName[len+1] := 'P';
    inFileName[len+2] := 0C;
    outFileName[len] := '.';
    outFileName[len+1] := 'U';
    outFileName[len+2] := 0C;
END doFileNames;

BEGIN
    ClearScreen;
    WriteLnString("Uncompression program");
    WriteString('Input file (omit ".P"): ');
    ReadString(inFileName);
    doFileNames;
    doUncompress;
    pause('done--');
END Uncompress.
ile (omit ".P"): ');
    ReadString(inFileName);
    doFileNames;
    doUncompress;
    pause('done--');
END Unc