unit packer;

interface

function ReadFile(Filename:string; size:longint; where:word):byte;
function WriteFile(name:string; size:longint; from:word):byte;
function CompressRLE(size:longint; from, dest: word): word;
function DecompressRLE(filesize, from, dest: word): longint;
function ChangeExtension(const FileName, NewExt: string): string;



implementation

uses crt;

const
  Signature: array[0..2] of Char = ('7','p','k');

var
freq:array[0..255] of word;


function ChangeExtension(const FileName, NewExt: string): string;
var
  i, DotPos: Byte;
begin
  DotPos := 0;
  for i := Length(FileName) downto 1 do
    if FileName[i] = '.' then
    begin
      DotPos := i;
      Break;
    end;

  if DotPos = 0 then
    ChangeExtension := FileName + '.' + NewExt
  else
    ChangeExtension := Copy(FileName, 1, DotPos) + NewExt;
end;


function CRC16(size:longint; where: word): word;
var
  crc: Word;
  i, j: word;
  byteVal: Byte;
begin
  crc := $FFFF;  {start value}
  for i := 0 to word(size - 1) do
  begin
    byteVal := mem[where:i];
    crc := crc xor (byteVal shl 8);
    for j := 0 to 7 do
    begin
      if (crc and $8000) <> 0 then
        crc := (crc shl 1) xor $1021
      else
        crc := crc shl 1;
    end;
  end;
  CRC16 := crc;
end;

function ReadFile(Filename:string; size:longint; where:word):byte;
var
fr:file;
l:longint;
n:word;
b:byte;
begin
Assign(fr, filename);
Reset(fr, 1);
if IOResult<>0 then begin ReadFile:=1; exit; end;
n:=0;
for l:=1 to size do
   begin
      BlockRead(fr, b, 1);
      if IOResult<>0 then begin ReadFile:=2; exit; end;
      mem[where:n]:=b;
      inc(n);
   end;
Close(fr);
ReadFile:=0;
end;


function WriteFile(name:string; size:longint; from:word):byte;
var
i:word;
fw:file;
begin
  Assign(fw, name);
  Rewrite(fw,1);
  if IOResult<>0 then begin WriteFile:=1; exit; end;
  for i:=0 to word(size-1) do begin
     BlockWrite(fw, mem[from:i], 1);
     if IOResult<>0 then begin WriteFile:=2; exit; end;
  end;
  Close(fw);
  WriteFile:=0;
end;

function FindRareByte(size:longint; where: word):byte;
var n, min: word;
b:byte;
begin
  for n:=0 to 255 do freq[n]:=0;
  for n := 0 to size - 1 do Inc( freq[ mem[where:n] ]);

  min := 65535;
  b := 0;
  for n := 0 to 255 do
    if freq[n] < min then
    begin
      min := freq[n];
      b := n;
    end;
  FindRareByte := b;
end;



function CompressRLE(size:longint; from, dest: word): word;
var
  i, j, count, outPtr: longint;
  cur, marker: Byte;
begin
  marker:=FindRareByte(size, from);
  {WriteLn('Marker: ', marker, '( ',freq[marker],' takih byte v originale)');}

  {zagolovok}
  for i := 0 to 2 do mem[dest:i] := byte(Signature[i]);
  memW[dest:3] := crc16(size, from);
  memW[dest:5] := word(size-1); {original size}
  memW[dest:7] := $0000;        {packed size}
  mem[dest:9]  := marker;

  outPtr := 10;
  i := 0;
  while i < size do
  begin
    cur := mem[from:i];
    count := 1;

    while (i + count < size) and (mem[from:i + count] = cur) and (count < 255)
    do Inc(count);

    if (count > 3) and (cur <> marker) then
    begin
         mem[dest:word(outPtr)] := marker;
         mem[dest:word(outPtr+1)] := cur;
         mem[dest:word(outPtr+2)] := count;
         Inc(outPtr, 3);
         Inc(i, count);
    end
    else
    begin
          for j := 0 to count - 1 do
             if mem[from:i + j] = marker then
                 begin
                 mem[dest:word(outPtr)]   := marker;
                 mem[dest:word(outPtr+1)] := marker;
                 Inc(outPtr, 2);
                 end
             else
                 begin
                 mem[dest:word(outPtr)] := mem[from:i + j];
                 Inc(outPtr);
                 end;

         Inc(i, count);
    end;

    if outPtr>65533 then begin WriteLn('Packed size too big!'); CompressRLE:=0; exit; end;

  end;

  memW[dest:7] := outPtr; {set packed size}
  if odd(outPtr) then inc(outPtr); {dobavlyem fictivnyy razmer estli ne chetn}
  CompressRLE  := outPtr;

end;




function DecompressRLE(filesize, from, dest: word): longint;
var
  packsize, crc, i, j: Word;
  outPtr, origLen:longint;
  cur, marker, count: Byte;
begin
  for i := 0 to 2 do
    if mem[from:i] <> byte(signature[i]) then
    begin
      {WriteLn('Signature fail');}
      DecompressRLE := 0;
      Exit;
    end;

  crc      := memW[from:3];
  origLen  := Longint(memW[from:5])+1;
  packsize := memW[from:7];
  marker   := mem[from:9];

  {razmer faila men'she razmera dannyh ukazanogo v zagolovke, cheto ne to}
  if filesize<packsize then begin DecompressRLE := 3; exit; end;

  i := 10;
  outPtr := 0;

  while i < packsize do
  begin
       if mem[from:i] = marker then
       begin
           if mem[from:i+1] = marker then
              begin
                 mem[dest:outPtr] := marker;
                 Inc(outPtr); Inc(i,2);
              end
              else
              begin
                 cur := mem[from:i+1];
                 count := mem[from:i+2];
                 for j := 1 to count do begin
                     mem[dest:outPtr] := cur;
                     Inc(outPtr);
                     end;
                 Inc(i,3);
              end;
        end
        else
        begin
              mem[dest:word(outPtr)] := mem[from:word(i)];
              inc(outPtr);
              inc(i);
        end;
  end;

  if outPtr<>origLen then DecompressRLE:=1 {depack size wrong}
  else if crc<>crc16(outPtr, dest) then DecompressRLE:=2 {crc wrong}
  else DecompressRLE := outPtr;
end;




end.