{packer do RIP'ow}
{uzywa POWER.pas by madman/MADTEAM}
uses crt,dos;
var f,g:file;
    m,n:file of byte;
    lhea,p,err,h1,h2,h3,a1,a2,a3,a4,stc0,stc1:word;
    bit,all,ln,lnght,bb:longint;
    ind,iun,iof,b3,last_o,bm,frm,k,i,j,d,l,a,x,t,s:integer;
    max_l,max_p,max_x,tre_i:integer;
    tmp,tryb:byte;
    buf:array [0..20300] of byte;
    tab:array [0..575] of record
                       l:byte;
                       v:word;
                       end;
    btt:array [0..4000] of byte;
    boo:array [0..8000] of byte;
    bll,bmm:array [0..13000] of byte;
    q,v:array[0..7] of byte;
    huf:array [0..256] of record
                        l:word;
                        v:word;
                       end;
    tre01:array [0..511] of word;
    pom:array [0..15] of byte;
    dirinfo:searchrec;
    rip:array [0..255] of byte;
    hip:array [0..5] of word;
    nam,map,hea,inp,pal:string[16];
    nazwa,naz,naz1,naz2:string;
    label lab1,lab2,lab3,lab4,lab5,lab6,pck;

const
     msk:array [1..16] of word=
     ($8000,$4000,$2000,$1000,$0800,$0400,$0200,$0100,$0080,$0040,$0020,
      $0010,$0008,$0004,$0002,$0001);

     head=16;
     unpack=0;
     pack=1;

     min_lzs=2;
     match=64;
     max_lzs=min_lzs+match-1;
     dic=256;
     max_dic=dic+min_lzs-1;
     min_dic=0;

{     inp='aaa.rip';}


procedure error;
begin
writeln;
writeln('Mem sux: ',iun,'-[',sizeof(bll),'] ',iof,'-[',sizeof(boo),']');
erase(m);
halt;
end;

procedure sav(b:byte);
begin
 write(m,b);
 inc(lnght);
end;

function lowhi(w:word):string;
begin
lowhi:=chr(w div 256)+chr(w mod 256);
end;

procedure head_hip(mpal:byte;mwys,msiz:word);
begin
write('Info:'); read(nazwa);
naz1:='RIP1.6  '+lowhi(0);
naz2:=lowhi(80)+lowhi(mwys)+lowhi(length(nazwa))+'T:'+nazwa+chr(lo(mpal))+'CM:';
naz2:=naz2+pal;
naz:=naz1+lowhi(length(naz1)+length(naz2)+2)+naz2;

j:=length(naz); for i:=0 to j-1 do rip[i]:=ord(naz[i+1]);
rip[7]:=tryb;

assign(g,'tmp.$$$'); rewrite(g,1);
 blockwrite(g,rip,j,err); blockwrite(g,buf,msiz,err);
close(g); nam:='RIP';
findfirst('tmp.$$$',archive,dirinfo);
assign(f,'tmp.$$$');reset(f,1);
end;

function bajt:byte;
begin
  bajt:=$80*q[0]+$40*q[1]+$20*q[2]+$10*q[3]+8*q[4]+4*q[5]+2*q[6]+q[7];
  fillchar(q,sizeof(q),0);
end;
function bajt2:byte;
begin
  bajt2:=$80*v[0]+$40*v[1]+$20*v[2]+$10*v[3]+8*v[4]+4*v[5]+2*v[6]+v[7];
  fillchar(v,sizeof(v),0);
end;

function gbit:byte;
begin
gbit:=btt[ind] and $80; btt[ind]:=btt[ind] shl 1;
inc(t); if t>7 then begin t:=0; inc(ind); end;
end;

procedure sav_bit(b:byte);           { zapisz 1 bit }
begin
q[t]:=b; inc(t); {write(b);}
 if t>7 then begin
  btt[ind]:=bajt; inc(ind); t:=0; if ind>sizeof(btt) then error;
 end;
end;

procedure savbit(o:word;ol:byte);    { zapisz N bitow }
var i:byte;
begin
for i:=0 to ol-1 do begin
  v[s]:=(o and $8000) shr 15; o:=o shl 1; inc(s);
   if s>7 then begin sav(bajt2); s:=0; inc(j); end;
 end;
end;

procedure min(max_:integer);
begin                    {p - minimum   err - indeks wartosci}
p:=$ffff; err:=$100;
 for a:=0 to max_-1 do begin
  if (huf[a].l<p) and (huf[a].l<>0) then begin p:=huf[a].l; err:=a; end;
 end;
end;

procedure sort(max_s:integer);
begin
{
dlugosci kodow do tablicy zapasowej tre01
aby potem przywrocic stare uporzadkowanie
}
for a:=0 to max_s-1 do begin tre01[a]:=a; tre01[a+256]:=huf[a].l; end;

{ B U B B L E  sort za wolna, zastapila ja VFAST}
{
for i:=0 to max_s-1 do begin
 for j:=0 to max_s-1 do begin
  if tre01[i+256]<tre01[j+256] then begin
   p:=tre01[i+256]; tre01[i+256]:=tre01[j+256]; tre01[j+256]:=p;
   p:=tre01[i]; tre01[i]:=tre01[j]; tre01[j]:=p;
  end;
 end;
end;
}

{ V F A S T }

l:=0;
for j:=0 to 15 do begin
 for i:=0 to max_s-1 do begin
  if tre01[i+256]=j then begin tre01[l]:=i; inc(l); end;
 end;
end;

for i:=0 to 15 do pom[i]:=0;
 for i:=0 to max_s-1 do inc(pom[tre01[i+256]]);
l:=0;
 for i:=0 to 15 do begin
  for j:=1 to pom[i] do begin
   tre01[l+256]:=i; inc(l);
  end;
 end;

{for a:=0 to 63 do writeln(tre01[a+256],',',tre01[a]);halt;}
end;

procedure bin(v:word);
begin
 for a:=0 to 15 do begin
  write((v and $8000) shr 15); v:=v shl 1;
 end;
end;



{
generujemy kody na podstawie danych dlugosci bitow
}

{**** S H A N N O N - F A N O ****}

procedure fano(max_i:integer);
begin

sort(max_i);  { sortujemy dlugosci bitow }
p:=0;         { code }
err:=0;       { code increment }
l:=0;         { last bit length }

for i:=max_i-1 downto 0 do begin

 if tre01[i+256]<>0 then begin
 p:=p+err;
  if tre01[i+256]<>l then begin l:=tre01[i+256]; err:=msk[l]{1 shl (16-l);} end;
  huf[tre01[i]].v:=p xor $ffff; huf[tre01[i]].l:=tre01[i+256];
 end;
end;

end;



{
huf.l - liczba wystepowan danego elementu /T
huf.v - kod elementu /T
tre01 - lewy i prawy lisc galezi /T
tre_i - indeks nowej galezi w drzewie /W
p     - wartosc minimalna liczby wystepowan elementu /W
err   - indeks wartosci minimalnej /W
j     - wysokosc drzewka /W
}

{**** H U F F M A N ****}

procedure hufman(max_h:integer);
begin

tre_i:=0;
err:=0;
fillchar(tre01,sizeof(tre01),0);
for a:=0 to 255 do huf[a].v:=a;        { huf.v - wartosci 0..255 }
                                       { huf.l - ilosc danego elementu }
{* TWORZENIE DRZEWKA *}                { stc0,p - wartosc min }
while err<>$100 do begin               { stc1,err - indeks min w huf.l}
min(max_h); stc0:=p; stc1:=err; huf[err].l:=0;        { 1 wartosc minimalna }
min(max_h); huf[err].l:=0;                            { 2 wartosc minimalna }

tre01[tre_i]:=huf[stc1].v;             { nowa galaz }
tre01[tre_i+1]:=huf[err].v;
huf[stc1].l:=stc0+p;            { nowa liczba elementow, suma 1 i 2 minimum }
huf[stc1].v:=tre_i div 2+$100; inc(tre_i,2);             { wpisz kod galezi }
end;

dec(tre_i,2); j:=tre_i div 2;          { wysokosc drzewka(j) }

{* SZUKANIE KOMBINACJI BITOW W DRZEWKU *}
for x:=0 to max_h-1 do begin
a:=x;
i:=0;
l:=0;
err:=$8000;      { kod bitowy 10000... }
huf[x].v:=0;

while (i div 2)<j do begin
 while (tre01[i]<>a) and (i<tre_i) do inc(i);
 if i<tre_i then begin
  huf[x].v:=huf[x].v or (i and 1)*err; err:=err shr 1;
{  write(i and 1);}
  inc(l); if l>15 then begin writeln('Fatal error!'); halt; end;  { ???? }
  a:=(i div 2)+$100;
 end;
end;

huf[x].l:=l;               { dlugosc kodu w bitach }
end;

{ wyjatek gdy j=0 czyli w drzewku wystapil tylko jeden element }
{ wstawiamy dodatkowy element (xor $ff) aby depacker zadzialal }
 if j=0 then begin huf[stc1].l:=1; huf[stc1 xor $ff].l:=1; end;
end;




{ M A I N }
begin
all:=0;

writeln;
writeln('RIP Packer V1.4 --- (c) 1998 Madman/Madteam');writeln;

if paramcount<1 then begin
 writeln('Usage: RIPPCK [ripfile,hipfile,micfile]');
 writeln('MIC extension: G8, G9, G10, G11, G15, C16, I15, I8'); halt;
end;

inp:=paramstr(1);

{inp:='k.rip';}

for frm:=0 to 0 do begin
str(frm,map); map:=inp{+map+'.mic'};

fillchar(buf,sizeof(buf),0);
fillchar(btt,sizeof(btt),0);
fillchar(bmm,sizeof(bll),0);
fillchar(bll,sizeof(bmm),0);

findfirst(map,archive,dirinfo);
if doserror<>0 then begin write('File not found.'); halt; end;
if dirinfo.size>sizeof(buf) then begin write('File to long.'); halt; end;

i:=pos('.',inp); nam:=inp; nam:=copy(nam,i+1,3);         { file extension }
tryb:=$20; pal:='         ';

for i:=1 to length(nam) do nam[i]:=upcase(nam[i]);

if nam='I15' then tryb:=$1e;
if nam='I8' then tryb:=$1f;
if nam='C16' then tryb:=$10;
if nam='G8' then tryb:=$0f;
if nam='G9' then tryb:=$4f;
if nam='G10' then tryb:=$8f;
if nam='G11' then tryb:=$cf;
if (nam='G15') or (nam='MIC') then tryb:=$0e;

if tryb<>$20 then nam:='MIC';

{* czy MIC *}
if nam='MIC' then begin
ln:=dirinfo.size;
 if (ln mod 40)=0 then begin writeln('I need colour palette.'); halt; end;
  assign(f,inp); reset(f,1); blockread(f,buf,ln,err); close(f);
for i:=0 to 8 do rip[i]:=0;

if tryb=$10 then begin
  rip[0]:=buf[ln-8]; rip[1]:=buf[ln-7]; rip[2]:=buf[ln-6]; rip[3]:=buf[ln-5];
  rip[4]:=buf[ln-4]; rip[5]:=buf[ln-3]; rip[6]:=buf[ln-2]; rip[7]:=buf[ln-1];
 end else begin
  rip[8]:=buf[ln-4]; rip[4]:=buf[ln-3]; rip[5]:=buf[ln-2]; rip[6]:=buf[ln-1];
end;
for i:=0 to 8 do pal[i+1]:=chr(rip[i]);
if tryb=$10 then head_hip(9,(((ln-8) div 40) div 2),ln-8)
else if (tryb=$1e) or (tryb=$1f) then head_hip(9,(((ln-4) div 40) div 2),ln-4)
else head_hip(9,((ln-4) div 40),ln-4);

goto pck;
end;


assign(f,map); reset(f,1);               { sprawdzenie naglowka }
blockread(f,hip,6,err);
nam:=chr(lo(hip[0]))+chr(hi(hip[0]))+chr(lo(hip[1]));

{ czy HIP Hard'ow 16012 byte }
if (hip[0]=$ffff) and (hip[1]=$6010) and (hip[2]=$7f4f) then begin
seek(f,6); blockread(f,buf,8006,err); blockread(f,buf[8000],8000,err); close(f);
pal:=chr(0)+chr(0)+chr(2)+chr(4)+chr(6)+chr(8)+chr(10)+chr(12)+chr(14);
head_hip(9,200,16000); goto pck;
end;

{ inny HIP 16009 byte z paleta kolorow }
if (nam<>'RIP') and (dirinfo.size=16009) then begin
 seek(f,0); blockread(f,buf[8000],8000,err); blockread(f,buf,8000,err);
 blockread(f,rip,9,err);
for i:=0 to 8 do pal[i+1]:=chr(rip[i]); close(f);
head_hip(9,200,16000); goto pck;
end;

{ czy RIP }
pck:
if nam<>'RIP' then halt;
seek(f,11);
blockread(f,lhea,2,err);             { dlugosc naglowka RIP'a }
seek(f,0); blockread(f,rip,lhea,err);
ln:=dirinfo.size-lhea;
blockread(f,buf,ln,err);
close(f);

if rip[9]>0 then halt;               { czy byl pakowany }
erase(f);

nam:=map; delete(nam,pos('.',nam),4);
assign(m,nam+'.rip'); rewrite(m);
seek(m,head+288+lhea);                    { omijamy head bajtow - naglowek }


{ L E T ' S  G O }

lnght:=0; bit:=0; t:=0; s:=0; ind:=0; bm:=0; iun:=0; iof:=0;

{
boo - ofsety /T
iof - indeks dla wartosci ofset (8 bit)
bmm - len_match /T
bm  - indeks dla wartosci len_match (4 bit)
bll - unpack byte /T
iun - indeks dla wartosci unpack (8 bit)
}


write('Name:',map,'   Compress:');


{d,j - indeks slownika  i,p - indeks danych}

{ L Z S S }
d:=0;          { startujemy }
p:=min_dic;    { zapisz min_dic bajtow jako niespakowane }

lab1:
j:=d; max_l:=0;
i:=p;

lab2:
while (buf[j]<>buf[i]) and (j<i) do inc(j);
x:=j;

l:=0; while (buf[j]=buf[i]) and (j<p) and (j-d<max_dic) and (l<max_lzs) do begin
   inc(l); inc(j); inc(i);
  end;

 if (l<min_lzs) and (j<>i) then begin
  j:=x+1; i:=p; goto lab2;
 end;

if l>max_l then begin max_l:=l; max_p:=p; max_x:=x; end;
if j<p then begin j:=x+1;i:=p; goto lab2; end;

str(100-round((i/ln)*100),map); write(map,'% '); gotoxy(wherex-length(map)-2,wherey);

l:=max_l;
if l>=min_lzs then begin
x:=max_x; p:=max_p;
 k:=lo(p-x-min_lzs);
   inc(bit,8+6+1); {write(k,',');}
   boo[iof]:=k; inc(iof);     { ofset znalezionego ciagu }
       if iof>sizeof(boo) then error;
    sav_bit(pack); k:=l-min_lzs;
    bmm[bm]:=k; inc(bm);      { dlugosc ciagu }  {write(k,',');}
       if bm>sizeof(bmm) then error;
 end else begin
inc(bit,8+1); l:=1;           { 1 niespakowany byte }
sav_bit(unpack); bll[iun]:=buf[p]; inc(iun); {write(buf[p],',');}
       if iun>sizeof(bll) then error;
end;

lab5:
inc(p,l); if (p-d>=max_dic) then inc(d,l);
if p<ln then goto lab1;


{
dlugosci kodow 4bit (288byte)
znaczniki 1bitowe
h1 - kompresja match_len
h2 - kompresja ofset
h3 - kompresja unpack
}

{
fillchar(huf,sizeof(huf),0);
findfirst('t.txt',archive,dirinfo);
assign(n,dirinfo.name); reset(n);
bm:=dirinfo.size;
for a:=0 to bm-1 do begin read(n,tmp); huf[a].l:=tmp-97; end;
close(n); fano(64);
}


a1:=ind*8+t;                       { dlugosc ciagow znacznikow 1 bitowych }
if t<>0 then btt[ind]:=bajt;

{for a:=0 to ind-1 do sav(btt[a]);
if t<>0 then begin inc(ind); inc(bit); sav(bajt); end;}
a2:=head+288{+ind};

{ **** match_lenght **** }
d:=bm;
fillchar(huf,sizeof(huf),0); for a:=0 to d-1 do inc(huf[bmm[a]].l);
hufman(64);
 for a:=0 to 63 do tab[a].l:=huf[a].l; fano(64); a3:=a2+j;
 for a:=0 to 63 do tab[a].v:=huf[a].v;
{j:=0; s:=0; for a:=0 to d-1 do savbit(huf[bmm[a]].v,huf[bmm[a]].l);
if s<>0 then begin sav(bajt2); inc(j); end; writeln(d,'-',j,'=',d-j);}

{ **** ofset **** }
d:=iof;
fillchar(huf,sizeof(huf),0); for a:=0 to d-1 do inc(huf[boo[a]].l);
hufman(256);
 for a:=0 to 255 do tab[a+64].l:=huf[a].l; fano(256); a4:=a3+j;
 for a:=0 to 255 do tab[a+64].v:=huf[a].v;
{j:=0; s:=0; for a:=0 to d-1 do savbit(huf[boo[a]].v,huf[boo[a]].l);
if s<>0 then begin sav(bajt2); inc(j); end; writeln(d,'-',j,'=',d-j);}

{ **** unpack **** }
d:=iun;
fillchar(huf,sizeof(huf),0); for a:=0 to d-1 do inc(huf[bll[a]].l);
hufman(256);
 for a:=0 to 255 do tab[a+256+64].l:=huf[a].l; fano(256);
 for a:=0 to 255 do tab[a+256+64].v:=huf[a].v;
{j:=0; s:=0; for a:=0 to d-1 do savbit(huf[bll[a]].v,huf[bll[a]].l);
if s<>0 then begin sav(bajt2); inc(j); end; writeln(d,'-',j,'=',d-j);}

seek(m,head+lhea);                        { dlugosci kodow 4bit'owe }
s:=0; for a:=0 to 575 do savbit(tab[a].l shl 12,4);

{ **** S A V E **** }
{ zapisujemy spakowany plik, bit prefiksu(0,1) - unpack lub ofset+len }
ind:=0; t:=0; s:=0; j:=0;
bm:=0; iof:=0; iun:=0;

for a:=0 to a1-1 do begin
 if gbit=0 then begin
  savbit($0000,1);
  savbit(tab[256+64+bll[iun]].v,tab[256+64+bll[iun]].l); inc(iun);
 end else begin
  savbit($8000,1);
  savbit(tab[64+boo[iof]].v,tab[64+boo[iof]].l); inc(iof);
  savbit(tab[bmm[bm]].v,tab[bmm[bm]].l); inc(bm);
 end;
end;
if s<>0 then sav(bajt2);      { zapisz ostatnie bity }


{***** S T O R E D *****}
if lnght>ln then begin
rewrite(m); seek(m,head+lhea); bit:=0;
 for a:=0 to ln-1 do begin write(m,buf[a]); inc(bit,8); end;
lnght:=ln; tmp:=0; a1:=0; a2:=head;
end;

ln:=ln+lhea;
gotoxy(wherex,wherey); err:=wherex;
tmp:=round((lnght/ln)*100);                        { stopien kompresji }
writeln(tmp,'%','   Original:',ln,'   Packed:',lnght);

all:=all+bit;
end;

seek(m,0);

{
0..2    PCK                                 3byte
3       stopien kompresji - 7bit            1byte /tmp
4..5    dlugosc danych przed kompresja      2byte /ln
6..7    dlugosc danych po kompresji         2byte /lnght
8..9    liczba znacznikow 1bitowych         2byte /a1
10..11  ofset do spakowanych danych         2byte /a2
12..13  ofset przesuniecia danych           2byte /a3

14..15  niewykorzystane

/dlugosci kodow dla 3 drzew - 4bit   288byte/
}

a3:=ln-lnght-head+16+16;
a4:=0;                       { nieuzywane w tej wersji }

hea:='PCK'+chr(tmp)+chr(lo(ln))+chr(hi(ln));
hea:=hea+chr(lo(lnght))+chr(hi(lnght));
hea:=hea+chr(lo(a1))+chr(hi(a1));
hea:=hea+chr(lo(a2))+chr(hi(a2));
hea:=hea+chr(lo(a3))+chr(hi(a3));
hea:=hea+chr(lo(a4))+chr(hi(a4));

if rip[7]=0 then rip[7]:=tryb;          { tryb graficzny }
rip[9]:=1;                              { kompresja nr 1 czyli PCK }
for a:=0 to lhea-1 do write(m,rip[a]);
for a:=1 to head do begin tmp:=ord(hea[a]); write(m,tmp); end;

close(m);
end.