unit Clanky;
{$I defines.inc}

{$R-}
{$Q-}
{$S-}

interface
uses Vaznik;

type
     pclanek = ^tclanek;
     tclanek = packed record
     pocet_radek:longint;
     nadpis:pstring;
     text:pchar;
     end;

     tdpole = array[0..0] of pointer;
     pdpole = ^tdpole;


Function Nacti_Data(co:string):pdpole;
Function hlll(hl:pdpole;s:string):PClanek;
Function hlla(const s:string):string;
Function hllp(hl:pdpole;const s:string):pchar;
Function hllp(const s:string):pchar;

Function Far_hlll(segm:word;hl:pdpole;s:string):pointer;
Procedure Far_hllq(segm:word;hl:pdpole;s:string;vystup_p:pchar);
Function Far_hllp(segm:word;hl:pdpole;s:string):pchar;
Function Far_hlla(segm:word;hl:pdpole;s:string):string;

Procedure Far_pstring_util(segm:word;adr:longint;var frs:string);


var vaznik_s_hlaskami:pdpole;
    otazniky:string[2];
    clKonecRadky:string[5];
    CL_bylo_nalezeno:boolean;

implementation
uses Lacrt,tedradky;

const CL_NENALEZENO = '???';
type Tindextyp = array['_'..'z'] of record min,max:longint;end;
     Pindextyp = ^Tindextyp;

Function Trideni_S(p,q:pointer):boolean;
var v1,v2:pclanek;
begin
v1:=p;v2:=q;
Trideni_S:=v1^.nadpis^<v2^.nadpis^;
end;

{Function DoPole(p:PVaznik):pdpole;
var d:pdpole;
    i,j:longint;

    e:PClanek;

begin
i:=p^.pocet;
GetMem(d,(i+1)*4);
d^[0]:=pointer(i);
j:=1;
p^.Reset;
while not p^.Konec do
   begin
   e:=p^.Nacti;
   d^[j]:=e;
   inc(j);
   end;
DoPole:=d;
end;}


Function DoPole(p:PVaznik):pdpole;
var d:pdpole;
    i,j:longint;
    u,w:char;
    e:PClanek;
    indx:Pindextyp;

begin
i:=p^.pocet;
GetMem(d,(i+1+1)*4);     {pamet na strukturu s clanky}
New(indx);
d^[0]:=pointer(i);       {pocet clanku ve strukture}
d^[1]:=indx;             {odkaz na index (pro rychle vyhledavani)}

j:=2;      {texty budou az od pozice 2}

FillChar(indx^,sizeof(Tindextyp),0);   {vynulovani indexu}
w:=#0;
p^.Reset;
while not p^.Konec do
   begin
   e:=p^.Nacti;
   d^[j]:=e;
   u:=e^.nadpis^[1];  {prvni pismeno nadpisu?}
   if u>w then        {najeli jsme na jine pismeno, nez bylo to dosavadni?}
      begin
      if w<>#0 then indx^[w].max:=j-1;
      w:=u;
      indx^[w].min:=j;
      end;
   inc(j);
   end;
if w<>#0 then indx^[w].max:=j-1;
DoPole:=d;
end;


Function Nacti_Data(co:string):pdpole;
var f:text;
    s:string;
    p:PVaznik;
    v:pclanek;
    e:PEdRadek;
    h:pchar;
    hd,hn0,hnx:longint;
    bylo_prazdnych_radku,a:byte;
    byl_uz_nejaky_titulek:boolean;

