unit Vaznik;
{$IFDEF VER2}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF VER3}{$DEFINE NEWFPC}{$ENDIF}
{$IFDEF NEWFPC}{$CALLING OLDFPCCALL}{$ENDIF}

interface
uses Objects;       {jsen kvuli operacim se soubory}
type



ActionType = procedure(var p:pointer);
SizeDetectproc = function(p:pointer):longint;


PUzel = ^TUzel;
TUzel = object
    dalsi:PUzel;
    predchozi:PUzel;
    vazba:pointer;
    Procedure Done;
    {S deklaraci jako destructor by byla potiz v tom, ze v takovem pripade
     by vsechny instance musely byt tvorene pres konstruktor. Jinak by to
     pri ruseni generovalo chybu VMT}
    end;

type
Pvaznik = ^Tvaznik;
Tvaznik = object
{Univerzalni obousmerny spojovy seznam s hlavou.Umi se chovat i jako cyklicky}
    first,last:PUzel;
    bod_kruhu,poloha:PUzel;
    pocet:longint;
    akce:ActionType;
    porovnejproc:function(p,q:pointer):boolean; {porovnejproc:=p<q}
    Constructor Init;
    Function InitNext(q:pointer):PUzel;
    Function InsertNew(u:PUzel;q:pointer):PUzel;
    Function InsertSort(q:pointer):PUzel;
    Procedure AbsorbujVaznik(u:PUzel;v:PVaznik);
    Procedure AbsorbujVaznikUnikatnimi(u:PUzel;v:PVaznik);
    Function Uzel(a:longint):PUzel;
    Function PocetUzlu:longint;
    Procedure PozpatkuUzly;
    Procedure For_Each(action:ActionType);
    Function Je_ve_vazniku(p:puzel):boolean;
    Function Kolikaty_ve_Vazniku(p:puzel):longint; {pokud neni, vraci 0}
    Function Kolikata_vazba_ve_vazniku(p:pointer):longint;
    Function Vyhledej_ve_vazniku(p:pointer):puzel;
    Procedure Reset;
    Function Konec:boolean;
    Function Nacti:pointer;
    Procedure ResetKruh(p:PUzel);
    Function NactiKruh:pointer;
    Function KonecKruh:boolean;
    Function Nacteny:PUzel;
    Function Duplicate:Pvaznik;
    Procedure Setrid;
    Procedure ZrusUzel(u:PUzel);
    Procedure ZrusPodvaznik(v:PVaznik);
    Procedure ZrusVsechnyUzly;
    Destructor Done;
    end;


THeapArray4 = array[1..maxlongint div 4] of pointer;
TlongintArray = array[0..(maxlongint div 4)-1] of longint;
RndFunkce = Function(max_plus_1:longint):longint;

PZasobnik = ^Tzasobnik;
TZasobnik = object
{Zasobnik imlementovany pomoci pole. Umi se cyklit, takze nikdy nepretece.}
  pole:^THeapArray4;
  baze,num,max:longint;
  kruh:boolean;
  err:byte;
  Constructor Init(imax:longint;ikruh:boolean);
  Procedure Dej(p:pointer);    {Umisti do zasobniku atribut}
  Function Vem:pointer;        {Sejme ze zasobniku atribut}
  Function Cti:pointer;        {Ukaze na vrchol zasobniku, ale nesejme z nej}
  Function CtiN(a:longint):pointer; {Ukaze ne na posledni, ale na N-ty prvek}
  Destructor Done;
end;


const
 RINGBUF_PRAZDNY = 255;
 RINGBUF_OK      = 0;

type
PRingBuf = ^TRingBuf;
TRingBuf = object
{Kruhovy buffer}
  velikost:longint;
  obsazeno:longint;

  pole:pchar;
  chyba:byte;
  aktin:longint;
  pos_vlozeno:longint;
  Constructor Init(bajtu:longint);
  Procedure Reset;
  Function Vloz(var data;bajtu:longint):longint;
  Function Cti(bajtu:longint;var cil):longint;
  Function CtiPosl(var cil;maxbajtu:longint):longint;
  Function CtiPosl(var cil):longint;
  Function CtiBuffer(var cil):longint;

  private
  Function CtiAbs(index,bajtu:longint;var cil):longint;
  Function ErrProlog(co_ma_byt_kladne:longint):boolean;
  Procedure Navys_Aktin(bajtu:longint);
  Destructor Done;
end;


PRandomEmiter = ^TRandomEmiter;
TRandomEmiter = object
{Generuje nahodne poradi N prvku tak, aby zadny prvek nebyl tazen vicekrat}
   pole:^TLongintArray;
   velikost,zbyva:longint;
   rnd:RndFunkce;
   Constructor Init(n:longint;rndfunc:rndfunkce);
   Function Dej:longint;
   Destructor Done;
   end;
{Bohuzel nejde udelat primo: Emiter.Init(100,@crt.Random)
 Musis oklikou, t.j. nadefinovat si:
    Function MyRandom(n:longint):longint;
    begin MyRandom:=crt.Random(n);end;
 a pak:
 Emiter.Init(100,@MyRandom).  (pozn: Pokus se opravdu pouzije Random z unitu
                               Crt, melo by byt na zacatku programu volano
                               "randomize")}



