(********************************************************************)
(*                                                                  *)
(*  deflate.s7i   Deflate compression algorithm                     *)
(*  Copyright (C) 2013, 2015, 2020, 2023, 2024  Thomas Mertes       *)
(*                                                                  *)
(*  This file is part of the Seed7 Runtime Library.                 *)
(*                                                                  *)
(*  The Seed7 Runtime Library is free software; you can             *)
(*  redistribute it and/or modify it under the terms of the GNU     *)
(*  Lesser General Public License as published by the Free Software *)
(*  Foundation; either version 2.1 of the License, or (at your      *)
(*  option) any later version.                                      *)
(*                                                                  *)
(*  The Seed7 Runtime Library is distributed in the hope that it    *)
(*  will be useful, but WITHOUT ANY WARRANTY; without even the      *)
(*  implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR *)
(*  PURPOSE.  See the GNU Lesser General Public License for more    *)
(*  details.                                                        *)
(*                                                                  *)
(*  You should have received a copy of the GNU Lesser General       *)
(*  Public License along with this program; if not, write to the    *)
(*  Free Software Foundation, Inc., 51 Franklin Street,             *)
(*  Fifth Floor, Boston, MA  02110-1301, USA.                       *)
(*                                                                  *)
(********************************************************************)


include "bitdata.s7i";
include "huffman.s7i";


const integer: DEFLATE_END_OF_BLOCK is 256;


