program gomoku(input,output); {$debug-}
type
  cell = record image: char; color: byte; end;
  block = record leftc: char; lefta: byte; rightc: char; righta: byte; end;
  possibilities = array[0..2] of block;
  dtype = array[1..4] of integer;
  ctype = array[1..7] of integer;
const
  normal = 7; inverse = 112;
  empty = block('ù',normal,' ',normal);
  player = block('O',normal,' ',normal);
  machine = block('X',normal,' ',normal);
  upperleft = block('É',normal,'Í',normal);
  lowerleft = block('È',normal,'Í',normal);
  upperright = block('»',normal,' ',normal);
  lowerright = block('¼',normal,' ',normal);
  horizontal = block('Í',normal,'Í',normal);
  vertical = block('º',normal,' ',normal);
  figure = possibilities(empty,player,machine);
  idir = dtype( 1,1,1,0);
  jdir = dtype(-1,0,1,1);
  ccc = ctype(36,64,100,81,112,121,169);
  replay = '-'; quit = chr(27);
var
  screen: ads of array[0..24,0..39] of block;
  ooo,xxx,ppp: array[1..20,1..20] of integer;
  move_count: integer;
  inchar: word;
  i,j: integer;
  ch: char;

procedure cursor(w:word); external;
procedure locate(w:word); external;
procedure scroll(a,b:word;c:integer); external;
function inkey: word; external;
function random(n:integer): integer; external;

procedure print_help(var ch: word);
  var i: integer;
begin
  locate(byword( 0,45)); write('The object  of the game of  GOMOKU');
  locate(byword( 1,45)); write('is to place five  of your marks in');
  locate(byword( 2,45)); write('a row (your mark will be "O").  At');
  locate(byword( 3,45)); write('the same time, I will be trying to');
  locate(byword( 4,45)); write('five of my marks in a row (my mark');
  locate(byword( 5,45)); write('will be "X").  You make  your move');
  locate(byword( 6,45)); write('by positioning the cursor with the');
  locate(byword( 7,45)); write('numeric  keypad on the  right, and');
  locate(byword( 8,45)); write('then pressing ENTER.  We will take');
  locate(byword( 9,45)); write('turns making moves until one of us');
  locate(byword(10,45)); write('wins or neither of us can move.');
  locate(byword(12,45)); write('It may seem at  first that I can''t');
  locate(byword(13,45)); write('be beaten, but with  practice, and');
  locate(byword(14,45)); write('if you  are very  careful, you can');
  locate(byword(15,45)); write('win most of the time.');
  locate(byword(17,45)); write('To restart the game, press the DEL');
  locate(byword(18,45)); write('key.  To redraw  the board,  press');
  locate(byword(19,45)); write('the INS key.  And to stop the game');
  locate(byword(20,45)); write('press the ESC key.');
  locate(byword(22,45)); write('Press any key to continue:  ');
  repeat ch:=inkey until ch=0; cursor(byword(12,13));
  while ch=0 do ch:=inkey;     cursor(byword(15,0));
end;

procedure board;
  var i,j: integer;
begin
  scroll(byword(0,43),byword(24,79),25); scroll(byword(22,0),byword(24,79),25);
  screen^[0,0]:=upperleft;
  for j:=1 to 20 do screen^[0,j]:=horizontal;
  screen^[0,21]:=upperright;
  for i:=1 to 20 do begin
    screen^[i,0]:=vertical;
    for j:=1 to 20 do screen^[i,j]:=figure[ppp[i,j]];
    screen^[i,21]:=vertical;
  end;
  screen^[21,0]:=lowerleft;
  for j:=1 to 20 do screen^[21,j]:=horizontal;
  screen^[21,21]:=lowerright;
end;

procedure moveto(p,i,j: integer);
begin
  move_count:=move_count+1; ppp[i,j]:=p;
  locate(byword(i,2*j)); screen^[i,j]:=figure[p];
end;

procedure position(var i,j: integer; var c: char);
  var inchar: word; i_first,j_first: integer; msg: boolean;
