program dama;
uses crt;
const
 MoveMax=511; { максимален брой ходове в играта }
 MMax=1000; { максимален брой ходове в една позиция }
 FMax=24; { брой полета }
 DMax=16; { брой дами }
type 
 TDama=array[1..3] of byte;
 TField=record 
  FN: string[2]; { нотация }
  X,Y:byte; { координати върху дъската }
  Nct:byte; { брой съседи }
  Nb:array[1..4] of byte; { съседи }
  Dct:byte;
  D:array[1..2] of byte; { дами в които участва полето }
 end;
 TMove=record { ход }
  m:word; { номер на ход }
  a,b,c:byte; 
  { a-поле от което вземаме пул, 
    b-поле на което слагаме пула, 
    c-противников пул, който махаме }
 end;
 TPos=record { позиция }
  mnum:word; { номер на ход }
  player:byte; { играч на ход }
  mv:TMove; { ход, който е игран в тази позиция, служи само при рисуването }
  d:array[1..FMax] of byte; { дъска: 0-няма пул, 1-пул на първи играч, 2-пул на втори играч }
 end;
 TMArr=array[1..MMax] of TMove;

var
 FArr:array[1..FMax] of TField;
 DArr:array[1..DMax] of TDama;
 cmnum:word; { текуш ход }
 PStack:array[0..MoveMax] of TPos;
 winer:byte;

procedure Init;
 var
  C:array[-1..1,-1..1,-1..1] of byte;
  x,y,z:integer;
  vcnt,v,dcnt:byte;
 procedure G(i,j:byte);
  begin
   with FArr[i] do begin inc(Nct); Nb[Nct]:=j end; 
   with FArr[j] do begin inc(Nct); Nb[Nct]:=i end; 
  end;
 procedure Dama(i,j,k:byte);
  begin
   inc(dcnt);
   DArr[dcnt,1]:=i; DArr[dcnt,2]:=j; DArr[dcnt,3]:=k;
   with FArr[i] do begin inc(Dct); D[Dct]:=dcnt end;
   with FArr[j] do begin inc(Dct); D[Dct]:=dcnt end;
   with FArr[k] do begin inc(Dct); D[Dct]:=dcnt end;
  end;
 begin
  vcnt:=0; dcnt:=0;
  for x:=-1 to 1 do for y:=-1 to 1 do for z:=-1 to 1 do 
  if (x=0) and (y=0)
   then C[x,y,z]:=0
   else begin
    inc(vcnt);
    C[x,y,z]:=vcnt;
    FArr[vcnt].X:=4+x+x+x*z;
    FArr[vcnt].Y:=4+y+y+y*z;
    with FArr[vcnt] do begin 
     Nct:=0; Dct:=0;
     FN:=chr(ord('A')+X-1)+chr(ord('0')+Y);
     { writeln(FN,' ',x,' ',y); }
    end;
   end;
  for x:=-1 to 1 do for y:=-1 to 1 do for z:=-1 to 1 do 
  if (x*y=0) and (x<>y) then begin
   v:=C[x,y,z];
   if x=0 then begin
    G(v,C[1,y,z]); G(v,C[-1,y,z]);
    Dama(C[-1,y,z],v,C[1,y,z]);
   end; 
   if y=0 then begin
    G(v,C[x,1,z]); G(v,C[x,-1,z]);
    Dama(C[x,-1,z],v,C[x,1,z]);
   end; 
   if z=0 then begin
    G(v,C[x,y,1]); G(v,C[x,y,-1]);
    Dama(C[x,y,-1],v,C[x,y,1]);
   end;
  end;
   
  cmnum:=0;
  with PStack[cmnum] do begin
   mnum:=cmnum;
   player:=1;
   for v:=1 to FMax do d[v]:=0;
  end;
 end;

function Blank(n:byte):string;
 var i:byte; s:string;
 begin s:=''; for i:=1 to n do s:=s+' '; Blank:=s end;

function PullCh(p:byte):char;
 begin case p of
   0:PullCh:=' ';
   1:PullCh:='o';
   2:PullCh:='x';
 end end;

procedure WriteFld(i:byte; w:char);
 begin
   gotoxy(1+4*FArr[i].X,17-2*FArr[i].Y);
   write(w);
 end;

procedure FlashPul(i,player:byte; b:boolean);
 var w1,w2:char;
 begin
  if b 
   then begin w1:=PullCh(player); w2:=PullCh(0) end
   else begin w1:=PullCh(0); w2:=PullCh(player) end;
  WriteFld(i,w1); Delay(300); 
  WriteFld(i,w2); Delay(300); 
  WriteFld(i,w1); Delay(300); 
  WriteFld(i,w2); Delay(300); 
  WriteFld(i,w1);  
 end;

