Umiestnenie súboru www.TrSek.com/pas/rutiny.pas

{ 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;

Copyrigth by Zdeno Sekerak 2007, http://www.trsek.com