PStrom = ^TStrom;
TStrom = object
{Struktura pro uchovavani stromovych struktur. Vetvi muze byt mnoho, takze
 je o hodne slozitejsi nez klasicky binarni strom.}
    predchozi,dalsi,rodic,potomek:Pstrom;
    vazba:pointer;
    skok:PStrom;         {korenova polozka ukazuje na posledni a vsechny ostatni na prvni}
    Constructor Init(_rod,_pre,_dal:PStrom);
    Function InitNext(q:pointer):PStrom;
    Procedure Insert(p:PStrom);
    Function PocetPrvku:longint;
    Function InitOffspring(q:pointer):PStrom;
    Function SearchFirst:PStrom;
    Function SearchLast:PStrom;
    Function SearchRecord(id:integer):PStrom;
    Function Search_Offsprings(p:pointer):PStrom;
    Function Search_Parents(p:pointer):PStrom;
    Function Root:PStrom;
    Function Deepness(p:Pstrom):longint;
    Function Save(s:string):byte;
    Function Load(s:string):byte;       {st_OK nebo st_BADFORMAT}
    Function Num_Childerns:longint;
    Function Num_Offsprings:longint;
    Function Vem:Pstrom;                {vem:=potomek^.dalsi}
    Procedure InzertVaznik(p:PVaznik);  {Pripoji jenom vazby}
    Procedure PridejPodstrom(p:Pstrom); {Pripoji primo jednotlive prvky}
    Function Kolikaty_v_linii(p:PStrom):longint;
    Procedure PozpatkuPrvky;
    Function Linearize:PVaznik;
    Procedure For_Each(action:ActionType);
    Function DejDalsi:PStrom;
    Function DejPredchozi:Pstrom;
    Function Vaznik_z_predku:PVaznik;
    Function Vaznik_z_generace_nasledniku:PVaznik;
    {Na vaznik budou navazany nikoliv PStrom, ale PStrom^.vazba}
    Function Duplicate:Pstrom;
    Destructor Done;

    { Tyto procedury se budou v potomcich predefinovavat podle typu dat }
    { V teto zakladni forme ovladaji typ PString  }
    end;


pstring=^string;

const
    st_OK                     = 0;
    st_NOT_FOUND              = 1;
    st_NOT_EMPTY              = 2;
    st_NO_DATA                = 3;
    st_DATA_SIZE_NOT_ASSIGNED = 4;
    st_BADFORMAT              = 5;
    st_FILENOTEXIST           = 6;

    st_VERZESOUBORU = 1;
    st_BUFFERSIZE = $4000;


Function StromDef(p:PStrom):PStrom;
Function SvazejS(p:PStrom):PStrom;
Function Vetev(objekt:pointer;spodek,dal:PStrom):PStrom;
Function UzelS(objekt:pointer;dal:PStrom):PStrom;
Function Uzel(objekt:pointer;dal:PUzel):PUzel;
Function Svazej(p:PUzel):PVaznik; {Vaze uzly}
{Urceno k takovymto definicim:
<uses Strings>
p:=Svazej(
   Uzel(StrNew('prvni polozka'),
   Uzel(StrNew('druha polozka'),
   Uzel(StrNew('treti polozka'),
   Uzel(StrNew('ctvrta polozka'),
   Uzel(StrNew('pata polozka'),nil))))));
}
Procedure Vaznik_Done_All(var p:PVaznik);
Procedure Vaznik_Done_All(var p:PVaznik;action:ActionType);
Procedure Strom_Done_All(var p:PStrom;action:ActionType);

Function NovyVaznik:Pvaznik;
Function PoleNaVaznik(var p:array of string):PVaznik;
Function NovyStrom:PStrom;

var (*porovnejproc:function(p,q:pointer):boolean;
    {porovnejproc:=p<q}*)

    procMySizeOf:function(p:pointer):longint;
    procSaveMyData:procedure(f:PBufStream;p:pointer;j:longint);
    procSaveHeaderOfMyData:procedure(f:PBufStream);
    procLoadHeaderOfMyData:function(f:PBufStream):boolean;
    procLoadMyData:function(f:PBufStream):pointer;
    procCompMyData:function(p,q:pointer):boolean;

implementation
const tkadlo:PVaznik = nil;
      skadlo:PStrom = nil;
      seznam_vetveni:PVaznik = nil; {funguje jako zasobnik (LIFO)}


Procedure TUzel.Done;
begin
if predchozi<>nil then predchozi^.dalsi:=dalsi;
if dalsi<>nil then dalsi^.predchozi:=predchozi;
end;


Function DefaultSortComp(p,q:pointer):boolean;
begin
{nevime, s jakymi budeme pracovat daty, tak to defaultne vypnu}
{pro konkretni ulohu si napis vlastni porovnavac}
DefaultSortComp:=false;
end;

Constructor TVaznik.Init;
begin
first:=nil;
last:=nil;
poloha:=nil;
bod_kruhu:=nil;
akce:=nil;
pocet:=0;
porovnejproc:=@DefaultSortComp;
end;

Procedure TVaznik.Reset;
begin
poloha:=first;
end;

Function TVaznik.Konec:boolean;
begin
Konec:=poloha=nil;
end;

Function TVaznik.Nacti:pointer;
begin
if poloha=nil then Exit(nil)
   else begin
   Nacti:=poloha^.vazba;
   poloha:=poloha^.dalsi;
   end;
end;

Function TVaznik.Nacteny:PUzel;
begin
if poloha=nil then Nacteny:=last else
   if poloha=first then Nacteny:=first else Nacteny:=poloha^.predchozi;
end;

Procedure TVaznik.ResetKruh(p:PUzel);
begin
bod_kruhu:=p;
poloha:=p;
end;

Function TVaznik.NactiKruh:pointer;
begin
if bod_kruhu=nil then Exit(nil)
   else begin
   NactiKruh:=poloha^.vazba;
   poloha:=poloha^.dalsi;
   if poloha=nil then poloha:=first;
   end;
end;

Function TVaznik.KonecKruh:boolean;
begin
KonecKruh:=poloha=bod_kruhu;
end;


Function TVaznik.InsertNew(u:PUzel;q:pointer):PUzel;
{Vytvori novy uzel a umisti ho hned za specifikovany uzel}
var p:PUzel;
begin
New(p);
if u=nil then
   begin
   p^.predchozi:=nil;
   p^.dalsi:=first;
   first:=p;
   if last=nil then last:=p;
   if p^.dalsi<>nil then
      p^.dalsi^.predchozi:=p;
   end

   else begin
   p^.dalsi:=u^.dalsi;
   if u^.dalsi=nil then last:=p else u^.dalsi^.predchozi:=p;
   u^.dalsi:=p;
   p^.predchozi:=u;
   end;
p^.vazba:=q;
inc(pocet);
InsertNew:=p;
end;

Function TVaznik.InsertSort(q:pointer):PUzel;
begin
if poloha=nil then
   begin
   poloha:=InsertNew(nil,q);
   Exit(poloha);
   end;