procedure WritePos;
 var i:byte;
 begin
  for i:=1 to FMax do WriteFld(i,PullCh(PStack[cmnum].d[i]));
 end;

procedure IScreen;
 begin
  clrscr;
  gotoxy(1,1); writeln('    Koram game by (c) Skelet');
  gotoxy(1,3);
  writeln('7  [ ]---------[ ]---------[ ]');
  writeln('    |           |           | ');
  writeln('6   |  [ ]-----[ ]-----[ ]  | ');
  writeln('    |   |       |       |   | ');
  writeln('5   |   |  [ ]-[ ]-[ ]  |   | ');
  writeln('    |   |   |       |   |   | ');
  writeln('4  [ ]-[ ]-[ ]     [ ]-[ ]-[ ]'); 
  writeln('    |   |   |       |   |   | ');
  writeln('3   |   |  [ ]-[ ]-[ ]  |   | ');
  writeln('    |   |       |       |   | ');
  writeln('2   |  [ ]-----[ ]-----[ ]  | ');
  writeln('    |           |           | ');
  writeln('1  [ ]---------[ ]---------[ ]');
  writeln;
  writeln('    A   B   C   D   E   F   G ');
  WritePos;
  gotoxy(1,20);
 end;

function EvalNotF(s:string):byte;
 var i:byte;
 begin
  EvalNotF:=0;
  if length(s)=2 then begin
   if s[1] in ['a'..'g'] then s[1]:=chr(ord(s[1])-ord('a')+ord('A'));
   if (s[1] in ['A'..'G']) and (s[2] in ['1'..'7']) 
    then for i:=1 to FMax do if s=FArr[i].FN then EvalNotF:=i;
  end;
 end;

procedure ReadMove(var ms:string; var m:TMove);
 var s1,s2,s3,ws:string;
 begin
  if pos('-',ms)=3 
   then begin s1:=copy(ms,1,2); ws:=ms; delete(ws,1,3); end 
   else begin s1:=''; ws:=ms end;
  s2:=copy(ws,1,2); 
  if pos(':',ws)=3
   then begin s3:=ws; delete(s3,1,3); end
   else begin s3:='' end;
  m.a:=EvalNotF(s1); 
  m.b:=EvalNotF(s2); 
  m.c:=EvalNotF(s3);
  {
  gotoxy(1,20);
  writeln(s1,'-',s2,':',s3,' -> ',m.a,'-',m.b,':',m.c,'   '); 
  } 
 end;

function MoveNot(var mv:TMove):string;
 var i:byte; s:string;
 begin
  if mv.a=0
   then s:=''
   else s:=FArr[mv.a].FN+'-';
  s:=s+FArr[mv.b].FN;
  if mv.c>0 
   then s:=s+':'+FArr[mv.c].FN;
  for i:=1 to length(s) do if (s[i] in ['A'..'G'])
   then s[i]:=chr(ord('a')+ord(s[i])-ord('A'));
  while length(s)<8 do s:=s+' ';
  MoveNot:=s;
 end;

procedure GenAllMoves(mnum:word; var mcnt:word; var MArr:TMArr);
 var i,k,l,player,mypools:byte; wm:TMove;
 function TestDama(i,player:byte):boolean;
  function TestD(var Dama:TDama):boolean;
   var j:byte; B:boolean;
   begin
    B:=true;
    for j:=1 to 3 do B:=B and (PStack[mnum].d[Dama[j]]=player);
    TestD:=B;
   end;
  begin
   TestDama:=TestD(DArr[FArr[i].D[1]]) or TestD(DArr[FArr[i].D[2]]);
  end;
 procedure AddMoves;
  var j:byte;
  begin
   if PStack[mnum].d[i]=0 then begin { празно ли е полето където ще слагаме пул ? }
    if k>0 then PStack[mnum].d[k]:=0; { махаме пулчето временно }
    PStack[mnum].d[i]:=player; { слагаме пулчето временно }
    with wm do begin m:=mnum+1; a:=k; b:=i; c:=0; end;
    if TestDama(i,player)
     then begin
      for j:=1 to FMax do if PStack[mnum].d[j]=3-player 
       then if not TestDama(j,3-player) 
        then begin inc(mcnt); wm.c:=j; MArr[mcnt]:=wm; end
     end 
     else begin inc(mcnt); MArr[mcnt]:=wm; end;
    PStack[mnum].d[i]:=0; { махаме пулчето }
    if k>0 then PStack[mnum].d[k]:=player; { връщаме пулчето }
   end; 
  end;
 begin
  mcnt:=0;
  player:=PStack[mnum].player;
  if mnum<18 
   then begin
    k:=0;
    for i:=1 to FMax do AddMoves;
   end
   else begin
    mypools:=0;
    for k:=1 to FMax do if PStack[mnum].d[k]=player then inc(mypools);
    if mypools>3 
     then begin
      for k:=1 to FMax do if PStack[mnum].d[k]=player 
       then for l:=1 to FArr[k].Nct do begin
        i:=FArr[k].Nb[l];
	AddMoves;
       end;
     end 
     else begin
      for k:=1 to FMax do if PStack[mnum].d[k]=player
       then for i:=1 to FMax do AddMoves;
     end;
   end;
 end;

