Игра Реверси (FPC)

* Игра написана весьма тупо - из-за множества циклов
* Аналитика на несколько ходов вперед отсутствует
* Играет компьютер с компьютером (это легко изменить)

program reverse;

{ Copyright (C) Igor Salnikov 2015 }

type
    TCell = record
       fig: integer;
       mark: integer;
    end;
    
    TField = array[1..8,1..8] of TCell;
var
    Field:TField;

function FigName(fig:integer):string;
begin
    FigName:='.';
    if fig=1 then FigName:='B'
        else if fig=-1 then FigName:='R';
end;

procedure ResetField;
var i,j: integer;
begin
    { set init position }
    Field[4,4].fig:=1;
    Field[5,4].fig:=-1;
    Field[4,5].fig:=-1;
    Field[5,5].fig:=1;
end;

procedure CopyField;
begin
end;

procedure OnStart();
begin
    //ClearField;
    randomize;
    ResetField;
end;

function sign(x:integer):integer;
begin
    if x=0 then sign:=0
    else if x>0 then sign:=1
    else sign:=-1;
end;

function OnLine(fig,x1,y1,x2,y2:integer):boolean;
var dx,dy,c:integer;
    px, py: integer;
begin
    OnLine:=false;
    if (Field[x1,y1].fig<>fig) or (Field[x2,y2].fig<>fig) then exit;
    dx:=abs(x2-x1); dy:=abs(y2-y1);
    if (dx=0) or (dy=0) or (dx=dy) then
    begin
        dx:=sign(x2-x1);
        dy:=sign(y2-y1);
        px:=x1+dx; py:=y1+dy;
        OnLine:=true; c:=0;
        while not ((px=x2) and (py=y2)) do
        begin
            if Field[px,py].fig<>-fig then
            begin
                OnLine:=false;
                break;
            end;
            px:=px+dx;
            py:=py+dy;
            c:=c+1;
        end;
        if c=0 then OnLine:=false;
    end;
    
end;

function Invert(fig:integer; x,y:integer):integer;
var i, j: integer;
    px, py: integer;
    dx, dy: integer;
begin
    for i:=1 to 8 do
        for j:=1 to 8 do
        if (i<>y) or (j<>x) then
        if OnLine(fig,x,y,j,i) then
        begin
            dx:=sign(j-x);
            dy:=sign(i-y);
            px:=x; py:=y;
            while not ((px=j) and (py=i)) do
            begin
                if Field[px,py].fig=-fig then
                    Field[px,py].mark:=1;
                px:=px+dx;
                py:=py+dy;
            end;
        end;
    for i:=1 to 8 do
        for j:=1 to 8 do
            if Field[j,i].mark=1 then
            begin
                Field[j,i].mark:=0;
                Field[j,i].fig:=fig;
            end;
end;


procedure SetFigure(x,y:integer; fig:integer);
begin
    Field[x,y].fig:=fig;
    Invert(fig,x,y);
end;

function OnField(x,y:integer):boolean;
begin
   if (x>=1) and (x<=8) and (y>=1) and (y<=8) then
       OnField:=true else OnField:=false;
end;

function PosPower(fig:integer; x,y:integer):integer;
var k:integer;
    nx, ny: integer;
    step_x, step_y: integer;
    step_power, power: integer;
begin
    power:=0;
    for step_y:=-1 to 1 do
        for step_x:=-1 to 1 do
        begin
            if (step_x=0) and (step_y=0) then continue;
            step_power:=0;
            nx:=x+step_x; ny:=y+step_y;
            while OnField(nx,ny) do
            begin
                if Field[nx,ny].fig=-fig then inc(step_power);
                if Field[nx,ny].fig=fig then break;
                if Field[nx,ny].fig=0 then
                begin
                   step_power:=0; break;
                end;
                nx:=nx+step_x; ny:=ny+step_y;
            end;
            if not OnField(nx,ny) then step_power:=0;
            power:=power+step_power;
        end;
    PosPower:=power;
end;

procedure GetNewPos(fig: integer; var x,y:integer);
type
    TPara = record
        x,y:integer;
    end;
var i,j,p:integer;
    max_p: integer;
    max_save: array[1..60] of TPara;
    max_count: integer;
begin
    max_count:=0;
    max_p:=0;
    for i:=1 to 8 do
        for j:=1 to 8 do
            if Field[j,i].fig=0 then
            begin
                p:=PosPower(fig,j,i);
                if p>max_p then
                begin
                    max_p := p;
                    inc(max_count);
                    max_save[max_count].x:=j;
                    max_save[max_count].y:=i;
                end;
            end;
    p:=random(max_count)+1;
    x:=max_save[p].x;
    y:=max_save[p].y;
end;

function HasPos(fig:integer):boolean;
var i,j:integer;
    r:boolean;
begin
    r:=false;
    for i:=1 to 8 do
        for j:=1 to 8 do
            if (Field[j,i].fig=0) and (PosPower(fig,j,i)>0) then
                r:=r or true;
    HasPos:=r;
end;

{ cut off }
procedure Show;
var i,j:integer;
begin
    for i:=1 to 8 do
    begin
       for j:=1 to 8 do
          write(FigName(Field[j,i].fig),' ');
       writeln;
    end;
    writeln;
end;


procedure OnClick(X,Y:integer);
var nx,ny:integer;
    wait:boolean;
begin
    if PosPower(1,X,Y)>0 then
    begin
        SetFigure(X,Y,1);
        Show;
        //Pause;
        //SetLock(true);
        //CopyField;
        wait:=false;
        while HasPos(-1) do
        begin
            GetNewPos(-1, nx, ny);
            SetFigure(nx,ny,-1);
            if HasPos(1) then
            begin
                wait:=true;
                break;
            end;
        end;
        //SetLock(false);
        //if not wait then TheEnd;
    end;
end;

procedure PrintCounters;
var i,j:integer;
    b,r:integer;
begin
    b:=0; r:=0;
    for i:=1 to 8 do
        for j:=1 to 8 do
            if Field[j,i].fig=1 then inc(b)
            else if Field[j,i].fig=-1 then inc(r);
    writeln('B=',b,', R=',r);
end;

var nx,ny:integer;
begin
    OnStart;
    while HasPos(1) do
    begin
        GetNewPos(1, nx, ny);
        OnClick(nx,ny);
        Show;
        PrintCounters;
    end;
end.