begin
Assign(f,co);
Reset(f);
p:=NovyVaznik;
p^.porovnejproc:=@Trideni_S;
e:=nil;
byl_uz_nejaky_titulek:=false;
while not Eof(f) do
   begin
   hd:=NactiRadkuTextovehoSouboru(f,h);
   hn0:=Prvni_za_mezerami(h);

   if hn0=-1
      then if byl_uz_nejaky_titulek=true then inc(bylo_prazdnych_radku)
      {Co delat s uplne prazdnymi radky? Kdyz jsou mezi ne-prazdnymi
       radky, tak je proste chape jako prazdne radky. Kdyz jsou ale na
       konci clanku, tak je vyradime, protoze je povazujeme za formatovaci
       zalezitost vlozenou pro lepsi prehlednost clankoveho souboru.
       Pokus skutecne chces prazdne radky na konci, tak je vloz do
       pascalovskych uvozovek ' '}
      else
   else begin  {hd<>0}
   if h[hn0]='#' then  {1.varianta - radek zacina znakem #}
      begin
      s:=h;                  {vime, ze neb++udeme delsi nez 255 znaku...}
      s:=SkipAllSpaces(s);   {...takze prevod na string pro lepsi manilulaci}
      if s[2]<>'#' then    {zacatek ## se bude chapat jako komentar}
         begin
         byl_uz_nejaky_titulek:=true;
         if e<>nil then
            begin          {uzaveni rozdelaneho clanku (abychom byli pripraveni na novy)}
            v^.text:=e^.p;      {nutne - pri e^.VlozS se muze menit e^.p}
            e^.p:=nil;
            Dispose(e,Done);
            end;
         delete(s,1,1);
         s:=Convert_down(s);
         bylo_prazdnych_radku:=0;
         new(v);
         e:=New(PEdRadek,Init);
         v^.nadpis:=NaPstring(s);
         v^.text:=e^.p;
         v^.pocet_radek:=0;
         p^.InsertSort(v);
         end;
      end
      else begin    {2.varianta - na zacatku radky neni #}
      if byl_uz_nejaky_titulek=true then
         begin
         hnx:=Posledni_pred_Mezerami(h,hd);
         if h[hn0]=#39     {znak "'"}
             then begin
                  inc(hn0);
                  dec(hnx);
                  end
                  else begin
                  {hn0:=0;
                  hnx:=hd;}
                  end;

         if bylo_prazdnych_radku<>0 then
            begin
            inc(v^.pocet_radek,bylo_prazdnych_radku);
            for a:=1 to bylo_prazdnych_radku do e^.VlozS(#13#10,e^.spp);
            bylo_prazdnych_radku:=0;
            end;
         inc(v^.pocet_radek);
         if v^.pocet_radek<>1 then e^.VlozS(#13#10,e^.spp);
         e^.Vloz(@h[hn0],hnx-hn0+1,e^.spp);
         end;
      end;
   end;
   FreeMem(h);
   end;
v^.text:=e^.p;      {nutne - pri e^.VlozS se muze menit e^.p}
e^.p:=nil;
Dispose(e,Done);
Close(f);
Nacti_Data:=DoPole(p);
Vaznik_Done_All(p);
end;


Function Get_DS_selector:word;assembler;
asm
mov ax,ds
end;

Function get_far_pointer(segm:word;hl:pdpole;i:longint):pointer;assembler;
asm
push esi
push es
mov ax,segm
mov es,ax
mov esi,hl
mov ebx,i
shl ebx,2 {EBX:=EBX*4}
add esi,ebx
mov eax,es:[esi]
pop es
pop esi
end;


Function Far_v_pocet_radek(segm:word;v:PClanek):longint;assembler;
asm
push es
mov ax,segm
mov es,ax

mov ebx,v
mov eax,es:[ebx]

pop es
end;


Procedure Far_v_nadpis(segm:word;v:PClanek;var frs:string);assembler;
asm
push es
mov ax,segm
mov es,ax

mov ebx,v
mov edx,es:[ebx+4]  {TClanek.nadpis}

mov ecx,0
mov cl,es:[edx]  {delka retezce}

mov esi,frs

mov ds:[esi],cl    {jiz nas segment}

@smycka:
inc edx
inc esi
mov al,es:[edx]
mov ds:[esi],al
loop @smycka

pop es
end;



Procedure Far_pstring_util(segm:word;adr:longint;var frs:string);assembler;
{ADR je vlastne PString, ale do ciziho segmentu}
asm
push es
mov ax,segm
mov es,ax
mov edx,adr
mov ecx,0
mov cl,es:[edx]  {delka retezce}
mov esi,frs
mov ds:[esi],cl    {jiz nas segment}

@smycka:
inc edx
inc esi
mov al,es:[edx]
mov ds:[esi],al
loop @smycka

pop es
end;



Procedure Far_v_text(segm:word;v:PClanek;frs:pchar);assembler;
asm
push es
mov ax,segm
mov es,ax

mov ebx,v
mov edx,es:[ebx+8]  {TClanek.text}

mov esi,frs

mov ecx,0

@smycka:
mov cl,es:[edx]
mov ds:[esi],cl    {jiz nas segment}
inc edx
inc esi
cmp cl,0
jnz @smycka

pop es
end;




{Function hlll(hl:pdpole;s:string):PClanek;
var i,j,a:longint;
    v:pclanek;
begin
j:=longint(hl^[0]);
i:=1;
s:=Convert_down(s);
CL_bylo_nalezeno:=true;
repeat
a:=(j+i) div 2;
v:=hl^[a];
if s<v^.nadpis^ then j:=a-1 else
if s>v^.nadpis^ then i:=a+1 else
if s=v^.nadpis^ then Exit(v);
until j-i<0;
CL_bylo_nalezeno:=false;
hlll:=nil;
end;}


Function hlll(hl:pdpole;s:string):PClanek;
var i,j,a:longint;
    v:pclanek;
    indx:PIndexTyp;
    u:char;

begin
CL_bylo_nalezeno:=false;
s:=Convert_down(s);
u:=s[1];

indx:=hl^[1];

i:=indx^[u].min;        {jake je minimum pri pismeno U?}
if i=0 then Exit(nil); {Nula? Takze pro pismeno U nemame zadny clanek. Konec.}

j:=indx^[u].max;

repeat
a:=(j+i) div 2;
v:=hl^[a];
if s<v^.nadpis^ then j:=a-1 else
if s>v^.nadpis^ then i:=a+1 else
if s=v^.nadpis^ then
   begin
   CL_bylo_nalezeno:=true;
   Exit(v);
   end;
until j-i<0;
hlll:=nil;
end;



Function far_hlll(segm:word;hl:pdpole;s:string):pointer;
{pozor, pointer bude ukazovat do ciziho segmentu, t.j. do segmentu SEGM}
var i,j,a:longint;
    v:pointer;
    fnadpis:string;

begin
j:=longint(get_far_pointer(segm,hl,0)+1);  {j:=pocet clanku+1}
i:=2;
s:=Convert_down(s);
CL_bylo_nalezeno:=true;

repeat
a:=(j+i) div 2;

v:=get_far_pointer(segm,hl,a);

Far_v_nadpis(segm,v,fnadpis);

if s<fnadpis then j:=a-1 else
if s>fnadpis then i:=a+1 else
if s=fnadpis then Exit(v);

until j-i<0;
CL_bylo_nalezeno:=false;
far_hlll:=nil;
end;



Function hllp(hl:pdpole;const s:string):pchar;
var i,j,a:longint;
    v:pclanek;
begin
v:=hlll(hl,s);
if v=nil then hllp:=CL_NENALEZENO else hllp:=v^.text;
end;

Function hlla(const s:string):string;
var p:pchar;
begin
p:=hllp(vaznik_s_hlaskami,s);
hlla:=p;
end;

Function hllp(const s:string):pchar;
begin
hllp:=hllp(vaznik_s_hlaskami,s);
end;


Procedure Far_hllq(segm:word;hl:pdpole;s:string;vystup_p:pchar);
{P musi ukazovat na dostatecne velky buffer}
var p:pointer;
    nen:string;
begin
p:=far_hlll(segm,hl,s);
if p=nil then
   begin
   nen:=CL_NENALEZENO+#0;
   Move(nen[1],vystup_p,Length(nen));
   Exit;
   end;

far_v_text(segm,p,vystup_p);
end;


Function Far_hlla(segm:word;hl:pdpole;s:string):string;
var buf:array[0..8192] of byte;
    p:pchar;
    t:string;
    i:longint;

begin
p:=@buf;
far_hllq(segm,hl,s,p);
i:=PLength(p);
if i>255 then i:=255;
t[0]:=char(i);
move(buf,t[1],i);
far_hlla:=t;
end;


Function Far_hllp(segm:word;hl:pdpole;s:string):pchar;
{pro retezce alokuje misto na heapu}
var buf:array[0..8192] of byte;
    p,q:pchar;
    i:longint;

begin
p:=@buf;
far_hllq(segm,hl,s,p);
i:=PLength(p);

GetMem(q,i+1);
Move(buf,q[0],i);
q[i]:=#0;           {pro jistotu}
Far_hllp:=q;
end;


end.