function TestMove(wm:TMove; var mcnt:word; var MArr:TMArr):boolean;
 var i:word;
 begin
  TestMove:=false;
  if mcnt>0 then for i:=1 to mcnt do with MArr[i] do 
   if (a=wm.a) and (b=wm.b) and (c=wm.c) and (m=wm.m) then TestMove:=true;
 end;

procedure MakeMove(wm:Tmove; draw:boolean);
 begin
  PStack[wm.m]:=PStack[wm.m-1];
  PStack[wm.m-1].mv:=wm;
  with PStack[wm.m] do begin
   inc(mnum);
   if wm.a>0 then begin 
    d[wm.a]:=0;
    if draw then FlashPul(wm.a,player,false)
   end; 
   d[wm.b]:=player;
   if draw then FlashPul(wm.b,player,true);
   if wm.c>0 then begin 
    d[wm.c]:=0;
    if draw then FlashPul(wm.c,3-player,false)
   end; 
   player:=3-player;
  end;
 end;

procedure Error(s:string);
 var w:char;
 begin
  gotoxy(1,22); write(s); w:=ReadKey; w:=w;
  gotoxy(1,22); write(Blank(70));
 end;

function EndGame(mnum:word;var winer:byte; draw:boolean):boolean;
 var 
  eg,b:boolean;
  MArr:TMArr;
  mcnt,l:word;
  player:byte;
  i,n,pct:byte;
  p:array[1..100] of word;
 begin
  eg:=false;
  player:=PStack[mnum].player;
  GenAllMoves(mnum,mcnt,MArr);
  if mcnt=0 then begin { играча няма възможни ходове }
   winer:=3-player;
   eg:=true;
   if draw then begin
    gotoxy(1,20);
    write('Player ',player,' can''t move anywhere !')
   end;
  end;
  if (not eg) then begin
   n:=0; 
   for i:=1 to FMax do if PStack[mnum].d[i]=player then inc(n);
   if (n<3) and (mnum>18) then begin { след дебюта играча има под 3 пула }
    winer:=3-player;
    eg:=true;
    if draw then begin
     gotoxy(1,20);
     write('Player ',player,' lost too many pools !')
    end;
   end;	    
  end;
  if (not eg) and (mnum>0) then begin { проверка за потретване на позиция }
   pct:=0;
   for l:=0 to mnum-1 do if PStack[l].player=player then begin
    b:=true;
    for i:=1 to FMax do if PStack[mnum].d[i]<>PStack[l].d[i] then b:=false;
    if b then begin
     inc(pct);
     p[pct]:=l;
    end; 
   end;
   if pct>1 then begin
    winer:=0;
    eg:=true;
    if draw then begin
     gotoxy(1,20);
     write('Position ',mnum,' same as ',p[1],' and ',p[2],' !')
    end;
   end;
  end;
  EndGame:=eg;
 end;

procedure Play;
 const mvdy=20;
 var 
  ms:string;
  m:TMove;
  MArr:TMArr;
  mcnt:word;
  dy,y:word;
 begin
  repeat
   repeat
    if cmnum>mvdy 
     then begin
      dy:=cmnum-mvdy;
      for y:=1 to mvdy do begin
       gotoxy(50,y);
       write(dy+y:3,'[',PullCh(PStack[dy+y-1].player),']: ');
       write(MoveNot(PStack[dy+y-1].mv),'  ');
      end;
     end 
     else dy:=0;
    gotoxy(50,cmnum-dy+1); write(Blank(20));
    gotoxy(50,cmnum-dy+1); write(cmnum+1:3,'[',PullCh(PStack[cmnum].player),']: ');
    readln(ms);
    if ms='quit' then begin gotoxy(1,22); halt end;
    m.m:=cmnum+1;
    ReadMove(ms,m);
    GenAllMoves(cmnum,mcnt,MArr);
    if not TestMove(m,mcnt,MArr) 
     then Error('Incorrect move, press a key and try again ! ');
   until TestMove(m,mcnt,MArr); 
   MakeMove(m,true);
   inc(cmnum);
  until EndGame(cmnum,winer,true);
  gotoxy(1,21);
  write('Game finished: ');
  case winer of
   0:writeln('no winer');
   1:writeln('player 1 win');
   2:writeln('player 2 win');
  end;
 end;

begin
 Init; 
 IScreen;
 Play;
end.