if porovnejproc(q,poloha^.vazba) then {Q<poloha^.vazba?}
   repeat
      poloha:=poloha^.predchozi;
      if poloha=nil then begin poloha:=InsertNew(nil,q);Exit(poloha);end;
   until porovnejproc(q,poloha^.vazba)=false
   else begin                         {Q>=poloha^.vazba?}
   repeat
      poloha:=poloha^.dalsi;
      if poloha=nil then begin poloha:=InsertNew(last,q);Exit(poloha);end;
   until porovnejproc(q,poloha^.vazba)=true;
   poloha:=poloha^.predchozi;
   end;
poloha:=InsertNew(poloha,q);
InsertSort:=poloha;
end;

Function TVaznik.InitNext(q:pointer):PUzel;
{Vytvori novy uzel a prida ho na konec vazniku}
begin
InitNext:=InsertNew(last,q);
end;

Procedure TVaznik.AbsorbujVaznik(u:PUzel;v:PVaznik);
begin
if v^.pocet=0 then Exit;
inc(pocet,v^.pocet);
if first=nil then first:=v^.first else v^.first^.predchozi:=u;
if u=last then last:=v^.last else
   begin
   if u=nil then
      begin
      first^.dalsi^.predchozi:=v^.last;
      v^.last^.dalsi:=first;
      first:=v^.first;
      end
      else begin
      u^.dalsi^.predchozi:=v^.last;
      v^.last^.dalsi:=u^.dalsi;
      end;
   end;
if u<>nil then u^.dalsi:=v^.first;
v^.pocet:=0;
v^.first:=nil;
v^.last:=nil;
end;


Procedure TVaznik.AbsorbujVaznikUnikatnimi(u:PUzel;v:PVaznik);
var e,f:PUzel;
    n:pointer;
begin
if v^.pocet=0 then Exit;
if first=nil then AbsorbujVaznik(u,v) else
   begin
   e:=v^.first;
   while e<>nil do
      begin
      n:=e^.vazba;
      f:=e^.dalsi;
      if Kolikata_vazba_ve_vazniku(n)=0 then
         begin
         InsertNew(u,n);
         u:=u^.dalsi;
         v^.ZrusUzel(e);
         end;
      e:=f;
      end;
   end;
end;


Function TVaznik.Uzel(a:longint):PUzel;
var p:PUzel;
    b:longint;
begin
if a<1 then Exit(nil);
if a>pocet then a:=pocet;
p:=first;
for b:=2 to a do p:=p^.dalsi;
Uzel:=p;
end;

Function TVaznik.Kolikaty_ve_Vazniku(p:PUzel):longint;
var l:longint;
    q:PUzel;
begin
l:=1;
q:=first;
while q<>nil do
   begin
   if q=p then Exit(l);
   q:=q^.dalsi;
   inc(l);
   end;
Kolikaty_ve_Vazniku:=0;
end;

Function TVaznik.Kolikata_vazba_ve_vazniku(p:pointer):longint;
var l:longint;
    q:PUzel;
begin
l:=1;
q:=first;
while q<>nil do
   begin
   if q^.vazba=p then Exit(l);
   q:=q^.dalsi;
   inc(l);
   end;
Kolikata_vazba_ve_vazniku:=0;
end;

Function TVaznik.Vyhledej_ve_vazniku(p:pointer):puzel;
var q:PUzel;
begin
q:=first;
while q<>nil do
   begin
   if q^.vazba=p then Exit(q);
   q:=q^.dalsi;
   end;
Vyhledej_ve_vazniku:=nil;
end;

Function TVaznik.Je_ve_vazniku(p:PUzel):boolean;
begin
Je_ve_vazniku:=Kolikaty_ve_Vazniku(p)<>0;
end;

Function TVaznik.PocetUzlu:longint;
begin
PocetUzlu:=pocet;
end;

Procedure TVaznik.PozpatkuUzly;
var p,q:PUzel;
    v2:pointer;
    a:longint;
begin
if pocet<2 then Exit; {pro 0 nebo 1 prvku prohazovat nebudu}
p:=first;
q:=last;
for a:=1 to pocet div 2 do
    begin
    v2:=p^.vazba;
    p^.vazba:=q^.vazba;
    q^.vazba:=v2;
    p:=p^.dalsi;
    q:=q^.predchozi;
    end;
end;

Procedure TVaznik.For_each(action:ActionType);
var p:pointer;
begin
if action=nil then Exit;
Reset;
while not konec do
   begin
   p:=Nacti;
   action(p);
   end;
end;

Function TVaznik.Duplicate:Pvaznik;
var p:PVaznik;
begin
p:=New(PVaznik,Init);
Reset;while not konec do p^.InitNext(Nacti);
Duplicate:=p;
end;

