- RU.ALGORITHMS (2:5030/1334.67) ------------------------------ RU.ALGORITHMS -
 Msg  : 1 из 906
 From : Sergey Buts                         2:4614/9.59     Пон 06 Hоя 00 22:58
 To   : All                                                 Пон 13 Hоя 00 01:32
 Subj : Крестики-нолики
-------------------------------------------------------------------------------
По многочисленным просьбам кидаю исходник прямо в эху.
Кое-какие напутствия:
Управление - на цифровой клавиатуре. Поскольку компьютер всегда выигрывает, то
первым предоставляется ход человеку. В этом случае можно сыграть в ничью. Желаю
удачи :-)


--- Тут начинается файл x0lik.pas ---
{А разработал данную прогу А.Отенко}
uses Crt;
const
   xSize:byte = 39;
   ySize:byte = 20;
   Length1:byte = 5;

var
  i,j,maxx,maxy,curx,cury,quit:byte;
  aS:char;
  fild:array[ 1..40, 1..20] of word;
  fildS:array[ 1..40, 1..20 ] of char;

function fac( x:word ):word;
begin
  if x=0 then fac:=1 else fac:=fac( x-1 )*4 +1
end;

procedure color( tex,back:word );
begin
  TextColor( tex );
  TextBackground( back )
end;

procedure setcurs;
begin
  gotoxy( curx*2, cury )
end;

procedure findempty;
var
   x1,y1:byte;
begin

 maxx:=0;
 for x1:=1 to xSize do
  for y1:=1 to ySize do
  begin
   fild[ x1, y1 ]:=0;
   if fildS[ x1, y1 ]='.' then
   begin
     maxx:=x1;
     maxy:=y1
   end
  end;
 if maxx=0 then quit:=2
end;

procedure buildline( kx,ky:shortint );
var
   kolx,kol0,kolempty,x1,y1,k:byte;
begin
   kolempty:=0;
   kolx:=0;
   kol0:=0;
   for k:=0 to Length1-1 do
   begin
    x1:=i+k*kx;
    y1:=j+k*ky;
    if ( x1>0 ) and ( y1>0 ) and ( x1<=xSize ) and ( y1<=ySize ) then
aS:=fildS[ x1, y1 ]
    else aS:=' ';
    if aS='.' then Inc( kolempty );
    if aS='x' then Inc( kolx );
    if aS='o' then Inc( kol0 )
   end;

   if ( ( kolx=0 ) or ( kol0=0 ) ) and ( kolx+kol0+kolempty=Length1 ) then
   begin
    for k:=0 to Length1-1 do
    begin
      x1:=i+k*kx;
      y1:=j+k*ky;

      fild[ x1, y1 ]:=fild[ x1, y1 ]+fac( kolx+kol0 );
      if ( fild[ x1, y1 ]>fild[ maxx, maxy ] ) and ( fildS[ x1, y1 ]='.' ) then
      begin
        maxx:=x1;
        maxy:=y1
      end;
    end;
    if ( kolx=Length1 ) and ( quit <> 2 ) then quit:=1;
    if ( kol0=Length1 ) then quit:=2;

    if ( kolx+kolempty<Length1 ) and ( kol0+kolempty<Length1 ) and ( quit=0 )
then quit:=3;
    if ( ( kolx+kolempty=Length1 ) or ( kol0+kolempty=Length1 ) ) and ( quit<>1
) and ( quit<>2 ) then quit:=4
  end
end;

procedure ithink;
var
   bS:char;
