Program rieši tajničku osemsmerovky

{ RUTINY.PAS                Copyright (c) TrSek alias Zdeno Sekerak }
{ Rutiny k 8smer.pas.                                               }
{                                                                   }
{ Datum:28.05.1996                             http://www.trsek.com }
 
{ vycisti vsetky tabulky }
procedure default;
begin
 
 for x:=1 to MAX do
  for y:=1 to MAX do
   PTaj[x,y] := SPACE;
 
 for x:=1 to MAX do
  for y:=1 to MAX do
    OKRieT[x,y] := true;
 
 for x:=1 to PocSlov do
  begin
   Slov[x] := '';
   OKSlov[x] := true;
  end;
 
end;
 
 
{ Obhod komentar }
procedure Readlnf(var f:text;var ria:string );
begin
 Repeat
  Readln( f, ria );
 Until (( ria[1] <> ';' ) or eof(f));
end;
 
 
{ Nacita subor, ak nieco nieje OK vrati false }
function citaj_subor( Subor:string ):boolean;
var i:integer;
    f : text;                  { nacitany subor }
    ria : string;              { precitany riadok }
begin
 
 default;
 px:=0;py:=0;
 
 Assign( f, Subor );
 {$I-}
 Reset( f );
 {$I+}
 if( IOResult<>0 ) then
     begin citaj_subor := false; exit; end;
 
 Readlnf( f, ria );
 { Najprv kolko znakov ma vysledok }
 Repeat
  Val( ria, pp, i );
  if(i <> 0) then delete( ria, i, 1);
 Until ( i = 0 );
 
 
 Readlnf( f, ria );
 { Nacitaj znaky tajnicky }
 Repeat
 
  Inc( py );            { dalsi riadok }
  for i:=1 to length(ria) do
    ria[i] := UpCase(ria[i]);
 
  i := 0;
 
  while( length(ria) > 0 ) do
   begin
 
    if( ria[1] = SPACE ) then
      delete(ria,1,1)
    else
    begin
      inc(i);
      PTaj[i,py] := copy( ria,1,2 );
      delete(ria,1,2);
 
      if( PTaj[i,py][2] = SPACE )then
          delete( PTaj[i,py], 2, 1 );
    end;
 
   end;
 
  if( i>px )then px:=i;
 
  { Dalsi riadok }
  Readln( f, ria );
 
 Until(( ria[1] = ';' ) or eof(f));
 
 
 { Nacitavaj slova ktore treba hladat }
 ps:=1;
 Repeat
 
  Readlnf( f, ria );
 
  for i := 1 to Length( ria ) do
 
   if( ria[i] = ',' )then
    begin
     if( ps < PocSlov ) then Inc(ps);
    end
   else
    Slov[ ps ] := Slov[ ps ] + UpCase( ria[i] );
 
 Until( eof(f));
 Close( f );
 
 if( px=0 ) or ( py = 0 ) or ( ps = 0 ) then
     citaj_subor := false
 else
     citaj_subor := true;
 { skoncili sme tu uz niet co najst }
end;
 
 
 
{ Vykresli celu tajnicku na posledny riadok na obrazovke }
function disp( od:integer ):integer;
var i,x,y : integer;          { max pokial vypisovat }
    celkom:string;
begin
 
 i:=0;
 celkom:='';
 farba( ColB, ColP );
 
 for y:=1 to py do
  for x:=1 to px do
   begin
 
    if( OKRieT[x,y] )then inc(i);
 
    if( OKRiet[x,y] and ( i>=od ) and ( i<72 ))then
      celkom := celkom + PTaj[x,y];
 
   end;
 
 { este zmazeme do konca }
 for x:=length(celkom) to 70 do
   celkom := celkom + SPACE;
 
 gotoxy( 2, MAXY+1 );
 write('(',i:4,')=',celkom);
 
 disp := i;
 
end;
 
 
 
{ Vypise na obrazovku znak, rychlejsie ako write xy mejbi :-() }
procedure W_CXY( x,y,ix,iy:integer; znak:string );
var pom,pom1,pom2:word;
begin
 
 ix := ix+x;
 iy := iy+y;
 
 if( ix >= 1 ) and ( ix <= MAXX ) and
   ( iy >= 1 ) and ( iy <= MAXY ) then
   begin
{
    obr^.znak[iy,2*ix] := 7936 + ord(znak);
 
    if( znak='Ä' ) or ( znak='Ú' ) or ( znak='Ŕ' )then
      obr^.znak[iy,2*ix+1] := 7936 + ord('Ä')
    else
      obr^.znak[iy,2*ix+1] := 7968;
 
}
    znak := znak + SPACE;
    gotoxy(2*ix,iy);
    write( znak[1], znak[2] );
 
   end;
 
end;
 
 
 
{ ukaze tabulku v dannom vyreze }
procedure VisTab( x,y:integer );
var ix,iy:integer;
    xmax,ymax:integer;
begin
 
 for ix:=1 to px do
  begin
 
   { ramcek linka hore, dole, na zmazanie }
   TextColor(ColP);
   W_CXY( x, y, ix+1,    0, '  ' );
   W_CXY( x, y, ix+1,    1, 'ÄÄ' );
   W_CXY( x, y, ix+1, py+2, 'ÄÄ' );
   W_CXY( x, y, ix+1, py+3, '  ' );
 
   for iy:=1 to py do
    begin
     if( OKRieT[ix,iy] ) then farba(ColB,ColP)
                         else farba(ColB,ColPI);
 
     W_CXY( x, y, ix+1, iy+1, PTaj[ix,iy] );
    end;
 
  end;
 
 TextColor(ColP);
 
 for iy:=0 to py+1 do
  begin
   { ramcek linka vlavo, vpravo }
   W_CXY( x, y,    0, iy+1, '  ' );
   W_CXY( x, y,    1, iy+1, 'ł ' );
   W_CXY( x, y, px+2, iy+1, 'ł ' );
   W_CXY( x, y, px+3, iy+1, '  ' );
  end;
 
 { styri rohy }
 W_CXY( x, y,    1,    0, '  ' );
 W_CXY( x, y,    1,    1, 'ÚÄ' );
 
 W_CXY( x, y,    1, py+3, '  ' );
 W_CXY( x, y,    1, py+2, 'ŔÄ' );
 
 W_CXY( x, y, px+2,    0, '  ' );
 W_CXY( x, y, px+2,    1, 'ż ' );
 
 W_CXY( x, y, px+2, py+3, '  ' );
 W_CXY( x, y, px+2, py+2, 'Ů ' );
 
 KurzorZap(false);
 
end;
 
 
 
{ vpravo zobrazi vsetky slova }
procedure VisSlova(y,yz:integer);
var iy:integer;
    xl:integer; { kde vlavo ma byt }
    slovo:string;
begin
 
 xl := 2*MAXX+3;
 
 for iy:=y to MAXY+y-1 do
  if( iy >= 1 ) and ( iy <= PocSlov )then
   begin
 
    if( iy-y=yz ) then farba( ColBI, -1 )
                  else farba( ColB, -1 );
 
    if( OKSlov[iy] ) then farba( -1, ColP )
                     else farba( -1, ColPI );
 
    slovo := Copy( Slov[iy], 1, 80 - xl );
    while( length(slovo) < (80-xl)) do
      slovo := slovo + SPACE;
 
    gotoxy( xl, iy-y+1 );
    write(slovo);
   end;
 
end;
 
 
 
{ najde zaciatocny znak }
procedure FindStart( var x,y:integer; slovo:string );
begin
 
 repeat
  inc(x);
  if( x>px )then inc(y);
  if( x>px )then x:=1;
  if( y>py )then y:=0;
 until(( y=0 ) or ( PTaj[x,y][1] = slovo[1] ));
 
end;
 
 
 
{ najde dalsi znak pre smer ktory mu urcim }
function NextSmer( var xr,yr,sm:integer ):string;
begin
 
 case sm of
 
  1: inc(xr);   { vpravo }
  2: inc(yr);   { dole   }
  3: dec(xr);   { vlavo  }
  4: dec(yr);   { hore   }
 
  5: begin inc(xr); dec(yr); end;  { vpravo - hore }
  6: begin inc(xr); inc(yr); end;  { vpravo - dole }
  7: begin dec(xr); inc(yr); end;  { vlavo  - dole }
  8: begin dec(xr); dec(yr); end;  { vlavo  - hore }
 
 end;
 
 if(( xr<1 ) or ( yr<1 ) or ( xr>px ) or ( yr>py ))then
   NextSmer := SPACE
  else
   NextSmer := PTaj[xr,yr];
 
end;
 
 
 
{ samotne hladanie riesenia }
procedure Hladaj(var x,y,sm:integer; slovo:string);
var dl:integer;
    xr,yr:integer;
    hslovo:string;
    znak:string;
begin
 
 { aku dlzku potrebujeme }
 dl := length( slovo );
 x:=0; y:=1;
 FindStart( x,y, slovo );
 if( y=0 )then y:=1;
 
 repeat
 
  sm:=0;
  { vsetkych osem smerov }
  repeat
 
   hslovo := PTaj[x,y];
   xr:=x; yr:=y; sm:=sm+1;
 
   { je riesenie v danom smere }
   repeat
 
    znak := NextSmer( xr,yr,sm );
    hslovo := hslovo + znak;
 
   until(( length( hslovo ) >= dl ) or ( slovo=hslovo ) or ( znak=SPACE ));
 
  { bud nasiel alebo niet co hladat }
  until(( slovo=hslovo ) or ( sm=8 ));
 
  { tak najdi dalsie zaciatocne pismenko }
  if( slovo<>hslovo )then
     FindStart( x,y, slovo );
 
 { nasiel alebo niet co hladat slovo nenajdene a to je problem }
 until(( slovo=hslovo ) or ( y=0 ));
 
end;
 
 
 
{ vyznaci riesenie }
procedure OznacNajdene(xt,yt,sm,ys:integer);
var hslovo:string;
begin
 
 { oznacime ze slovo je najdene }
 OKSlov[ys] := false;
 hslovo := PTaj[xt,yt];
 
 W_CXY( x, y, xt+1, yt+1, PTaj[xt,yt] );
 OKRieT[xt,yt] := false;
 
 { a teraz vyskrtame pismenka }
 repeat
 
  hslovo := hslovo + NextSmer( xt,yt,sm );
  W_CXY( x, y, xt+1, yt+1, PTaj[xt,yt] );
  OKRieT[xt,yt] := false;
 
 until(( Slov[ys] = hslovo ) or ( length(Slov[ys]) < length(hslovo)));
 
end;
 
 
 
{ ako bude vyzerat obrazovka }
procedure obrazovka;
var i:integer;
begin
 
 farba(Magenta,ColP);
 clrscr;
 
 farba(ColB,-1);
 window(2,1,MAXX*2+1,MAXY);
 clrscr;
 
 window(1,1,80,MAXY+3);
 gotoxy(2,MAXY+3); write('ESC-End F1-Help F2-Save F3-Load F5-Solve TAB-Next Enter-Edit Software by TrSek');
end;
 
 
{ ukaze pomoc, ak to niekomu pomoze }
procedure Help;
begin
 window(11,3,71,19);
 farba(ColBI,ColP);
 clrscr;
  writeln;
  writeln('  Program na risenie osemsmerovky');
  writeln;
  writeln('        F1 - Tento help');
  writeln('        F2 - Nahraje tajnicku do suboru');
  writeln('        F3 - Vyberie tajnicku zo suboru');
  writeln('        F5 - Zacne riesit osemsmerovku');
  writeln('       TAB - Presuva sa medzi zoznamom slov a tajnickou');
  writeln('    F4,INS - Hlada riesenie pre slovo na ktorom je kurzor');
  writeln('       ESC - Ukoncenie prace s produktom');
  writeln('     sipky - pohyb po zozname slov, alebo pohyb tajnickou');
  writeln;
  writeln('  Pri svojom spusteni sa snazi nacitat subor tajnicka.dat');
  writeln;
  writeln('                                        Software by TRSEK');
  writeln('                                 http://www.trsek.host.sk');
 repeat until (readkey in [#27,#13]);
 
 window(1,1,80,Hi(WindMax)+1);
end;
 
procedure Save;
begin
end;
 
procedure Load;
begin
end;