Procedure TVaznik.Setrid;
   function MergeSort(TheList:PUzel;N:longint):PUzel;
   var
      TempNode1 :PUzel;
      TempNode2 :PUzel;
      Count     :longint;
      Size1     :longint;
      Size2     :longint;
      UsingList1:boolean;

   begin
   if N <= 2 then                 {dva prvky nebo mene?}
      begin
      if N = 1 then               {v seznamu je jenom jeden prvek?...}
         MergeSort := TheList     {...tak to je pro tentokrat dotrideno}
         else
         begin                       {dva prvky?}
         if porovnejproc(TheList^.vazba,TheList^.dalsi^.vazba) then MergeSort := TheList
            else begin               {eventualne je prohod}
            TempNode1 := TheList;
            TempNode2 := TheList^.dalsi;
            TempNode1^.predchozi := TempNode2;
            TempNode2^.dalsi := TempNode1;
            TempNode1^.dalsi := nil;
            TempNode2^.predchozi := nil;
            MergeSort := TempNode2;
            end;
         end;
      end
      else
      begin
      {vice nez dva prvky?}
      {rozdelim seznam na dve poloviny}
      {TempNode1 pokryje prvni polovinu a}
      {TempNode2 druhou}

      TempNode2 := TheList;
      Size1 := N div 2;
      Size2 := n - Size1;
      for Count := 1 to Size1 - 1 do TempNode2 := TempNode2^.dalsi;
      TempNode1 := TempNode2;
      TempNode2 := TempNode2^.dalsi;
      TempNode1^.dalsi:=nil;
      TempNode2^.predchozi:=nil;
      TempNode1:=TheList;

      {tyto dve poloviny setridi}

      TempNode1 := MergeSort(TempNode1,Size1);
      TempNode2 := MergeSort(TempNode2,Size2);

      {obe poloviny zase spoji}
      {musi se ale napred rozhodnout, ktera bude prvni}

      if porovnejproc(TempNode1^.vazba,TempNode2^.vazba) then
         begin
         MergeSort := TempNode1;
         UsingList1 := true;
         end
         else begin
         MergeSort := TempNode2;
         UsingList1 := false;
         end;

      while (TempNode1 <> nil) and (TempNode2 <> nil) do
         begin
         {a ted je spojim}
         if UsingList1 then
            begin
            while (TempNode1^.dalsi <> nil) and
                  porovnejproc(TempNode1^.dalsi^.vazba,TempNode2^.vazba) do
               TempNode1 := TempNode1^.dalsi;
            TempNode2^.predchozi := TempNode1;
            TempNode1 := TempNode1^.dalsi;
            TempNode2^.predchozi^.dalsi := TempNode2;
            if TempNode1 = nil then Exit;
            end
            else
            begin
            while (TempNode2^.dalsi <> nil) and
                  porovnejproc(TempNode2^.dalsi^.vazba,TempNode1^.vazba) do
               TempNode2 := TempNode2^.dalsi;
            TempNode1^.predchozi := TempNode2;
            TempNode2 := TempNode2^.dalsi;
            TempNode1^.predchozi^.dalsi := TempNode1;
            if TempNode2 = nil then Exit;
            end;
            UsingList1 := not UsingList1;
         end;
      end;
   end;

var i:longint;
begin
i:=Pocet;
if i>1 then
   begin
   first:=MergeSort(first,i);
   last:=Uzel(pocet);
   {first^.predchozi:=nil;}
   {last^.dalsi:=nil}
   end;
end;


Procedure TVaznik.ZrusUzel(u:PUzel);
begin
if u=last then last:=u^.predchozi;
if u=first then first:=u^.dalsi;
if u^.predchozi<>nil then u^.predchozi^.dalsi:=u^.dalsi;
if u^.dalsi<>nil then u^.dalsi^.predchozi:=u^.predchozi;
Dispose(u);
dec(pocet);
end;


Procedure TVaznik.ZrusPodvaznik(v:PVaznik);
var p:pointer;
    u:PUzel;
begin
v^.Reset;
while not v^.Konec do
   begin
   p:=v^.Nacti;
   u:=Vyhledej_ve_vazniku(p);
   if u<>nil then ZrusUzel(u);
   end;
end;

Procedure TVaznik.ZrusVsechnyUzly;
var u:PUzel;
begin
u:=first;
if akce=nil then while pocet<>0 do ZrusUzel(first)
   else while pocet<>0 do
           begin
           akce(first^.vazba);
           ZrusUzel(first);
           end;
end;

Destructor TVaznik.Done;
var u:PUzel;
begin
u:=first;
ZrusVsechnyUzly;
end;


Function NovyVaznik:PVaznik;
begin
NovyVaznik:=New(PVaznik,Init);
end;

Function NovyStrom:PStrom;
begin
NovyStrom:=New(PStrom,init(nil,nil,nil));
end;

Function NaPstring(s:string):pointer;
var p:pchar;
begin
GetMem(p,Length(s)+1);
Move(s,p^,Length(s)+1);
NaPstring:=p;
end;

Function PoleNaVaznik(var p:array of string):PVaznik;
var a:longint;
    n:PVaznik;
begin
n:=NovyVaznik;
for a:=Low(p) to High(p) do n^.InitNext(NaPstring(p[a]));
PoleNaVaznik:=n;
end;

Procedure Vaznik_Done_all(var p:PVaznik;action:ActionType);
var i:longint;
    n:PUzel;
begin
if p=nil then Exit;
p^.akce:=action;

i:=p^.pocet;
n:=p^.first;

Dispose(p,Done);
p:=nil;
end;

Procedure Vaznik_Done_all(var p:PVaznik);
begin
if p=nil then Exit;
p^.akce:=nil;
Dispose(p,Done);
p:=nil;
end;



Constructor TZasobnik.Init(imax:longint;ikruh:boolean);
begin
num:=0;
baze:=1;
max:=imax;
kruh:=ikruh;
GetMem(pole,max*4);
end;


Procedure TZasobnik.Dej(p:pointer);
var i:longint;
begin
err:=0;
if num<max then
   begin
   inc(num);
   i:=baze+num-1;
   if i>max then i:=max-i;
   pole^[i]:=p;
   end
   else if kruh=false then err:=1
      else begin
      inc(baze);
      i:=baze-1;
      if baze>max then baze:=1;
      pole^[i]:=p;
      end;
end;


Function TZasobnik.Cti:pointer;
var i:longint;
begin
if num=0 then begin err:=1;Cti:=nil;Exit;end;
err:=0;

i:=baze-(max-num+1);

if i<1 then i:=max+i; {I je zaporne, takze nesmi nastat ze "-" a "-" je plus}
Cti:=pole^[i];
end;


Function TZasobnik.CtiN(a:longint):pointer;
begin
CtiN:=pole^[a];
end;


Function TZasobnik.Vem:pointer;
begin
Vem:=Cti;
if err=0 then dec(num);
end;


Destructor TZasobnik.Done;
begin
FreeMem(pole,max*4);
end;


Constructor TRingBuf.Init(bajtu:longint);
begin
obsazeno:=0;
velikost:=bajtu;
aktin:=0;
chyba:=0;
pos_vlozeno:=0;
pole:=nil;
if velikost<1 then chyba:=RINGBUF_PRAZDNY else GetMem(pole,velikost);
end;