const proc: putLiteralOrLength (inout lsbOutBitStream: compressedStream,
    in integer: literalOrLength) is func
  begin
    if literalOrLength <= 143 then
      putBits(compressedStream, reverseBits[8][literalOrLength + 2#00110000], 8);
    elsif literalOrLength <= 255 then
      putBits(compressedStream, reverseBits[9][literalOrLength + 2#110010000 - 144], 9);
    elsif literalOrLength <= 279 then
      putBits(compressedStream, reverseBits[7][literalOrLength - 256], 7);
    else
      putBits(compressedStream, reverseBits[8][literalOrLength + 2#11000000 - 280], 8);
    end if;
  end func;


const proc: putLength (inout lsbOutBitStream: compressedStream,
    in integer: length) is func
  begin
    if length <= 10 then
      putLiteralOrLength(compressedStream, 254 + length);
    elsif length <= 18 then
      putLiteralOrLength(compressedStream, 265 + ((length - 11) >> 1));
      putBit(compressedStream, (length - 11) mod 2);
    elsif length <= 34 then
      putLiteralOrLength(compressedStream, 269 + ((length - 19) >> 2));
      putBits(compressedStream, (length - 19) mod 4, 2);
    elsif length <= 66 then
      putLiteralOrLength(compressedStream, 273 + ((length - 35) >> 3));
      putBits(compressedStream, (length - 35) mod 8, 3);
    elsif length <= 130 then
      putLiteralOrLength(compressedStream, 277 + ((length - 67) >> 4));
      putBits(compressedStream, (length - 67) mod 16, 4);
    elsif length <= 257 then
      putLiteralOrLength(compressedStream, 281 + ((length - 131) >> 5));
      putBits(compressedStream, (length - 131) mod 32, 5);
    elsif length = 258 then
      putLiteralOrLength(compressedStream, 285);
    else
      raise RANGE_ERROR;
    end if;
  end func;


const proc: putDistance (inout lsbOutBitStream: compressedStream,
    in integer: distance) is func
  begin
    case pred(distance) >> 2 of
      when {0}:
        putBits(compressedStream, reverseBits[5][pred(distance)], 5);
      when {1}:
        putBits(compressedStream, reverseBits[5][4 + ((distance - 5) >> 1)], 5);
        putBit(compressedStream, (distance - 5) mod 2);
      when {2 .. 3}:
        putBits(compressedStream, reverseBits[5][6 + ((distance - 9) >> 2)], 5);
        putBits(compressedStream, (distance - 9) mod 4, 2);
      when {4 .. 7}:
        putBits(compressedStream, reverseBits[5][8 + ((distance - 17) >> 3)], 5);
        putBits(compressedStream, (distance - 17) mod 8, 3);
      when {8 .. 15}:
        putBits(compressedStream, reverseBits[5][10 + ((distance - 33) >> 4)], 5);
        putBits(compressedStream, (distance - 33) mod 16, 4);
      when {16 .. 31}:
        putBits(compressedStream, reverseBits[5][12 + ((distance - 65) >> 5)], 5);
        putBits(compressedStream, (distance - 65) mod 32, 5);
      when {32 .. 63}:
        putBits(compressedStream, reverseBits[5][14 + ((distance - 129) >> 6)], 5);
        putBits(compressedStream, (distance - 129) mod 64, 6);
      when {64 .. 127}:
        putBits(compressedStream, reverseBits[5][16 + ((distance - 257) >> 7)], 5);
        putBits(compressedStream, (distance - 257) mod 128, 7);
      when {128 .. 255}:
        putBits(compressedStream, reverseBits[5][18 + ((distance - 513) >> 8)], 5);
        putBits(compressedStream, (distance - 513) mod 256, 8);
      when {256 .. 511}:
        putBits(compressedStream, reverseBits[5][20 + ((distance - 1025) >> 9)], 5);
        putBits(compressedStream, (distance - 1025) mod 512, 9);
      when {512 .. 1023}:
        putBits(compressedStream, reverseBits[5][22 + ((distance - 2049) >> 10)], 5);
        putBits(compressedStream, (distance - 2049) mod 1024, 10);
      when {1024 .. 2047}:
        putBits(compressedStream, reverseBits[5][24 + ((distance - 4097) >> 11)], 5);
        putBits(compressedStream, (distance - 4097) mod 2048, 11);
      when {2048 .. 4095}:
        putBits(compressedStream, reverseBits[5][26 + ((distance - 8193) >> 12)], 5);
        putBits(compressedStream, (distance - 8193) mod 4096, 12);
      when {4096 .. 8191}:
        putBits(compressedStream, reverseBits[5][28 + ((distance - 16385) >> 13)], 5);
        putBits(compressedStream, (distance - 16385) mod 8192, 13);
      otherwise:
        raise RANGE_ERROR;
    end case;
  end func;


const type: lookupDict is hash [string] integer;
const type: slidingWindowType is array [0 .. 32767] integer;

const type: deflateData is new struct
    var integer: uncompressedPos is 1;
    var lookupDict: dictionary is lookupDict.value;
    var slidingWindowType: slidingWindow is slidingWindowType times -32768;
    var array integer: literalOrLengthSymbolCount is [0 .. 285] times 0;
    var array integer: distanceSymbolCount is [0 .. 29] times 0;
  end struct;


const proc: deflateFixed (inout deflateData: deflateState, in string: uncompressed,
    in integer: limit, inout lsbOutBitStream: compressedStream) is func
  local
    var integer: pos is 0;
    var integer: posFound is 0;
    var integer: dictionaryPosFound is 0;
    var integer: length is 0;
    var integer: maxLength is 0;
    var integer: nextPos is 0;
  begin
    putBits(compressedStream, 1, 2);       # btype:  Fixed Huffman codes
    pos := deflateState.uncompressedPos;
    while pos <= limit do
      if pos < pred(length(uncompressed)) then
        posFound := update(deflateState.dictionary, uncompressed[pos fixLen 3], pos);
        if posFound <> pos and posFound >= pos - 32768 then
          maxLength := 258;
          if length(uncompressed) - pos < maxLength then
            maxLength := length(uncompressed) - pos;
          end if;
          length := 3;
          while length < maxLength and
                uncompressed[pos + length] = uncompressed[posFound + length] do
            incr(length);
          end while;
          dictionaryPosFound := posFound;
          nextPos := deflateState.slidingWindow[posFound mod 32768];
          while nextPos >= pos - 32768 and length < maxLength do
            if uncompressed[nextPos + 3 fixLen length - 2] = uncompressed[pos + 3 fixLen length - 2] then
              incr(length);
              posFound := nextPos;
              while length < maxLength and
                    uncompressed[pos + length] = uncompressed[posFound + length] do
                incr(length);
              end while;
            end if;
            nextPos := deflateState.slidingWindow[nextPos mod 32768];
          end while;
          deflateState.slidingWindow[pos mod 32768] := dictionaryPosFound;
          if length > 3 or pos - posFound <= 4096 then
            putLength(compressedStream, length);
            putDistance(compressedStream, pos - posFound);
            nextPos := pos + length;
            incr(pos);
            while pos < nextPos do
              if pos < pred(length(uncompressed)) then
                posFound := update(deflateState.dictionary, uncompressed[pos fixLen 3], pos);
                if posFound <> pos then
                  deflateState.slidingWindow[pos mod 32768] := posFound;
                end if;
              end if;
              incr(pos);
            end while;
          else
            putLiteralOrLength(compressedStream, ord(uncompressed[pos]));
            incr(pos);
          end if;
        else
          # Not necessary to update slidingWindow, since it is already outdated.
          putLiteralOrLength(compressedStream, ord(uncompressed[pos]));
          incr(pos);
        end if;
      else
        putLiteralOrLength(compressedStream, ord(uncompressed[pos]));
        incr(pos);
      end if;
    end while;
    putLiteralOrLength(compressedStream, DEFLATE_END_OF_BLOCK);
    deflateState.uncompressedPos := pos;
  end func;


const func integer: encodeLz77Length (in integer: length, inout integer: bits,
    inout integer: bitWidth) is func
  result
    var integer: symbol is 0;
  local
    var integer: rawSymbol is 0;
  begin
    if length <= 10 then
      bitWidth := 0;
      bits := 0;
      symbol := length + 254;
    elsif length <= 18 then
      bitWidth := 1;
      rawSymbol := length + 519;
      bits := rawSymbol mod 2;
      symbol := rawSymbol >> 1;
    elsif length <= 34 then
      bitWidth := 2;
      rawSymbol := length + 1057;
      bits := rawSymbol mod 4;
      symbol := rawSymbol >> 2;
    elsif length <= 66 then
      bitWidth := 3;
      rawSymbol := length + 2149;
      bits := rawSymbol mod 8;
      symbol := rawSymbol >> 3;
    elsif length <= 130 then
      bitWidth := 4;
      rawSymbol := length + 4365;
      bits := rawSymbol mod 16;
      symbol := rawSymbol >> 4;
    elsif length <= 257 then
      bitWidth := 5;
      rawSymbol := length + 8861;
      bits := rawSymbol mod 32;
      symbol := rawSymbol >> 5;
    else
      bitWidth := 0;
      bits := 0;
      symbol := 285;
    end if;
  end func;


const proc: addLz77Length (inout string: lz77, in integer: length,
    inout array integer: symbolCount) is func
  local
    var integer: symbol is 0;
    var integer: bits is 0;
    var integer: bitWidth is 0;
  begin
    symbol := encodeLz77Length(length, bits, bitWidth);
    incr(symbolCount[symbol]);
    lz77 &:= char(symbol);
    lz77 &:= char(bits);
    lz77 &:= char(bitWidth);
  end func;


const func integer: encodeLz77Distance (in integer: distance, inout integer: bits,
    inout integer: bitWidth) is func
  result
    var integer: symbol is 0;
  local
    var integer: rawSymbol is 0;
  begin
    case pred(distance) >> 2 of
      when {0}:
        bitWidth := 0;
        bits := 0;
        symbol := pred(distance);
      when {1}:
        bitWidth := 1;
        rawSymbol := distance + 3;
        bits := rawSymbol mod 2;
        symbol := rawSymbol >> 1;
      when {2 .. 3}:
        bitWidth := 2;
        rawSymbol := distance + 15;
        bits := rawSymbol mod 4;
        symbol := rawSymbol >> 2;
      when {4 .. 7}:
        bitWidth := 3;
        rawSymbol := distance + 47;
        bits := rawSymbol mod 8;
        symbol := rawSymbol >> 3;
      when {8 .. 15}:
        bitWidth := 4;
        rawSymbol := distance + 127;
        bits := rawSymbol mod 16;
        symbol := rawSymbol >> 4;
      when {16 .. 31}:
        bitWidth := 5;
        rawSymbol := distance + 319;
        bits := rawSymbol mod 32;
        symbol := rawSymbol >> 5;
      when {32 .. 63}:
        bitWidth := 6;
        rawSymbol := distance + 767;
        bits := rawSymbol mod 64;
        symbol := rawSymbol >> 6;
      when {64 .. 127}:
        bitWidth := 7;
        rawSymbol := distance + 1791;
        bits := rawSymbol mod 128;
        symbol := rawSymbol >> 7;
      when {128 .. 255}:
        bitWidth := 8;
        rawSymbol := distance + 4095;
        bits := rawSymbol mod 256;
        symbol := rawSymbol >> 8;
      when {256 .. 511}:
        bitWidth := 9;
        rawSymbol := distance + 9215;
        bits := rawSymbol mod 512;
        symbol := rawSymbol >> 9;
      when {512 .. 1023}:
        bitWidth := 10;
        rawSymbol := distance + 20479;
        bits := rawSymbol mod 1024;
        symbol := rawSymbol >> 10;
      when {1024 .. 2047}:
        bitWidth := 11;
        rawSymbol := distance + 45055;
        bits := rawSymbol mod 2048;
        symbol := rawSymbol >> 11;
      when {2048 .. 4095}:
        bitWidth := 12;
        rawSymbol := distance + 98303;
        bits := rawSymbol mod 4096;
        symbol := rawSymbol >> 12;
      when {4096 .. 8191}:
        bitWidth := 13;
        rawSymbol := distance + 212991;
        bits := rawSymbol mod 8192;
        symbol := rawSymbol >> 13;
      otherwise:
        raise RANGE_ERROR;
    end case;
  end func;


const proc: addLz77Distance (inout string: lz77, in integer: distance,
    inout array integer: symbolCount) is func
  local
    var integer: symbol is 0;
    var integer: bits is 0;
    var integer: bitWidth is 0;
  begin
    symbol := encodeLz77Distance(distance, bits, bitWidth);
    incr(symbolCount[symbol]);
    lz77 &:= char(symbol);
    lz77 &:= char(bits);
    lz77 &:= char(bitWidth);
  end func;


const func string: compressWithLz77 (inout deflateData: deflateState,
    in string: uncompressed, in integer: limit) is func
  result
    var string: lz77 is "";
  local
    var integer: pos is 0;
    var integer: posFound is 0;
    var integer: dictionaryPosFound is 0;
    var integer: length is 0;
    var integer: maxLength is 0;
    var integer: nextPos is 0;
  begin
    deflateState.literalOrLengthSymbolCount := [0 .. 285] times 0;
    deflateState.distanceSymbolCount := [0 .. 29] times 0;
    pos := deflateState.uncompressedPos;
    while pos <= limit do
      if pos < pred(length(uncompressed)) then
        posFound := update(deflateState.dictionary, uncompressed[pos fixLen 3], pos);
        if posFound <> pos and posFound >= pos - 32768 then
          maxLength := 258;
          if length(uncompressed) - pos < maxLength then
            maxLength := length(uncompressed) - pos;
          end if;
          length := 3;
          while length < maxLength and
                uncompressed[pos + length] = uncompressed[posFound + length] do
            incr(length);
          end while;
          dictionaryPosFound := posFound;
          nextPos := deflateState.slidingWindow[posFound mod 32768];
          while nextPos >= pos - 32768 and length < maxLength do
            if uncompressed[nextPos + 3 fixLen length - 2] = uncompressed[pos + 3 fixLen length - 2] then
              incr(length);
              posFound := nextPos;
              while length < maxLength and
                    uncompressed[pos + length] = uncompressed[posFound + length] do
                incr(length);
              end while;
            end if;
            nextPos := deflateState.slidingWindow[nextPos mod 32768];
          end while;
          deflateState.slidingWindow[pos mod 32768] := dictionaryPosFound;
          if length > 3 or pos - posFound <= 4096 then
            addLz77Length(lz77, length, deflateState.literalOrLengthSymbolCount);
            addLz77Distance(lz77, pos - posFound, deflateState.distanceSymbolCount);
            nextPos := pos + length;
            incr(pos);
            while pos < nextPos do
              if pos < pred(length(uncompressed)) then
                posFound := update(deflateState.dictionary, uncompressed[pos fixLen 3], pos);
                if posFound <> pos then
                  deflateState.slidingWindow[pos mod 32768] := posFound;
                end if;
              end if;
              incr(pos);
            end while;
          else
            incr(deflateState.literalOrLengthSymbolCount[ord(uncompressed[pos])]);
            lz77 &:= uncompressed[pos];
            incr(pos);
          end if;
        else
          # Not necessary to update slidingWindow, since it is already outdated.
          incr(deflateState.literalOrLengthSymbolCount[ord(uncompressed[pos])]);
          lz77 &:= uncompressed[pos];
          incr(pos);
        end if;
      else
        incr(deflateState.literalOrLengthSymbolCount[ord(uncompressed[pos])]);
        lz77 &:= uncompressed[pos];
        incr(pos);
      end if;
    end while;
    incr(deflateState.literalOrLengthSymbolCount[DEFLATE_END_OF_BLOCK]);
    deflateState.uncompressedPos := pos;
  end func;


const proc: huffmanEncodeLz77 (inout lsbOutBitStream: outStream,
    in string: lz77,  in huffmanEncoder: literalOrLengthEncoder,
    in huffmanEncoder: distanceEncoder) is func
  local
    var integer: index is 1;
    var integer: literalOrLength is 0;
    var integer: distance is 0;
  begin
    while index <= length(lz77) do
      literalOrLength := ord(lz77[index]);
      putHuffmanSymbol(outStream, literalOrLengthEncoder[literalOrLength]);
      incr(index);
      if literalOrLength > DEFLATE_END_OF_BLOCK then
        putBits(outStream, ord(lz77[index]), ord(lz77[succ(index)]));
        index +:= 2;
        distance := ord(lz77[index]);
        putHuffmanSymbol(outStream, distanceEncoder[distance]);
        putBits(outStream, ord(lz77[succ(index)]), ord(lz77[index + 2]));
        index +:= 3;
      end if;
    end while;
    putHuffmanSymbol(outStream, literalOrLengthEncoder[DEFLATE_END_OF_BLOCK]);
  end func;


const proc: checkMaximumCodeLength (inout array integer: codeLengths,
    in integer: allowedMaximum) is func
  local
    var boolean: aboveAllowedMaximum is FALSE;
    var integer: codeLength is 0;
  begin
    for codeLength range codeLengths until aboveAllowedMaximum do
      aboveAllowedMaximum := codeLength > allowedMaximum;
    end for;
    if aboveAllowedMaximum then
      reduceMaximumHuffmanCodeLength(codeLengths, allowedMaximum);
    end if;
  end func;


const func string: processCombinedData (in array integer: combinedData,
    inout array integer: symbolCount) is func
  result
    var string: dataString is "";
  local
    var integer: index is 1;
    var integer: combinedDataElement is 0;
    var integer: subIndex is 0;
    var integer: count is 0;
    var integer: factor is 0;
  begin
    index := minIdx(combinedData);
    while index <= maxIdx(combinedData) do
      combinedDataElement := combinedData[index];
      subIndex := succ(index);
      while subIndex <= maxIdx(combinedData) and
          combinedData[subIndex] = combinedDataElement do
        incr(subIndex);
      end while;
      count := subIndex - index;
      if count >= 3 then
        if combinedDataElement = 0 then
          if count <= 10 then
            incr(symbolCount[17]);
            dataString &:= '\17;';
            dataString &:= char(count - 3);
          else
            count := min(count, 138);
            incr(symbolCount[18]);
            dataString &:= '\18;';
            dataString &:= char(count - 11);
          end if;
          index +:= count;
        else
          incr(symbolCount[combinedDataElement]);
          dataString &:= char(combinedDataElement);
          decr(count);
          incr(index);
          while count >= 3 do
            factor := min(count, 6);
            incr(symbolCount[16]);
            dataString &:= '\16;';
            dataString &:= char(factor - 3);
            count -:= factor;
            index +:= factor;
          end while;
          while count >= 1 do
            incr(symbolCount[combinedDataElement]);
            dataString &:= char(combinedDataElement);
            decr(count);
            incr(index);
          end while;
        end if;
      else
        while count >= 1 do
          incr(symbolCount[combinedDataElement]);
          dataString &:= char(combinedDataElement);
          decr(count);
          incr(index);
        end while;
      end if;
    end while;
  end func;


const proc: huffmanEncodeCombinedData (inout lsbOutBitStream: compressedStream,
    in string: combinedDataString, in huffmanEncoder: combinedDataEncoder) is func
  local
    var integer: index is 1;
    var integer: combinedDataElement is 0;
  begin
    while index <= length(combinedDataString) do
      combinedDataElement := ord(combinedDataString[index]);
      if combinedDataElement <= 15 then
        putHuffmanSymbol(compressedStream, combinedDataEncoder[combinedDataElement]);
        incr(index);
      elsif combinedDataElement = 16 then
        putHuffmanSymbol(compressedStream, combinedDataEncoder[16]);
        putBits(compressedStream, ord(combinedDataString[succ(index)]), 2);
        index +:= 2;
      elsif combinedDataElement = 17 then
        putHuffmanSymbol(compressedStream, combinedDataEncoder[17]);
        putBits(compressedStream, ord(combinedDataString[succ(index)]), 3);
        index +:= 2;
      else # combinedDataElement = 18
        putHuffmanSymbol(compressedStream, combinedDataEncoder[18]);
        putBits(compressedStream, ord(combinedDataString[succ(index)]), 7);
        index +:= 2;
      end if;
    end while;
  end func;


const func array integer: mapCombinedDataCodeLengths (in array integer: codeLengths) is func
  result
    var array integer: mappedCodeLengths is 19 times 0;
  local
    const array integer: mapFromOrderedLengths is [0]
        (4, 18, 16, 14, 12, 10, 8, 6, 5, 7, 9, 11, 13, 15, 17, 19, 1, 2, 3);
    var integer: index is 0;
  begin
    for key index range codeLengths do
       mappedCodeLengths[mapFromOrderedLengths[index]] := codeLengths[index];
    end for;
    index := length(mappedCodeLengths);
    while index >= 1 and mappedCodeLengths[index] = 0 do
      decr(index);
    end while;
    mappedCodeLengths := mappedCodeLengths[.. index];
  end func;


const proc: deflateDynamic (inout deflateData: deflateState, in string: uncompressed,
    in integer: limit, inout lsbOutBitStream: compressedStream) is func
  local
    var string: lz77 is "";
    var array integer:  literalOrLengthCodeLengths is 0 times 0;
    var huffmanEncoder: literalOrLengthEncoder is huffmanEncoder.value;
    var array integer:  distanceCodeLengths is 0 times 0;
    var huffmanEncoder: distanceEncoder is huffmanEncoder.value;
    var array integer:  combinedData is 0 times 0;
    var string:         combinedDataString is "";
    var array integer:  combinedDataSymbolCount is [0 .. 18] times 0;
    var array integer:  combinedDataCodeLengths is 0 times 0;
    var huffmanEncoder: combinedDataEncoder is huffmanEncoder.value;
    var array integer: mappedCodeLengths is 0 times 0;
    var integer: number is 0;
  begin
    putBits(compressedStream, 2, 2);       # btype:  Dynamic Huffman codes
    lz77 := compressWithLz77(deflateState, uncompressed, limit);
    literalOrLengthCodeLengths := getHuffmanCodeLengths(deflateState.literalOrLengthSymbolCount);
    checkMaximumCodeLength(literalOrLengthCodeLengths, 15);
    distanceCodeLengths := getHuffmanCodeLengths(deflateState.distanceSymbolCount);
    checkMaximumCodeLength(distanceCodeLengths, 15);
    combinedData := literalOrLengthCodeLengths & distanceCodeLengths;
    combinedDataString := processCombinedData(combinedData, combinedDataSymbolCount);
    combinedDataCodeLengths := getHuffmanCodeLengths(combinedDataSymbolCount);
    checkMaximumCodeLength(combinedDataCodeLengths, 7);
    mappedCodeLengths := mapCombinedDataCodeLengths(combinedDataCodeLengths);
    putBits(compressedStream, length(literalOrLengthCodeLengths) - 257, 5);  # hlit
    putBits(compressedStream, length(distanceCodeLengths) - 1, 5);           # hdist
    putBits(compressedStream, length(mappedCodeLengths) - 4, 4);             # hclen
    for number range mappedCodeLengths do
      putBits(compressedStream, number, 3);
    end for;
    combinedDataEncoder := createHuffmanEncoder(combinedDataCodeLengths);
    huffmanEncodeCombinedData(compressedStream, combinedDataString,
                              combinedDataEncoder);
    literalOrLengthEncoder := createHuffmanEncoder(literalOrLengthCodeLengths);
    distanceEncoder := createHuffmanEncoder(distanceCodeLengths);
    huffmanEncodeLz77(compressedStream, lz77, literalOrLengthEncoder,
                      distanceEncoder);
  end func;


const proc: uncompressedBlock (inout deflateData: deflateState,
    in string: uncompressed, in var integer: uncompressedSize,
    inout lsbOutBitStream: compressedStream, in boolean: bfinal) is func
  local
    const integer: uncompressedBlockMaxSize is pred(2 ** 16);
  begin
    while uncompressedSize > uncompressedBlockMaxSize do
      putBit(compressedStream, 0);
      putBits(compressedStream, 0, 2);
      write(compressedStream, "\255;\255;\255;\255;");
      write(compressedStream, uncompressed[deflateState.uncompressedPos fixLen uncompressedBlockMaxSize]);
      deflateState.uncompressedPos +:= uncompressedBlockMaxSize;
      uncompressedSize -:= uncompressedBlockMaxSize;
    end while;
    putBit(compressedStream, ord(bfinal));
    putBits(compressedStream, 0, 2);
    write(compressedStream, bytes(uncompressedSize, UNSIGNED, LE, 2) &
                            bytes(uncompressedSize, UNSIGNED, LE, 2));
    if uncompressedSize <> 0 then
      write(compressedStream, uncompressed[deflateState.uncompressedPos fixLen uncompressedSize]);
      deflateState.uncompressedPos +:= uncompressedSize;
    end if;
  end func;


const proc: deflateBlock (inout deflateData: deflateState,
    in string: uncompressed, in integer: limit,
    inout lsbOutBitStream: compressedStream, in boolean: bfinal) is func
  local
    var integer: uncompressedStart is 0;
    var integer: uncompressedSize is 0;
    var integer: compressedStart is 0;
    var integer: compressedSize is 0;
  begin
    uncompressedStart := deflateState.uncompressedPos;
    uncompressedSize := succ(limit - uncompressedStart);
    compressedStart := length(compressedStream);
    if uncompressedSize <= 66 then
      # For this cases deflateFixed compresses better than deflateDynamic.
      putBit(compressedStream, ord(bfinal));
      deflateFixed(deflateState, uncompressed, length(uncompressed), compressedStream);
    else
      # For uncompressedSize >= 5555 deflateDynamic compresses better than deflateFixed.
      # For around 92% of the cases getween 67 and 5554 deflateDynamic compresses better.
      putBit(compressedStream, ord(bfinal));
      deflateDynamic(deflateState, uncompressed, length(uncompressed), compressedStream);
    end if;
    compressedSize := succ(pred(length(compressedStream) - compressedStart) mdiv 8);
    if compressedSize >= uncompressedSize + 4 then
      deflateState.uncompressedPos := uncompressedStart;
      truncate(compressedStream, compressedStart);
      uncompressedBlock(deflateState, uncompressed, uncompressedSize, compressedStream, bfinal);
    end if;
  end func;


(**
 *  Compress a string with the DEFLATE algorithm.
 *  DEFLATE is a compression algorithm that uses a combination of
 *  the LZ77 algorithm and Huffman coding.
 *)
const proc: deflateBlock (in string: uncompressed,
    inout lsbOutBitStream: compressedStream, in boolean: bfinal) is func
  local
    var deflateData: deflateState is deflateData.value;
  begin
    deflateBlock(deflateState, uncompressed, length(uncompressed),
                 compressedStream, bfinal);
  end func;


const func string: deflate (in string: uncompressed) is func
  result
    var string: compressed is "";
  local
    var lsbOutBitStream: compressedStream is lsbOutBitStream.value;
  begin
    deflateBlock(uncompressed, compressedStream, TRUE);
    flush(compressedStream);
    compressed := getBytes(compressedStream);
  end func;