program HTML2Texy;

uses dos; {pouzito pro moznost zjisteni existence souboru}

{definice zacatku a koncu znacek}
const ZPZ = '<';
      ZDZ = '</';
      KZ  = '>';
      KZX = ' />';
      MAXT = 0; {pripadna maximalni hloubka stromu}

{definice polozky stromu}
type PtrS = ^S;
     S = record
	       name : string[20];      {jmeno znacky}
               istext : boolean; {priznak pro innerText}
               isattr : boolean; {priznak pro atribut}
               value : string;   {hodnota innerTextu}
               child : PtrS;		 {ukazatel na potomka}
               next : PtrS;			 {ukazatel na sourozence}
         end;

{definice zasobniku pro pridavani do stromu}
type PtrL = ^Lifo;
     Lifo = record
               name : string[20]; {jmeno znacky}
               ptr : PtrS;				{ukazatel ve stromu}
               next : PtrL;				{ukazatel na dalsi polozku zasobniku}
            end;

{definice promennych}
var f,g : text;
    c : char;
    buffer : string;
    ground,prev,parent : PtrS;
    eolf : PtrL;
    ZRead : boolean;
    ul : boolean;
    cnt : longint;
    Ssoubor: string;
    Vsoubor: string;
    UVOZ : 34..39;

{procedura pro smazani stromu HTML dokumentu}
procedure DisposeTree(var ptr: PtrS);
begin
    if ptr^.child <> NIL then DisposeTree(ptr^.child); {zavolani funkce na potomky}
    if ptr^.next <> NIL then DisposeTree(ptr^.next);   {zavolani funkce na nasledovniky}

    dispose(ptr); {odstraneni z pameti}
end;