Function TRingBuf.ErrProlog(co_ma_byt_kladne:longint):boolean;
var a:boolean;
begin
chyba:=RINGBUF_OK;
a:=false;
if co_ma_byt_kladne<1 then a:=true;
if velikost<1 then a:=true;
if A=true then chyba:=RINGBUF_PRAZDNY;
ErrProlog:=a;
end;


Procedure TRingBuf.Reset;
begin
obsazeno:=0;
aktin:=0;
end;


Procedure TRingBuf.Navys_Aktin(bajtu:longint);
begin
inc(aktin,bajtu);
aktin:=aktin mod velikost;
end;


Function TRingBuf.Vloz(var data;bajtu:longint):longint;
{Pokud je BAJTU vetsi nez vel. bufferu, tak se zkopiruje jen poslednich BAJTU
 z buferu.
 Ve vysledku je pocet realne zapsanych bajtu do bufferu.}
var p:pointer;
    u,rsl:longint;
begin
if ErrProlog(bajtu) then Exit(0);
p:=@data;
inc(p,bajtu);
if bajtu>velikost then bajtu:=velikost;
rsl:=bajtu;
dec(p,bajtu);
{Osetreni preteceni - zkopiruji jen tolik bajtu od kone, kolik se vejde}

pos_vlozeno:=bajtu;
if aktin+bajtu>velikost
   then begin
   u:=velikost-aktin;
   Move(p^,pole[aktin],u);
   inc(p,u);
   inc(obsazeno,u);
   bajtu:=bajtu-u;
   aktin:=0;
   end;

if bajtu>0 then
   begin
   Move(p^,pole[aktin],bajtu);
   inc(obsazeno,bajtu);
   inc(aktin,bajtu);
   end;

if obsazeno>velikost then obsazeno:=velikost;
if aktin>velikost-1 then aktin:=velikost-aktin;
Vloz:=rsl;
end;


Function TRingBuf.CtiAbs(index,bajtu:longint;var cil):longint;
{Od absolutni pozice INDEX precte pozadovany pocet bajtu}
{Vraci pocet realne prectenych bajtu}
var p,q:pchar;
    u,rsl:longint;
begin
if ErrProlog(bajtu) then Exit(0);
if index<0 then
   begin
   inc(index,bajtu);
   if index<1 then Exit(0);
   bajtu:=index;
   index:=0;
   end;
rsl:=bajtu;

if index>velikost-1 then index:=0;
if bajtu>velikost then bajtu:=velikost;
p:=@cil;

if index+bajtu>velikost
   then begin
   u:=velikost-index;
   Move(pole[index],p^,u);
   inc(p,u);
   Move(pole[0],p^,bajtu-u);
   end

   else Move(pole[index],p^,bajtu);

CtiAbs:=rsl;
end;


Function TRingBuf.Cti(bajtu:longint;var cil):longint;
{Nacte pozadovany pocet naposledy zapsanych bajtu. Ve vysledku funkce vraci
 pocet realne prectenych bajtu}
var a:longint;
    p:pchar;

begin
if ErrProlog(bajtu) then Exit(0);
if bajtu>obsazeno then bajtu:=obsazeno;
if obsazeno<velikost then Move(pole[aktin-bajtu],cil,obsazeno)
   else begin
   p:=@cil;
   if bajtu>aktin then
      begin
      a:=bajtu-aktin;
      Move(pole[velikost-a],p^,a);
      inc(p,a);
      Move(pole[0],p^,aktin);
      end
      else begin
      a:=aktin-bajtu;
      Move(pole[aktin-a],p^,a);
      end;
   end;
Cti:=bajtu;
end;


Function TRingBuf.CtiPosl(var cil;maxbajtu:longint):longint;
{Od pozice INDEX precte pozadovany pocet poslednich bajtu}
var a:longint;
begin
if pos_vlozeno>maxbajtu then a:=maxbajtu else a:=pos_vlozeno;
CtiPosl:=Cti(a,cil);
end;


Function TRingBuf.CtiPosl(var cil):longint;
begin
CtiPosl:=CtiPosl(cil,$7FFFFFFF {maxlongint});
end;


Function TRingBuf.CtiBuffer(var cil):longint;
{Precte cely buffer, ktery konci bodem Aktin, t.j. posledne pridanym bajtem}
var a:longint;
    p:pchar;
begin
if obsazeno<velikost then Move(pole[0],cil,obsazeno)
   else begin
   p:=@cil;
   a:=velikost-aktin;
   Move(pole[aktin],p^,a);
   inc(p,a);

   Move(pole[0],p^,{velikost-a}aktin);
   end;
CtiBuffer:=obsazeno;
end;


Destructor TRingBuf.Done;
begin
if velikost>0 then FreeMem(pole,velikost);
obsazeno:=0;
velikost:=0;
pole:=nil;
end;



Constructor TRandomEmiter.Init(n:longint;rndfunc:rndfunkce);
var a:longint;
begin
velikost:=n;
zbyva:=n;
rnd:=rndfunc;
GetMem(pole,velikost*4);
for a:=0 to zbyva-1 do pole^[a]:=a;
end;


Function TRandomEmiter.Dej:longint;
var i,j,z:longint;
begin
if zbyva=0 then begin Dej:=0;Exit;end;
j:=velikost-zbyva;
i:=RND(zbyva)+j;
z:=pole^[i];
pole^[i]:=pole^[j];
pole^[j]:=z;
dec(zbyva);
Dej:=z;
end;


Destructor TRandomEmiter.Done;
begin
FreeMem(pole,velikost*4);
end;


Constructor TStrom.Init(_rod,_pre,_dal:PStrom);
begin
predchozi:=_pre;
dalsi:=_dal;
potomek:=nil;
rodic:=_rod;  {POZOR, pripadnou vazbu "rodic^.potomek:=@self" si musis udelat sam}
skok:=@self;
end;

Function TStrom.Vem:PStrom;
begin
Vem:=potomek^.dejdalsi;
end;

Function TStrom.InitOffspring(q:pointer):PStrom;
var p:Pstrom;
begin
if potomek=nil then
   begin
   potomek:=New(PStrom,Init(@self,nil,nil));
   p:=potomek^.InitNext(q);
   Exit(p);
   end else
   begin
   p:=potomek^.InitNext(q);
   Exit(p);
   end;
