unit GRPutil;
{$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF NEWFPC}{$CALLING OLDFPCCALL}{$ENDIF}
{$F+}
interface

const
MAX_GRP_CISLOVANYCH_SOUBORU = 99;

GRP_DESC_FILE = 'MAPA.DAT';

type
TGRP_zaznam_element = packed record
        oznaceni:longint;
        nazev:string[12];
        odkaz:pointer;
        end;

PGRP_zaznamy = ^TGRP_zaznamy;
TGRP_zaznamy = array[1..MAX_GRP_CISLOVANYCH_SOUBORU] of TGRP_zaznam_element;

{TGRPmapa predpoklada, ze uvnitr GRP archivu se nachazi soubor GRP_DESC_FILE,
 tedy 'MAPA.DAT'.
 Uvnitr tohoto souboru je seznam zajmovych souboru oznacenych ciselnym
 paramatrem.
 Priklad:
 *SILA_MYS.TXT = 1
 *SILA_PES.TXT = 10
 *SILA_PAV.NDF
 *SILA_KUN.TXT = 50

 Cast pred rovna se se dostane do TGRP_zaznam_element.nazev, cast za
 rovna se do TGRP_zaznam_element.oznaceni.
 Pokud cast s rovna se chybi (jako v SILA_PAV.NDF), tak se do <oznaceni>
 dosadi 0.
 Krome toho lze v MAPA.DAT definovat az 8 ciselnych parametru pojmenovanych
 PARAM0..PARAM7 s tim, ze mohou mit volitelne upresneni
 Priklad:
 Param1 (utok) = 10
 Param2 (obrana) = 50
 Param3 = 120
 Param4 "stesti" = 3
 }

PGRPmapa = ^TGRPmapa;
TGRPmapa = object
    num:byte;
    info:array[0..9] of longint;
    zaznam:PGRP_zaznamy;
    setrideno_podle_oznaceni:boolean;
    __vel:longint;
    Procedure Init(n:byte);
    Procedure Resize(n:byte);
    Procedure Setrid;
    Function Dej_nazev(n:byte):string;
    Function Dej_oznaceni(n:byte):byte;
    Function Index_podle_oznaceni(i:longint):byte;
    Function Nejblizsi_k_oznaceni(hodnota:longint):longint;
    Function Dej_Retezec_s_velikostmi:string;
    Procedure Done;
    end;

Function Vytahni_mapovy_soubor_GRP(s:string;var m:TGRPmapa):boolean;
Function Rozbal_GRP_archiv(s,kam:string):byte;

type
TRozbal_GRP_archiv_report_proc = procedure(var s:string);

var
Rozbal_GRP_archiv_report_proc:TRozbal_GRP_archiv_report_proc;

implementation
uses dos,objects,grpfile;

Function Upstring(s:string):string;
var a:byte;
begin
for a:=1 to Length(s) do s[a]:=UpCase(s[a]);
UpString:=s;
end;


Function KillSpaces(s:string):string;
var a:byte;
    t:string;