{procedura pro odebrani znacky ze zasobniku}
procedure RemFromLifo;
var actual : PtrL;
begin
    actual := eolf;
    {writeln('odebiram ',actual^.name);{}
    if (actual = NIL) then
    begin
    	 {pokud by melo dojit k odebrani NILu ze zasobniku, je uzavreno vice znacek nez otevreno}
    	 {zpusobeno nevalidnim vstupem; doslo by k selhani programu}
         writeln('Vstupni soubor nebyl validni');
         DisposeTree(ground);
         halt;
    end;

    eolf := actual^.next;
    dispose(actual);
end;

{procedura predchazejici zacykleni cyklu cekajicich na urcity znak}
procedure NotValid;
begin
    writeln('Zadany vstup neni validni.');
    DisposeTree(ground);
    while (eolf <> NIL) do
    begin
        RemFromLifo;
    end;
    halt;
end;

{V pripade, ze ukonci beh programu, vstup nebyl validni}
procedure CheckEof;
begin
    if eof(f) then NotValid;
end;

{funkce zjistujici existenci souboru}
function FileExists(FN :string) :boolean;
var S : PathStr;
begin
   S := FSearch(FN,'');   {hledani v seznamu souboru}
   if S = '' then FileExists := false else FileExists := true; {dosazeni do funkce}
end;

{procedura pro otevreni vstupniho souboru}
procedure OpenFile(var f: text; path : string);
begin
     if FileExists(path) then  {pokud soubor existuje, otevreme ho ke cteni}
     begin
          assign(f,path);
          reset(f);
     end
     else {v opacnem pripade ohlasime chybu a skoncime}
     begin
         writeln('CHYBA: Soubor nenalezen!'); 
         halt;
     end;

end;

{procedura pro otevreni vystupniho souboru}
procedure OpenVFile(var g: text; path : string);
begin
     assign(g,path);
     rewrite(g);
end;

procedure CheckMem;
begin

     {ochrana proti HEAP overflow, ktery je zapricinen prilis velkym vstupem}
     if (MaxAvail < 300) then
     begin
         writeln('Vstupni soubor obsahuje prilis mnoho dat.');
         writeln('Rozdelte jej na nekolik mensich.');
         DisposeTree(ground);

         while (eolf <> NIL) do
         begin
             RemFromLifo;
         end;

         halt;
     end;

end;

{procedura pro pridani polozky do stromu}
procedure AddToTree(var ptr: PtrS; var name: string; istext: boolean; isattr: boolean;
                    value: string; var parent: PtrS; var prev: PtrS);
begin
		
		 {nastaveni vlastnosti polozky}
     ptr^.name := name;
     ptr^.istext := istext;
     ptr^.isattr := isattr;
     ptr^.value := value;
     ptr^.child := NIL;
     ptr^.next := NIL;

     {pokud rodic jeste nema potomka, nastavi akt. prvek jako potomka}
     if (parent^.child = NIL) AND (parent <> NIL) then
     begin
          parent^.child := ptr;
     end;

     {pokud existuje predchazejici sourozenec, zaradi akt. prvek za nej}
     if (prev <> NIL) then
     begin
         prev^.next := ptr;{}
     end;{}

     {pokud je akt. prvek prvni polozkou stromu}
     if ground = NIL then
     begin
          ground := ptr;
     end;

     CheckMem;

end;

{procedura hledajici pozici, kam se bude zarazovat dalsi prvek}
procedure GetTreePos(var rodic : PtrS; var sourozenec : PtrS);
var temp : PtrS;
begin
        rodic := NIL;
        sourozenec := NIL;

        if (eolf <> NIL) AND (eolf^.ptr <> NIL) then
        begin
             rodic := eolf^.ptr; {rodicem je konec zasobniku}

						 {soourozencem je potomek rodice ukazujici na NIL}
             if eolf^.ptr^.child <> NIL then
             begin
                 temp := eolf^.ptr^.child;
                 while temp^.next <> NIL do
                 begin
                     temp := temp^.next;
                 end;
                 sourozenec := temp;
             end;

        end;
end;

{funkce, ktera ze stromu ziska hodnotu prislusneho atributu znacky}
function GetAttrVal(var ptr : PtrS; attrname : string): string;
var actual : PtrS;
begin
    actual := ptr^.child;
    {pokud ma prvek potomky (atributy jsou mezi nimi)}
    while actual <> NIL do
    begin    		
         if (actual^.name = attrname) AND (actual^.isattr = true) then
         begin
         		{hodnota atributu nalezena, dosadime do funkce a funkci ukoncime}
            GetAttrVal := actual^.value;
            exit;
         end;
         actual := actual^.next;
    end;
    GetAttrVal := '';{}
end;

{procedura pro rekurzivni prochazeni stromu a preklad do syntaxe Texy!}
procedure TranslateTree(var ptr: PtrS; level : longint);
var temp,temp2 : string;
begin

     if MAXT > 0 then
     begin
         if level >= MAXT then
         begin
             writeln('CHYBA. Prilis velke zanoreni znacek.');
             writeln('Rozdelte dokument do nekolika casti.');
             DisposeTree(ground);
             halt;
         end;
     end;

     {znaky, ktere je treba vypsat pred innerTextem}

     if ptr^.isattr = false then
     begin

	     if ptr^.name = 'b' then write(g,'**');
	     if ptr^.name = 'strong' then write(g,'**');
	     if ptr^.name = 'i' then write(g,'*');
	     if ptr^.name = 'em' then write(g,'*');
	     if ptr^.name = 'p' then write(g,chr(10),chr(13));
	     if ptr^.name = 'br' then write(g,chr(10),' ');
	     if ptr^.name = 'hr' then write(g,chr(10),'--------');
	     if ptr^.name = 'h1' then write(g,chr(10),'=======');
	     if ptr^.name = 'h2' then write(g,chr(10),'======');
	     if ptr^.name = 'h3' then write(g,chr(10),'=====');
	     if ptr^.name = 'h4' then write(g,chr(10),'====');
	     if ptr^.name = 'h5' then write(g,chr(10),'===');
	     if ptr^.name = 'h6' then write(g,chr(10),'==');
	     if ptr^.name = 'title' then write(g,chr(10),chr(60),'!-- ');
	     if ptr^.name = 'dd' then write(g,chr(10),'  -');
	     if ptr^.name = 'dt' then write(g,chr(10));
	     if ptr^.name = 'tr' then writeln(g);
	     if ptr^.name = 'td' then write(g,'| ');
	     if ptr^.name = 'th' then write(g,'|* ');
	
	
	     if ptr^.name = 'div' then
	     begin
	          write(g,chr(10),'/---div');
	          temp := GetAttrVal(ptr,'class');{}
	          if temp <> '' then write(g,' .[',temp,']');
	          write(g,chr(10));
	     end;
	
	     if ptr^.name = 'a' then write(g,' "');
	
	     if ptr^.name = 'img' then
	     begin
	          write(g,'[* ');
	          write(g,GetAttrVal(ptr,'src'));{}
	     end;
	
	     if ptr^.name = 'sup' then write(g,'^');
	     if ptr^.name = 'sub' then write(g,'_');
	
	     if ptr^.name = 'ul' then ul := true;
	     if ptr^.name = 'ol' then ul := false;
	
	     if ptr^.name = 'li' then
	     begin
	         if ul = true then write(g,chr(10),'- ') else
	                           begin
	                           write(g,chr(10),cnt+1,') ');
	                           inc(cnt);
	                           end;
	     end;
     end;

		 {innerText}

     if ptr^.istext = true then write(g,ptr^.value);

		 {zavolani funkce na potomky}
     if (ptr^.child <> NIL) then
     begin
          if ptr^.name <> 'script' then
          begin
               TranslateTree(ptr^.child,level+1);
          end;
     end;

     {znaky, ktere je treba vypsat za innerTextem}
     if ptr^.isattr = false then
     begin

     if ptr^.name = 'b' then write(g,'**');
     if ptr^.name = 'strong' then write(g,'**');
     if ptr^.name = 'i' then write(g,'*');
     if ptr^.name = 'em' then write(g,'*');
     if ptr^.name = 'title' then write(g,' --',chr(62),chr(10));

     if ptr^.name = 'acronym' then write(g,'((',GetAttrVal(ptr,'title'),'))');

     if ptr^.name = 'div' then write(g,chr(10),'\--- ',chr(10));
     if ptr^.name = 'dt' then write(g,':');

     if (ptr^.name = 'td') OR (ptr^.name = 'th') then
     begin
          write(g,' ');
     end;

     if ptr^.name = 'a' then
     begin
          write(g,'":');
          write(g,GetAttrVal(ptr,'href'),' ');
     end;

     if ptr^.name = 'img' then
     begin
          temp := GetAttrVal(ptr,'width');{}
          temp2 := GetAttrVal(ptr,'height');{}

          if (temp <> '') AND (temp2 <> '') then
          begin
              write(g,' ',temp,'x',temp2);
          end;


          write(g,' .(',GetAttrVal(ptr,'alt'),')');
          temp := GetAttrVal(ptr,'class');
          if temp <> '' then write(g,'[',temp,']');{}

          temp := GetAttrVal(ptr,'align');{}
          if temp = '' then write(g,' *] ');
          if temp = 'left' then write(g,' <] ');
          if temp = 'right' then write(g,' >] ');
     end;

     if ptr^.name = 'ul' then ul := false;
     if ptr^.name = 'ol' then begin ul := false; cnt := 0; end;

     if ptr^.name = 'p' then
     begin
         temp := GetAttrVal(ptr,'align');
         if temp = 'left' then write(g,' .<');
         if temp = 'right' then write(g,' .>');
         if temp = 'center' then write(g,' .<>');
     end;

     end;

		{zavolani funkce na sourozence}
     if ptr^.next <> NIL then TranslateTree(ptr^.next,level);
end;

{procedura pro testovaci vypis struktury stromu}
procedure FetchTreeItem(var ptr: PtrS; level : longint);
var i : longint;
begin
     for i := level downto 2 do
         write(' ');
     if level > 0 then write(chr(192));

     write(ptr^.name);{}
     if ptr^.isattr = true then write(' *atrr (',ptr^.value,')');
     if ptr^.istext = true then write(' * (',ptr^.value,')');
     writeln;

     if ptr^.child <> NIL then FetchTreeItem(ptr^.child,level+1); {zavolani funkce na potomky}
     if ptr^.next <> NIL then FetchTreeItem(ptr^.next,level); {zavolani funkce na sourozence}
end;

{procedura, ktera prida znacku do zasobniku a zavola jeji pridani do stromu}
procedure AddToLifo(var name : string; var ptrI: PtrS);
var actual : PtrL;
    temp,sourozenec,rodic : PtrS;
begin
    new(actual);             {nove misto v pameti}

    writeln('pridavam ',name);{}

    rodic := NIL;
    sourozenec := NIL;

    GetTreePos(rodic,sourozenec); {ziskani pozice ve stromu}

    if eolf <> NIL then rodic := eolf^.ptr else rodic := NIL;

    {writeln(name,rodic^.name,sourozenec^.name);{}
    AddToTree(ptrI,name,false,false,'',rodic,sourozenec);{}

    actual^.name := name;    {nastaveni vlastnosti}
    actual^.ptr := ptrI;
    actual^.next := eolf;

    eolf := actual;          {novy konec zasobniku}
end;

{procedura pro ziskani hodnoty atributu, ktera posleze zavola pridani atributu do stromu}
procedure ParseAttrs(var buffer: string);
var c,name,val : string;
    index : integer;
    sourozenec, rodic, item : PtrS;
begin
     c := '';
     name := '';
     val := '';
     index := 1;
     sourozenec := NIL;
     rodic := NIL;

     {pokud dostaneme na vstpu validni znaky pro atributy}
     if (buffer <> '/') AND (buffer <> '') then
     begin

        CheckMem;
	       
        new(item); {rezervujeme misto v pameti}

        while (c <> '=') do {pred znakem = hledame jmeno atributu}
        begin
             name := name + c;
             c := copy(buffer,index,1);
             inc(index);

             if index >= length(buffer) then
             begin
                 NotValid;
             end;
        end;
        inc (index);
        val := copy(buffer,index,length(buffer)-index+1); {vsechno dalsi je hodnota atributu}

        GetTreePos(rodic,sourozenec); {dosazeni pozice ve stromu}

        AddToTree(item,name,false,true,val,rodic,sourozenec); {pridani do stromu}
        {writeln('pridavam atribut ',name);{}
     end;
     buffer := '';
end;

{procedura, ktera hleda ve znacce atributy a predava je k rozparsovani}
procedure ReadAttrs(var f : text; var c : char; var eot: boolean);
var buffer : string;
    openattr : boolean;
    index : integer;
    backslash: boolean;
begin

   buffer := '';
   index := 0;

   openattr := false;
   backslash := false;

   while c <> KZ do {dokud nenarazime na konec znacky, hledame atributy}
   begin
       {write(c);{}
       if ((c <> ' ') AND (openattr = false)) OR ((c <> chr(UVOZ)) AND (openattr = true)) then
       begin
          if (c <> chr(10)) AND (c <> chr(13)) AND (c <> chr(9)) then
          buffer := buffer + c;

	  {pokud je atribut delsi nez 255 znaku, je treba jej rozdelit do vice polozek}
          {takove atributy vsak nejsou prekladany, nebot je syntaxe texy nezna}
					
          if index = 254 then
          begin
              ParseAttrs(buffer);
              buffer := '='+chr(UVOZ);
              index := 1;
          end;
          if ((c = chr(UVOZ)) AND (backslash = false)) then openattr := NOT openattr;
          inc(index);
       end
       else
       begin
          if (backslash = false)
          then
          begin
              ParseAttrs(buffer);
              openattr := false;
          end
          else buffer := buffer+c;
       end;
       if c = '\' then backslash := true else backslash := false;
       read(f,c);
       CheckEof;
   end;

   ZRead := true;

   if buffer = '/' then eot := true;
   if buffer <> '' then ParseAttrs(buffer);
end;

{procedura pro precteni innerTextu - textu mezi znackami}
procedure ReadInner(var f : text; var c : char);
var buffer,name : string;
    index : integer;
    rodic, sourozenec,item : PtrS;
begin

    buffer := '';
    name := 'innerText';

    ZRead := false;

    index := 0;

    read(f,c);

    {writeln('jsem zavolan na ',eolf^.ptr^.name,'|');{}
    {write(c);{}

    {osetreni proti nezakomentovanemu script se znakem <}
    if (eolf^.ptr^.name = 'script') then
    begin

         while (copy(buffer,index-9,9) <> '</script>') do
         begin

             buffer := buffer+c;

             if index = 254 then
             begin
                 index := 9;
                 buffer := copy(buffer,245,9); {v bufferu mohu mit cast hledaneho vyrazu}
             end;

             read(f,c);
             inc(index);
         end;
         exit;
    end;

    {osetreni proti nezakomentovanemu style se znakem <}
    if (eolf^.ptr^.name = 'style') then
    begin

         while (copy(buffer,index-8,8) <> '</style>') do
         begin

             buffer := buffer+c;

             if index = 254 then
             begin
                 index := 8;
                 buffer := copy(buffer,246,8);
             end;

             read(f,c);
             inc(index);
         end;
         exit;
    end;

    {dokud nenarazim na dalsi znacku, ctu hodnotu innerTextu}
    while ((c <> ZPZ) AND (NOT(eof(f)))) do
    begin
         if (c <> chr(10)) AND (c <> chr(13)) AND (c <> chr(9))
         then buffer := buffer+c;

	 {pokud je innerText delsi nez 255 znaku, je treba ho rozdelit do vice polozek}
         if index = 254 then
         begin
         		
             CheckMem;
         
             new(item);
             GetTreePos(rodic,sourozenec);
             AddToTree(item,name,true,false,buffer,rodic,sourozenec); {pridani polozky do stromu}
             index := -1;
             buffer := '';
         end;
         read(f,c);
         {write(ord(c),' ');{}

         inc(index);
    end;

    ZRead := true;

    if (buffer <> ' ') AND (buffer <> '') then
    begin
         {writeln(buffer,' napsal inner');{}
         new(item);
         GetTreePos(rodic,sourozenec);
         {writeln('~',name,rodic^.name,sourozenec^.name);{}
         AddToTree(item,name,true,false,buffer,rodic,sourozenec);{}

    end;

end;

{procedura, ktera hleda nazvy znacek a vola ReadInner a ReadAttrs}
procedure ParseHTML(var f : text);
var cbn,eot,added : boolean;
    name : string;
    treeItem : PtrS;
begin

     buffer := '';
     added := false;

     while not eof(f) do  {dokud nejsem na konci souboru}
     begin

          cbn := true;
          eot := false;

	  {boolean ZRead je nastaven procedurou ReadInner, ktera precte zacatecni znak znacky}
          if ZRead = false then read(f,c) else ZRead := false;      {nacti znak}

	  {hromadeni ziskane hodnoty}
          buffer := buffer + c;
          added := false;

	  if c = ZPZ then {pokud je to zacatek znacky}
	  begin
               {if (buffer <> '') AND (buffer <> ZPZ) then writeln(buffer);{}
               buffer := '';
               read(f,c); {cti znak}

               if c = '/' then  {pokud je znacka ukoncujici, nastav eot na true}
               begin
                    eot := true;
                    read(f,c);
               end;

               CheckMem;

               new(treeItem);

	       while c <> KZ do {precti celou znacku}
	       begin
                    if (c = ' ') then {pokud narazis na mezeru}
                    begin
                         if cbn = true then {pokud je to prvni mezera ve znacce}
                         begin
                             {writeln(name);{}
                             name := buffer; {aktualni sbirka znaku je nazev znacky}
                             cbn := false;   {zname jmeno}
                             
                             {DOCTYPE a poznamky jsou pro dokument nepodstatne a vymykaji se beznemu formatu}
                             if (name <> '!DOCTYPE') AND (copy(name,1,3) <> '!--')
                                AND (copy(name,1,1) <> '?')
                             then
                             begin
                                  AddToLifo(name,treeItem); {pridej do zasobniku}
                                  ReadAttrs(f,c,eot); {precti atributy znacky}
                             end;
                             added := true;
                         end;
                    end;

	            buffer := buffer + c; {cti dal}
	            
	            {boolean ZRead nastavuje procedura ReadAttrs, ktera jako posledni precte znak}
	            {ktery je zde potrebny a jinak by doslo k jeho zahozeni}
	            if ZRead = false then read(f,c) else ZRead := false;
                    {CheckEof;{}
	       end;
               if cbn = true then name := buffer; {pokud ve znacce nebyla mezera, je cely jeji obsah jmeno}

	       {writeln(buffer,' ',name);{}
	       				
	       			 {pokud nemame znacku odebrat, pridame ji...}
               if NOT eot then
               begin
               			{... pokud nebyla pridana vyse v kodu (obsahovala mezeru)}
                    if NOT added then AddToLifo(name,treeItem);
               end;
							
							 {pokud je znacka ukoncujici nebo neparova, odebereme ze zasobniku}	
               if ((eot) OR (copy(buffer,length(buffer),1) = '/')) then
                   RemFromLifo;{}           {odeber ze zasobniku}

               {writeln('volam inner');{}
               ReadInner(f,c);{}

               buffer := '';

	  end;
     end;

end;

{incializace programu}
begin

     ul := false;
     cnt := 0;
     ZRead := false;

     writeln('HTML2Texy! prevadec');{}
     writeln;{}
     
     {ziskani cesty ke vstupnimu souboru}
     writeln('Zadejte cestu ke vstupnimu HTML souboru:');{}
     readln(Ssoubor);
     {Ssoubor := 'C:\Pascal\error.htm';{}
     OpenFile(f,Ssoubor);{}

     {ziskani cesty k vystupnimu souboru}
     writeln('Zadejte cestu k vystupnimu HTML souboru:');{}
     readln(Vsoubor);
     {Vsoubor := 'C:\abcd.tex';{}
     OpenVFile(g,Vsoubor);{}

     {Nektere stranky chybne pouzivaji misto uvozovek apostrofy}
     writeln('Zadejte format uvozovek:');
     writeln('   34 pro znak ',chr(34));
     writeln('   39 pro znak ',chr(39));{}
     readln(UVOZ);{}

     {snilovani ukazatelu}
     ground := NIL;
     parent := NIL;
     prev := NIL;
     eolf := NIL;
			
     {spusteni hlavni procedury pro vytvoreni stromu}
     ParseHTML(f);{}

     {uzavreni vstupniho souboru}
     close(f);


     {FetchTreeItem(ground,0);{}

     {vypis stromu do Texy!}
     TranslateTree(ground,0);{}

     {Uvolneni pameti}
     DisposeTree(ground);{}

     {uzavreni vystupniho souboru}
     close(g);

end.