end;

Function DefaultMySizeOf(p:pointer):longint;
var v:pstring;
begin
v:=p;
DefaultMySizeOf:=Length(v^)+1;
end;

Function DefaultCompMyData(p,q:pointer):boolean;
   {Function Copy_of_MySizeOf(p:pointer):longint;
   var v:pstring;
   begin
   v:=p;
   Copy_of_MySizeOf:=Length(v^)+1;
   end;}

var b:longint;
    pv,qv:longint;
begin
if p=nil then Exit(false);
pv:={Copy_of_MySizeOf(p);}procMySizeOf(p);
qv:={Copy_of_MySizeOf(q);}procMySizeOf(p);
if pv<>qv then Exit(false); { nevim, jestli si to muzu dovolit }
b:=CompareByte(p^,q^,qv);
DefaultCompMyData:=b=0;
end;

Function TStrom.SearchLast:PStrom;
begin
if predchozi=nil then
   SearchLast:=skok else SearchLast:=skok^.skok;
end;

Function TStrom.SearchFirst:PStrom;
begin
if predchozi=nil then
   SearchFirst:=@self else SearchFirst:=skok;
end;

Function TStrom.Search_Offsprings(p:pointer):PStrom;
var q,r:PStrom;
{ Vrstvove prochazeni.
1. Prohleda vsechny deti.
2. Pro kazde dite hleda vsechny jeho deti
...

Tzn. nikdy se nevraci zezdola nahoru (od vnoucat k detem)
}
begin
if p=vazba then Exit(@self);
if potomek<>nil then
   begin
   q:=pstrom(potomek^.dalsi);
   while q<>nil do
      begin
      (*if q^.vazba=p then Exit(q);*)
      if procCompMyData(q^.vazba,p) then Exit(q);
      q:=pstrom(q^.dalsi);
      end;

   q:=pstrom(potomek^.dalsi);
   while q<>nil do
      begin
      r:=q^.Search_Offsprings(p);
      if r<>nil then Exit(r);
      q:=pstrom(q^.dalsi);
      end;
   end;
Search_Offsprings:=nil;
end;

Function TStrom.InitNext(q:pointer):PStrom;
var p:PStrom;
begin
p:=SearchLast;
p^.dalsi:=New(PStrom, Init(rodic,p,nil));
if p^.predchozi=nil then
   begin
   p^.dejdalsi^.skok:=p;
   skok:=p^.dejdalsi;
   end
   else begin
   p^.dejdalsi^.skok:=p^.skok;
   p^.skok^.skok:=p^.dejdalsi;
   end;
p:=p^.dejdalsi;
p^.vazba:=q;
p^.potomek:=nil;
InitNext:=p;
end;

Procedure TStrom.Insert(p:PStrom);
var q,r1,r2:PStrom;
begin  { Vlozi dalsi (existujici) uzly mezi volany (self) a jeho naslednika }
q:=p^.SearchLast;
r2:=dejdalsi;
q^.dalsi:=r2;
p^.predchozi:=@self;
if r2<>nil then r2^.predchozi:=q;
dalsi:=p;
r1:=dejdalsi;
if predchozi=nil then
   begin
   while r1<>r2 do     {soucasne se tim osetri i <> nil}
      begin
      r1^.skok:=@self;
      r1:=r1^.dejdalsi;
      end;
   if r2=nil then skok:=q;
   end
   else
   begin
   while r1<>r2 do     {soucasne se tim osetri i <> nil}
      begin
      r1^.skok:=skok;
      r1:=r1^.dejdalsi;
      end;
   if r2=nil then skok^.skok:=q;
   end;
end;


Procedure TStrom.PozpatkuPrvky;
{krome prvku musi obratit i odkazy na potomky a taky odkazy deti na rodice}
var p,q,r:PStrom;
    v2,v3:pointer;
begin
p:=SearchLast;
q:=@self;
if q^.DejPredchozi=nil then q:=q^.DejDalsi;
if p=q then Exit;
repeat
   {prohozeni vazby}
   v2:=p^.vazba;
   p^.vazba:=q^.vazba;
   q^.vazba:=v2;
   {prohozeni potomku}
   v3:=p^.potomek;
   p^.potomek:=q^.potomek;
   q^.potomek:=v3;
   {prohodit rodice neni treba, protoze je maji vsichni stejne}

   {Zbyva vyresit odkazy na rodice od mych potomku}
   r:=p^.potomek;
   while r<>nil do
      begin
      r^.rodic:=p;
      r:=r^.dejdalsi;
      end;
   r:=q^.potomek;
   while r<>nil do
      begin
      r^.rodic:=q;
      r:=r^.dejdalsi;
      end;

   p:=p^.DejPredchozi;
   q:=q^.DejDalsi;
   until (p=q) or (p^.DejDalsi=q);
end;

Function Tstrom.Search_Parents(p:pointer):PStrom;
begin
if procCompMyData(vazba,p) then Exit(@self);
if rodic<>nil then Search_Parents:=rodic^.Search_Parents(p);
end;

Function TStrom.Root:PStrom;
begin
if rodic=nil then Exit(@self) else Root:=rodic^.root;
end;

Function TStrom.PocetPrvku:longint;
var a:PStrom;
    b:longint;
begin
a:=dalsi;
b:=0;
while a<>nil do begin inc(b);a:=a^.dalsi;end;
PocetPrvku:=b;
end;

Function TStrom.Deepness(p:Pstrom):longint;
begin
if p=@self then Deepness:=0 else
   if rodic<>nil then Deepness:=rodic^.Deepness(p)+1 else Deepness:=-1;
end;

Procedure DefaultSaveHeaderOfMyData(f:PBufStream);
begin end;

Function DefaultLoadHeaderOfMyData(f:PBufStream):boolean;
begin DefaultLoadHeaderOfMyData:=true;end;

Procedure DefaultSaveMyData(f:PBufStream;p:pointer;j:longint);
begin
if p<>nil then
   begin
   f^.write(j,4);
   f^.write(p^,j);
   end
   else
   begin
   j:=0;
   f^.write(j,4);
   end;