begin
 repeat
  setcurs;
  color( 0, 7 );
  bS:=fildS[ curx, cury ];
  write( bS );

  aS:=readkey;

  setcurs;
  bS:=fildS[ curx, cury ];
  color( 14, 1 );
  if bS='x' then color( 13, 1 ) else if bS='o' then color( 10, 1 );
  write( bS );

  if aS='s' then
  begin
    quit:=1;
    exit
  end;

  if ( aS='4' ) or ( aS='7' ) or ( aS='1' ) then Dec( curx );
  if ( aS='6' ) or ( aS='9' ) or ( aS='3' ) then Inc( curx );
  if ( aS='8' ) or ( aS='7' ) or ( aS='9' ) then Dec( cury );
  if ( aS='2' ) or ( aS='1' ) or ( aS='3' ) then Inc( cury );

  if cury<1 then cury:=ySize;
  if curx<1 then curx:=xSize;
  if curx>xSize then curx:=1;
  if cury>ySize then cury:=1

 until ( aS=' ' ) and ( fildS[ curx, cury ]='.' );

  fildS[ curx, cury ]:='o';
  gotoxy( curx * 2, cury );
  color( 0, 7 );
  write( 'o' )
end;

{procedure printit;
begin
  for j:=1 to ySize do
  begin
    gotoxy( 40,j );
    for i:=1 to xSize do write( fild[ i, j ],' ' );
    writeln
  end

end;  }

procedure think;
begin
 findempty;
 if quit=0 then
 begin
  for j:=1 to ySize do
   for i:=1 to xSize do
   begin
     buildline( 1, 0 );
     buildline( 1, 1 );
     buildline( 0, 1 );
     buildline( -1, 1 )
   end;
  if quit=4 then quit:=0
 end
{ printit;
  write( #7 )}
end;

procedure msg( ss:string );
const
   ss1:string[12]='           ';
var
   x,y:byte;
begin
   color( 15, 2 );
   y:=abs( ySize div 2 -4 )+1;
   x:=abs( xSize div 2 -6 )+1;
   gotoxy( x, y );
   write( ss1 );
   Inc( y );
   gotoxy( x, y );
   write( ' GAME OVER ' );
   Inc( y );
   gotoxy( x, y );
   write( ss1 );
   Inc( y );
   gotoxy( x, y );
   write( ss );
   Inc( y );
   gotoxy( x, y );
   write( ss1 )
end;

BEGIN
 repeat
  curx:=1;
  cury:=1;
  quit:=0;
  clrscr;

  writeln( 'Will you change Current Setup (', xSize, 'x', ySize, 'x', Length1,
') y/n? ' );
  aS:=readkey;

  if aS='y' then
  begin
    write( 'X Size of field: '); readln( xSize );
    write( 'Y Size of field: '); readln( ySize );
    write( 'Length of line to complete: '); readln( Length1 )
  end;

  writeln( 'Do you want me to start? y/n '); aS:=readkey;

  color( 14, 1 );
  clrscr;
  for i:=1 to xSize do
    for j:=1 to ySize do
    begin
     fildS[ i, j ]:='.';
     gotoxy( i*2, j );
     write( '.' )
    end;

  writeln;
  write ( 'Press "s" to stop' );

  if aS<>'y' then ithink;

  while quit=0 do
  begin

    think;
    if quit = 0 then
    begin
      fildS[ maxx, maxy ]:='x'; { Set my figure }
      gotoxy( 1, 22 );
      write( 'Ok ?' );
      gotoxy( maxx * 2, maxy );
      color( 13+15, 1 );
      write( 'X' );

      aS:=readkey;

      color( 13, 1 );
      gotoxy( maxx*2, maxy );
      write( 'x' );
      gotoxy( 1, 22 );
      write( '    ' );

      findempty;
      if quit=0 then ithink;
    end;

    if quit=1 then msg( ' Happy End ' );
    if ( quit=2 ) or ( quit=3 ) then msg( '  You won  ' )

  end;

  gotoxy( 1, 21 );
  writeln( 'One more! y/n? ' );
  aS:=readkey;
 until aS<>'y'
end.


--- А здесь x0lik.pas кончается ---


                Best regards, Sergey Buts.


 * Origin: mailto:siriy@kaskad.sumy.ua | HomePage: http://siriy.n (2:4614/9.59)