begin
  i_first:=i; j_first:=j; c:=chr(0); msg:=false; cursor(byword(1,13));
  while c=chr(0) do begin
    locate(byword(i,2*j)); repeat inchar:=inkey until inchar<>0;
    if msg then begin scroll(byword(0,43),byword(24,79),25); msg:=false; end;
    case hibyte(inchar) of
      01: begin { ESC } c:=quit; end;
      28: begin { RETURN } { move }
        if ppp[i,j]=0 then c:=chr(13) else begin
          locate(byword(10,45)); write('Position occupied.'); msg:=true;
        end;
      end;
      71: begin { Home,  7 } if i>1 then i:=i-1; if j>1 then j:=j-1; end;
      72: begin { Up,    8 } if i>1 then i:=i-1; end;
      73: begin { PgUp,  9 } if i>1 then i:=i-1; if j<20 then j:=j+1; end;
      75: begin { Left,  4 } if j>1 then j:=j-1; end;
      76, 82: begin { Ins, 5 } i:=i_first; j:=j_first; board; end;
      77: begin { Right, 6 } if j<20 then j:=j+1; end;
      79: begin { End,   1 } if i<20 then i:=i+1; if j>1 then j:=j-1; end;
      80: begin { Down,  2 } if i<20 then i:=i+1; end;
      81: begin { PgDn,  3 } if i<20 then i:=i+1; if j<20 then j:=j+1; end;
      83: begin { Del } c:=replay; end;
      otherwise;
    end;
  end;
  cursor(byword(15,0));
end;

procedure find_winner(i,j: integer);
  var a,b,k,m,n,p: integer;  save: array[1..5] of word;
begin
  p:=ppp[i,j];
  for n:=1 to 4 do begin
    k:=0;
    for m:=-4 to 4 do begin
      a:=i+m*idir[n]; b:=j+m*jdir[n];
      if a>=1 and then a<=20 and then b>=1 and then b<=20 then begin
        if ppp[a,b]=p then begin
          k:=k+1; save[k]:=byword(wrd(a),wrd(b));
          if k>=5 then begin
            for k:=1 to 5 do
             screen^[ord(hibyte(save[k])),ord(lobyte(save[k]))].lefta:=inverse;
            locate(byword(8,45));
            if p=1 then write('You') else write('I');
            write(' win after ',move_count:0,' moves.');
            return;
          end;
        end
        else k:=0;
      end;
    end;
  end;
end;

procedure find_moves(var a,b: integer);
  var i,j,k,m,n,o,r,v,x: integer;  accepted: boolean;
      x_best,o_best,save: array[1..20] of word;
begin
  m:=0; o:=0;
  for i:=1 to 20 do begin
    for j:=1 to 20 do begin
      v:=ooo[i,j];
      if v>=o then begin
        if v>o then m:=1 else if m<20 then m:=m+1;
        o_best[m]:=byword(wrd(i),wrd(j)); o:=v;
      end;
    end;
  end;
  accepted:=false;
  repeat
    n:=0; x:=0;
    for i:=1 to 20 do begin
      for j:=1 to 20 do begin
        v:=xxx[i,j];
        if v>=x then begin
          if v>x then n:=1 else if n<20 then n:=n+1;
          x_best[n]:=byword(wrd(i),wrd(j)); x:=v;
        end;
      end;
    end;
    if x=112 and then random(2)=1
    then xxx[ord(hibyte(x_best[1])),ord(lobyte(x_best[1]))]:=82
    else accepted:=true;
  until accepted;
  r:=0; v:=0;
  if x>=o or else o<200 and then x>0 and then random(2)=1 then begin
    if o<=25 then begin
      save:=x_best; r:=n;
    end
    else begin
      for k:=1 to n do begin
        o:=ooo[ord(hibyte(x_best[k])),ord(lobyte(x_best[k]))];
        if o>=v then begin
          if o>v then r:=1 else r:=r+1;
          save[r]:=x_best[k]; v:=o;
        end;
      end;
    end;
  end
  else begin
    for k:=1 to m do begin
      x:=xxx[ord(hibyte(o_best[k])),ord(lobyte(o_best[k]))];
      if x>=v then begin
        if x>v then r:=1 else r:=r+1;
        save[r]:=o_best[k]; v:=x;
      end;
    end;
  end;
  r:=random(r); a:=ord(hibyte(save[r])); b:=ord(lobyte(save[r]));
end;

function scan4(p,i,j: integer): integer;
  var a,b,d,k,m,n,o,r,s,sgn,t,v,x: integer;
      vvv: array[1..4] of integer;
      ttt: array[1..2] of integer;