end;


Function TStrom.Save(s:string):byte;
var f:PbufStream;
    verze,reserved:byte;

   Procedure _Save(p:PStrom);
   var i:longint;
       q:PStrom;
   begin
   if p=nil then
      begin
      i:=0;
      f^.write(i,4);
      Exit;
      end;
   i:=p^.PocetPrvku;
   f^.write(i,4);   { Pocet prvku v teto generaci }
   q:=Pstrom(p^.dalsi);
   while q<>nil do
      begin
      i:=procMySizeOf(q^.vazba);
      procSaveMyData(f,q^.vazba,i);
      q:=Pstrom(q^.dalsi);
      end;

   q:=Pstrom(p^.dalsi);
   while q<>nil do
      begin
      _Save(q^.potomek);
      q:=Pstrom(q^.dalsi);
      end;
   end;

begin
f:=New(PBufStream,Init(s,{stOpenWrite}stCreate,st_BUFFERSIZE));
verze:=st_VERZESOUBORU;
reserved:=1;
procSaveHeaderOfMyData(f);
f^.Write(verze,1);
f^.Write(reserved,1);
_Save(potomek);
Dispose(f,Done);
Save:=st_OK;
end;


Function DefaultLoadMyData(f:PBufStream):pointer;
var velikost_polozky:longint;
    v:pointer;
begin
f^.read(velikost_polozky,4);
if velikost_polozky=0 then
   begin
   v:=nil;
   end
   else
   begin
   GetMem(v,velikost_polozky);
   f^.read(v^,velikost_polozky);
   end;
DefaultLoadMyData:=v;
end;


Function TStrom.Load(s:string):byte;
var f:PbufStream;
    x:byte;
    xx:boolean;

   Procedure _Load(p:PStrom);
   var q:PStrom;
       i:longint;
       v:pointer;
       pocet_prvku_v_generaci:longint;

   begin
   f^.read(pocet_prvku_v_generaci,4);
   if pocet_prvku_v_generaci=0 then Exit;
   q:=New(PStrom,Init(p,nil,nil));
   p^.potomek:=q;
   for i:=1 to pocet_prvku_v_generaci do
       begin
       v:=procLoadMyData(f);
       q^.InitNext(v);
       end;

   q:=Pstrom(q^.SearchFirst^.dalsi);
   while q<>nil do
      begin
      _Load(q);
      q:=PStrom(q^.dalsi);
      end;
   end;

begin
if potomek<>nil then Exit(st_NOT_EMPTY);
f:=New(PBufStream,init(s,stOpenRead,st_BUFFERSIZE));
if f^.errorinfo in [2,3] then Exit(st_FILENOTEXIST);
if procLoadHeaderOfMyData(f)=false then
   begin
   Dispose(f,Done);
   Exit(st_BADFORMAT);
   end;
f^.read(x,1);      { verze souboru  }
f^.read(xx,1);     { rezervovano? }

_Load(@self);
Dispose(f,Done);
Load:=st_OK;
end;


Function TStrom.Num_Childerns:longint;
begin
if potomek=nil then Num_Childerns:=0 else Num_Childerns:=potomek^.PocetPrvku;
end;

Function TStrom.Num_Offsprings:longint;
var p:PStrom;
    i:longint;
begin
i:=Num_Childerns;
if i=0 then Exit(0);
p:=pstrom(potomek^.dalsi);
while p<>nil do
   begin
   i:=i+p^.Num_Offsprings;
   p:=pstrom(p^.dalsi);
   end;
Num_Offsprings:=i;
end;


Function TStrom.Linearize:PVaznik;
var p:PStrom;
    q,r,t:PVaznik;
    v:pointer;
begin
if potomek=nil then Exit(nil);
q:=New(PVaznik,Init);
p:=pstrom(potomek^.dalsi);
while p<>nil do
   begin
   v:=p^.vazba;
   q^.InitNext(v);
   p:=p^.dalsi;
   end;

p:=pstrom(potomek^.dalsi);
while p<>nil do
   begin
   t:=p^.Linearize;
   q^.AbsorbujVaznik(q^.last,t);
   Dispose(t,Done);
   p:=p^.dalsi;
   end;
Linearize:=q;
end;


Procedure TStrom.InzertVaznik(p:PVaznik);
begin
p^.Reset;
while not p^.Konec do InitOffspring(p^.Nacti);
end;

Procedure TStrom.PridejPodstrom(p:Pstrom);
begin
potomek:=p;
while p<>nil do
   begin
   p^.rodic:=@self;
   p:=p^.dejdalsi;
   end;
end;

Procedure TStrom.For_Each(action:ActionType);
var p:PStrom;
    v:pointer;
begin
if potomek=nil then Exit;
p:=pstrom(potomek^.dalsi);
while p<>nil do
   begin
   v:=p^.vazba;
   if v<>nil then action(v);
   p:=PStrom(p^.dalsi);
   end;

p:=pstrom(potomek^.dalsi);
while p<>nil do
   begin
   p^.For_Each(action);
   p:=PStrom(p^.dalsi);
   end;
end;

Function TStrom.DejDalsi:PStrom;
begin
DejDalsi:=pstrom(dalsi);
end;

Function TStrom.DejPredchozi:PStrom;
begin
DejPredchozi:=pstrom(predchozi);
end;

Function TStrom.Vaznik_z_predku:PVaznik;
var p:PVaznik;
    q:PStrom;
begin
p:=New(PVaznik,Init);
q:=@self;
while q<>nil do
   begin
   p^.InsertNew(nil,q);
   q:=q^.rodic;
   end;
Vaznik_z_predku:=p;
end;


Function TStrom.Vaznik_z_generace_nasledniku:PVaznik;
{Na vaznik budou navazany nikoliv PStrom, ale PStrom^.vazba}
var p:PVaznik;
    q:PStrom;
begin
p:=New(PVaznik,Init);
q:=potomek;
while q<>nil do
   begin
   p^.InitNext(q^.vazba);
   q:=q^.dalsi;
   end;
Vaznik_z_generace_nasledniku:=p;
end;


