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