begin
  for d:=1 to 4 do begin
    r:=0; s:=0; t:=0; v:=0; sgn:=1;
    for n:=1 to 2 do begin
      sgn:=-sgn; m:=5;
      for k:=1 to 4 do begin
        a:=i+sgn*k*idir[d]; b:=j+sgn*k*jdir[d]; x:=ppp[a,b];
        if a<1 or else a>20 or else b<1 or else b>20 or else x=(3-p) then begin
          if m=5 then t:=2 else if m=3 and then o=p then r:=1;
          break;
        end;
        if x=p then v:=v+m else m:=(m+1) div 2;
        o:=x; s:=s+1;
      end;
    end;
    if s<4 then v:=0 else v:=v*v;
    if v<400 then if t=2 then v:=v div 2 else v:=v-r;
    vvv[d]:=v;
  end;
  m:=1;
  for n:=1 to 2 do begin
    for d:=1 to 4 do if vvv[d]>vvv[m] then m:=d;
    v:=vvv[m]; vvv[m]:=0;
    if v>=400 then v:=v+v;
    if v>=255 then v:=(v+v)*p;
    ttt[n]:=v;
  end;
  scan4:=ttt[1]+ttt[2];
  for n:=1 to 7 do begin
    for m:=1 to 7 do begin
      if ttt[1]=ccc[n] and then ttt[2]=ccc[m] then begin
        if m>3 or else n>3 then scan4:=400*p else scan4:=200;
        return;
      end;
    end;
  end;
end;

procedure set_values(i,j: integer);
  var a,b,sgn,v,w,x,y,z: integer;
begin
  ooo[i,j]:=0; xxx[i,j]:=0; sgn:=1;
  for w:=1 to 4 do begin
    for x:=1 to 2 do begin
      for y:=1 to 2 do begin
        sgn:=-sgn;
        for z:=1 to 4 do begin
          a:=i+sgn*z*idir[w]; b:=j+sgn*z*jdir[w];
          if a<1 or else a>20 or else b<1 or else b>20 then break;
          if ppp[a,b]=0 then begin
            if x=1 then ooo[a,b]:=scan4(x,a,b) else xxx[a,b]:=scan4(x,a,b);
          end
          else if x<>ppp[a,b] then break;
        end;
      end;
    end;
  end;
end;

begin
  screen.s:=#b000; screen.r:=0;
  cursor(byword(15,0)); board; locate(byword(10,45));
  write('Do you wish to see the rules? '); cursor(byword(12,13));
  repeat inchar:=inkey until inchar<>0; cursor(byword(15,0));
  if hibyte(inchar)=21 { Y } then print_help(inchar);
  if hibyte(inchar)<>1 { ESC } then inchar:=byword(21,0);
  while hibyte(inchar)=21 do begin { for each game }
    fillc(adr xxx,sizeof(xxx),chr(0));
    fillc(adr ooo,sizeof(ooo),chr(0));
    fillc(adr ppp,sizeof(ppp),chr(0));
    move_count:=0; board; locate(byword(10,45));
    write('Shall I move first? '); cursor(byword(12,13));
    repeat inchar:=inkey until inchar<>0; cursor(byword(15,0));
    scroll(byword(0,43),byword(24,79),25);
    if hibyte(inchar)=1 { ESC } then ch:=quit
    else if hibyte(inchar)=21 { Y } then begin
      i:=random(10)+5; j:=random(10)+5;
      moveto(2,i,j);
      set_values(i,j);
    end
    else begin i:=10; j:=10; end;
    while ch<>replay and then ch<>quit and then move_count<400 do begin
      position(i,j,ch);
      if ch=chr(13) then begin
        moveto(1,i,j);
        if ooo[i,j]>=1600 then begin
          find_winner(i,j); ch:=replay;
        end
        else if move_count<400 then begin
          set_values(i,j);
          find_moves(i,j);
          moveto(2,i,j);
          if xxx[i,j]>=3200 then begin
            find_winner(i,j); ch:=replay;
          end
          else set_values(i,j);
        end;
      end;
    end;
    if ch=replay then begin
      while inkey<>0 do;
      locate(byword(10,45)); write('Again? '); cursor(byword(12,13));
      repeat inchar:=inkey until inchar<>0; cursor(byword(15,0));
      ch:=' ';
    end
    else inchar:=0;
  end;
  locate(byword(22,0)); cursor(byword(12,13));
end.