Destructor TStrom.Done;
var p,q,r:PStrom;
begin
if rodic<>nil then
   if rodic^.potomek=@self then rodic^.potomek:=nil;
if dejdalsi=nil then skok^.skok:=dejpredchozi
   else
   if dejpredchozi=nil then   {rusim hlavicku seznamu, takze musim predelat SKOKY}
      begin                   {a taky vim, ze za hlavickou jeste neco je}
      r:=dejdalsi;
      p:=skok;           {posledni prvek}
      r^.skok:=p;
      q:=r^.dejdalsi;
      while q<>nil do
         begin
         q^.skok:=r;
         q:=q^.dejdalsi;
         end;
      end;

if dalsi<>nil then dalsi^.predchozi:=predchozi;
if predchozi<>nil then predchozi^.dalsi:=dalsi;
end;


Procedure Strom_Done_All(var p:PStrom;action:ActionType);
var q,r:PStrom;
    v:pointer;
begin
q:=p;
while q<>nil do
   begin
   if q^.potomek=nil then
      begin
      v:=q^.vazba;
      if v<>nil then
         if action<>nil then action(v);
      r:=Pstrom(q^.dalsi);
      Dispose(q,Done);
      q:=r;
      end
      else begin
      Strom_Done_All(q^.potomek,action);
      q^.potomek:=nil;
      end;
   end;
p:=nil;
end;

Function Uzel(objekt:pointer;dal:PUzel):PUzel;
begin
if tkadlo = nil then tkadlo:=New(PVaznik,Init);
tkadlo^.InitNext(objekt);
end;

Function Svazej(p:PUzel):PVaznik;
begin
tkadlo^.PozpatkuUzly;
Svazej:=tkadlo;
tkadlo:=nil;
end;

Function UzelS(objekt:pointer;dal:PStrom):PStrom;
begin
if skadlo = nil then skadlo:=New(PStrom,Init(nil,nil,nil));
UzelS:=skadlo^.InitNext(objekt);
end;


Function Vetev(objekt:pointer;spodek,dal:PStrom):PStrom;
var s:PStrom;
    p:PUzel;
begin
skadlo^.PozpatkuPrvky;
if dal=nil then
   begin
   skadlo:=New(PStrom,Init(nil,nil,nil));
   s:=skadlo^.InitNext(objekt);
   s^.PridejPodstrom(pstrom(spodek^.searchfirst));
   vetev:=s;
   end
   else begin
   {POP HL_VETEV}
   p:=seznam_vetveni^.Last;
   s:=p^.vazba;
   s^.InitNext(objekt);
   s:=s^.DejDalsi;
   s^.PridejPodstrom(skadlo);  {spodek je Skadlo}
   skadlo:=s^.SearchFirst;
   {skadlo:=pstrom(s^.SearchLast);}
   seznam_vetveni^.ZrusUzel(p);      {pop}
   {Vetev:=dal;}
   vetev:=s^.Searchlast;
   end;
end;

Function SvazejS(p:PStrom):PStrom;
var s:Pstrom;
{Musi byt vmezeren mezi DAL a SPODEK}
begin
{PUSH HL_VETEV}
if seznam_vetveni = nil then seznam_vetveni:=New(PVaznik,Init);
s:=pstrom(seznam_vetveni^.InitNext(p));  {push} {skadlo^.searchlast}
skadlo:=nil;
SvazejS:=s;  {neni nutne}
end;

Function StromDef(p:PStrom):PStrom;
var s:Pstrom;
    n:PUzel;
begin
if skadlo=nil then {Pro osetreni (nespravneho) zapisu StromDef(Svazej(...}
   begin
   n:=seznam_vetveni^.Last;
   s:=n^.vazba;
   skadlo:=PStrom(s^.SearchFirst);
   n^.Done;
   Dispose(n);
   end;
skadlo^.PozpatkuPrvky;
s:=New(Pstrom,Init(nil,nil,nil));
s^.PridejPodstrom(skadlo);
StromDef:=s;
skadlo:=nil;
if seznam_vetveni<>nil then begin Dispose(seznam_vetveni,Done);seznam_vetveni:=nil;end;
end;

Function TStrom.Duplicate:PStrom;
var p,q,r,s,t:PStrom;
begin
r:=New(PStrom,Init(nil,nil,nil));
p:=r;
q:=@self;
r^.vazba:=q^.vazba;
s:=q^.potomek;
if s<>nil then
   begin
   t:=s^.Duplicate;
   r^.PridejPodstrom(t);
   end;
q:=q^.dejdalsi;
while q<>nil do
   begin
   r^.Insert(New(PStrom,Init(nil,nil,nil)));
   r:=r^.dejdalsi;
   r^.vazba:=q^.vazba;
   s:=q^.potomek;
   if s<>nil then
      begin
      t:=s^.Duplicate;
      r^.PridejPodstrom(t);
      end;
   q:=q^.dejdalsi;
   end;
Duplicate:=p;
end;

Function TStrom.Kolikaty_v_linii(p:Pstrom):longint;
{P je nikoliv hledany uzel, ale hledana oblast, t.j. spravne se ma pouzivat:
 i:=prvek^.Kolikaty_v_linii(blok_dat) }
var l:longint;
begin
l:=0;
while p<>nil do
   begin
   if p=@self then Exit(l);
   p:=p^.dalsi;
   inc(l);
   end;
Kolikaty_v_linii:=-1;
end;

Function TStrom.SearchRecord(id:integer):PStrom;
{Pokud je ID vetsi nez pocet polozek, tak vrati maximalni polozku}
var a:PStrom;
    b:integer;
begin
a:=@self;
for b:=1 to id do
    if a^.dalsi<>nil then a:=a^.dalsi
                     else Exit(a);
SearchRecord:=a;
end;



begin
procMySizeOf:=@DefaultMySizeOf;
procSaveMyData:=@DefaultSaveMyData;
procSaveHeaderOfMyData:=@DefaultSaveHeaderOfMyData;
procLoadMyData:=@DefaultLoadMyData;
procLoadHeaderOfMyData:=@DefaultLoadHeaderOfMyData;
procCompMyData:=@DefaultCompMyData;
end.