begin
t:='';
for a:=1 to Length(s) do
    if not (s[a] in [#9,#32]) then t:=t+s[a];
KillSpaces:=t;
end;

Function KillNulls(s:string):string;
var a:byte;
    t:string;
begin
t:='';
for a:=1 to Length(s) do
    if not (s[a] in [#0]) then t:=t+s[a];
KillNulls:=t;
end;


Function MyVal(s:string):longint;
var i,j:longint;
      k:integer;
begin
{$IFDEF FPC}
Val(s,i,j);
{$ELSE}
Val(s,i,k);
{$ENDIF}
MyVal:=i;
end;


Function Vytahni_mapovy_soubor_GRP(s:string;var m:TGRPmapa):boolean;
var grp,grp2:TGRPstream;
    p:string;
    t,u:string;
    b:boolean;
    i,j,o:longint;
    tr:byte;
    tempmapa:TGRPMapa;
    tmn:longint;

begin
m.Init(0);

grp.Init(s+'#'+GRP_DESC_FILE,grpOpenRead);
if (grp.status<>stOK) then
   begin
   grp.Done;
   Vytahni_mapovy_soubor_GRP:=false;
   Exit;
   end;

tempmapa.init(MAX_GRP_CISLOVANYCH_SOUBORU);
tmn:=0;

while grp.status=stOK do
   begin
   p:=grp.ReadString;
   t:=KillSpaces(UpString(p));
   tr:=Pos('=',t);
   if (Pos('PARAM',t)=1) and (t[6] in ['0'..'9']) and (tr>6) then
      begin
      u:=Copy(t,6,1);              {vyseparuje cislo}
      i:=MyVal(u);
      if (i>-1) and (i<10) then
         begin
         u:=Copy(t,tr+1,255);
         m.info[i]:=MyVal(u);        {ulozime hodnotu za rovna se}
         end;
      end
      else
   if Pos('*',t)=1 then            {pred jmeno souboru dam hvezdicku}
      {format zaznamu je:
       *FILENAME.TXT

       nebo
       *FILENAME.TXT=ciselne_oznaceni
      }
      begin
      delete(t,1,1);
      i:=Pos('=',t);
      if i>0 then
         begin
         u:=Copy(t,i+1,255);    {oddelim cast za rovna se}
         o:=MyVal(u);
         delete(t,i,255);       {a pred rovna se}
         end
         else o:=0;

      grp2.Init(s+'#'+t,grpOpenRead);  {je realne tento soubor v archivu?}
      b:=grp2.status=stOK;
      grp2.Done;
      if b=true then
         begin
         inc(tmn);
         tempmapa.zaznam^[tmn].nazev:=t;
         tempmapa.zaznam^[tmn].oznaceni:=o;
         tempmapa.zaznam^[tmn].odkaz:=nil;
         end;
      end;

   end;

m.Resize(tmn);
for i:=1 to tmn do
    m.zaznam^[i]:=tempmapa.zaznam^[i];

{
for i:=1 to m.num do
    writeln(m.zaznam^[i].nazev,' : ',m.zaznam^[i].oznaceni);

for i:=0 to 9 do writeln(m.info[i]);
readln;
}

tempmapa.Done;
grp.Done;
m.Setrid;
Vytahni_mapovy_soubor_GRP:=true;
end;


{
Function ExistDir(s:string):boolean;
var s:string;
    r:searchrec;
begin
FindFirst(s,directory,r);
if DosError=0 then
   begin
   if ExistFile(s+'\nul') then ExistDir:=true else ExistDir:=false;
   end else ExistDir:=false;
FindClose(r);
end;
}


Function Vybal_soubor_z_GRP_archivu(grp:PGRPstream;s:string;v:longint):byte;
const MAX_TRFBLOK=20000;
var t:TBufStream;
    buf:array[0..MAX_TRFBLOK-1] of byte;
    i,j,bs,zbyva:longint;

begin
t.Init(s,stCreate,MAX_TRFBLOK);
if t.ErrorInfo<>0 then
   begin
   t.Done;
   Vybal_soubor_z_GRP_archivu:=1;
   Exit;
   end;

zbyva:=v;

repeat
if zbyva<=MAX_TRFBLOK then bs:=zbyva else bs:=MAX_TRFBLOK;
i:=grp^.ReadStream(buf,bs);
t.Write(buf,i);
dec(zbyva,i);
until zbyva<=0;


t.Done;
Vybal_soubor_z_GRP_archivu:=0;
end;


Function Rozbal_GRP_archiv(s,kam:string):byte;
var grp:TGRPstream;
    nsb:TBufStream;
    e,a,num,vs,spoz,poz:longint;
    js:string;

begin
grp.Init(s,grpOpenRead);
if (grp.status<>stOK) then
   begin
   grp.Done;
   Rozbal_GRP_archiv:=1;
   Exit;
   end;
if grp.jsem_ja_grp=false then begin grp.Done;Rozbal_GRP_archiv:=2;Exit;end;
if grp.Kolik_ja_mam_v_GRP<1 then begin grp.Done;Rozbal_GRP_archiv:=3;Exit;end;

{if not ExistDir(kam) then begin grp.Done;Exit(4);end;}

grp.Seek(12);         {Za MAGIC}
grp.Read(num,4);      {pocet souboru v archivu}
poz:=0;
for a:=1 to num do
    begin
    js[0]:=#12;
    grp.Read(js[1],12);  {jmeno souboru}
    js:=KillNulls(js);
    grp.Read(vs,4);      {velikost souboru}
    spoz:=12+4+num*16+poz;
    grp.Seek(spoz);
    e:=Vybal_soubor_z_GRP_archivu(@grp,kam+js,vs);
    {$IFDEF FPC}
    if e=0 then
       if Rozbal_GRP_archiv_report_proc<>nil
          then Rozbal_GRP_archiv_report_proc(js);

    {$ELSE}
    if e=0 then
       if @Rozbal_GRP_archiv_report_proc<>nil
          then Rozbal_GRP_archiv_report_proc(js);
    {$ENDIF}

    grp.Seek(12+4+a*16);
    inc(poz,vs);
    end;
Rozbal_GRP_archiv:=0;
grp.Done;
end;


Procedure TGRPmapa.Init(n:byte);
var a:byte;
begin
for a:=0 to 9 do info[a]:=0;
setrideno_podle_oznaceni:=false;
zaznam:=nil;
Resize(n);
end;


Procedure TGRPmapa.Resize(n:byte);
var a:byte;
begin
if zaznam<>nil then FreeMem(zaznam,__vel);

num:=n;
if num>0 then
   begin
   __vel:=num*SizeOf(TGRP_zaznam_element);
   GetMem(zaznam,__vel);
   for a:=1 to num do
       begin
       zaznam^[a].odkaz:=nil;
       zaznam^[a].nazev:='';
       zaznam^[a].oznaceni:=0;
       end;
   end
   else begin
   __vel:=0;
   zaznam:=nil;
   end;
end;


Function TGRPmapa.Nejblizsi_k_oznaceni(hodnota:longint):longint;
var a,b,i,d:longint;
begin
{writeln('TGRPmapa.Nejblizsi_k_oznaceni',' > hodnota: ',hodnota);}

if num=0 then begin Nejblizsi_k_oznaceni:=0;Exit;end;
if num=1 then begin Nejblizsi_k_oznaceni:=1;Exit;end;
if hodnota<=zaznam^[1].oznaceni then begin Nejblizsi_k_oznaceni:=1;Exit;end;
if hodnota>=zaznam^[num].oznaceni then begin Nejblizsi_k_oznaceni:=num;Exit;end;

if setrideno_podle_oznaceni=true then
   begin
   {writeln('setrideno');}
   a:=1;
   while hodnota>zaznam^[a].oznaceni do
         inc(a);

   if hodnota-zaznam^[a-1].oznaceni<zaznam^[a].oznaceni-hodnota
   then Nejblizsi_k_oznaceni:=a-1
   else Nejblizsi_k_oznaceni:=a;
   end
   else begin
   i:=maxlongint div 2;
   {writeln('nesetrideno');}
   b:=0;
   for a:=1 to num do
       begin
       if zaznam^[a].oznaceni=hodnota then begin Nejblizsi_k_oznaceni:=a;Exit;end;
       d:=abs(hodnota-zaznam^[a].oznaceni);
       if d<i then b:=a;
       end;
   Nejblizsi_k_oznaceni:=b;
   end;
end;


Function TGRPmapa.Dej_Retezec_s_velikostmi:string;
var a:byte;
    s,ps:string;
begin
if num=0 then begin Dej_Retezec_s_velikostmi:='';Exit;end;
s:='';
for a:=1 to num do
    begin
    Str(zaznam^[a].oznaceni,ps);
    s:=s+ps+',';
    end;
dec(byte(s[0]));
Dej_Retezec_s_velikostmi:=s;
end;


Procedure TGRPmapa.Setrid;
var hotovo:boolean;
    elem:TGRP_zaznam_element;
    a:longint;
    oz:longint;
    na:string;
    od:pointer;


begin
repeat
  hotovo:=true;
  for a:=1 to num-1 do
      if zaznam^[a].oznaceni>zaznam^[a+1].oznaceni then
         begin

         elem:=zaznam^[a];

         zaznam^[a]:=zaznam^[a+1];
         zaznam^[a+1]:=elem;

         {
         oz:=zaznam^[a].oznaceni;
         zaznam^[a].oznaceni:=zaznam^[a+1].oznaceni;
         zaznam^[a+1].oznaceni:=oz;

         na:=zaznam^[a].nazev;
         zaznam^[a].nazev:=zaznam^[a+1].nazev;
         zaznam^[a+1].nazev:=na;

         od:=zaznam^[a].;
         zaznam^[a].odkaz:=zaznam^[a+1].odkaz;
         zaznam^[a+1].odkaz:=na;
         }
         hotovo:=false;
         end;
until hotovo=true;
setrideno_podle_oznaceni:=true;
end;


Function TGRPmapa.Dej_nazev(n:byte):string;
begin
if (n=0) or (n>num) then Dej_nazev:='' else Dej_nazev:=zaznam^[n].nazev;
end;


Function TGRPmapa.Dej_oznaceni(n:byte):byte;
begin
if (n=0) or (n>num) then Dej_oznaceni:=0 else Dej_oznaceni:=zaznam^[n].oznaceni;
end;


Function TGRPmapa.Index_podle_oznaceni(i:longint):byte;
var a:longint;
begin
for a:=1 to num do
    if zaznam^[a].oznaceni=i then begin Index_podle_oznaceni:=a;Exit;end;
Index_podle_oznaceni:=0;
end;


Procedure TGRPmapa.Done;
begin
if __vel>0 then begin num:=0;FreeMem(zaznam,__vel);zaznam:=nil;__vel:=0;end;
end;

begin
Rozbal_GRP_archiv_report_proc:=nil;
end.
