old/PAS/XO/ROD3.INC

Procedure RodOldTurn(cz:byte; var x,y : byte);far;
Var
  x1,y1,PR,i,max,MAXX,MAXY,MAXI,MAXprX,MAXprY,MAXprI,MaxAr,MaxPRAr: byte;
  maxp,maxprp : integer;
  BestX,BestY,BestPRX,BestPRY : byte;
  ar : array [1..20] of byte;
  apr : array [1..20] of byte;
  Around : array [1..20] of byte;
  AroundPr : array [1..20] of byte;
  found,tmp,tmpPR,FoundPR,KON,FoundKrest,FNKR : boolean;

Procedure FindY(x1,y1,d:byte);
begin
case d of
 5: if (pole[x1,y1-1]=0) then begin x:=x1;y:=y1-1 end else
    if (pole[x1,y1-2]=0) then begin x:=x1;y:=y1-2 end else
    if (pole[x1,y1-3]=0) then begin x:=x1;y:=y1-3 end else
    begin x:=x1;y:=y1-4 end;
 4: if (pole[x1,y1-1]=0) then begin x:=x1;y:=y1-1 end else
    if (pole[x1,y1+1]=0) then begin x:=x1;y:=y1+1 end else
    if (pole[x1,y1-2]=0) then begin x:=x1;y:=y1-2 end else
    begin x:=x1;y:=y1-3 end;
 3: if (pole[x1,y1-1]=0) then begin x:=x1;y:=y1-1 end else
    if (pole[x1,y1+1]=0) then begin x:=x1;y:=y1+1 end else
    if (pole[x1,y1-2]=0) then begin x:=x1;y:=y1-2 end else
    begin x:=x1;y:=y1+2 end;
 2: if (pole[x1,y1-1]=0) then begin x:=x1;y:=y1-1 end else
    if (pole[x1,y1+1]=0) then begin x:=x1;y:=y1+1 end else
    if (pole[x1,y1+2]=0) then begin x:=x1;y:=y1+2 end else
    begin x:=x1;y:=y1+3 end;
 1: if (pole[x1,y1+1]=0) then begin x:=x1;y:=y1+1 end else
    if (pole[x1,y1+2]=0) then begin x:=x1;y:=y1+2 end else
    if (pole[x1,y1+3]=0) then begin x:=x1;y:=y1+3 end else
    begin x:=x1;y:=y1+4 end;
 end;
end;
Procedure FindX(x1,y1,d:byte);
begin
case d of
 5: if (pole[x1-1,y1]=0) then begin x:=x1-1;y:=y1 end else
    if (pole[x1-2,y1]=0) then begin x:=x1-2;y:=y1 end else
    if (pole[x1-3,y1]=0) then begin x:=x1-3;y:=y1 end else
    begin x:=x1-4;y:=y1-4 end;
 4: if (pole[x1-1,y1]=0) then begin x:=x1-1;y:=y1 end else
    if (pole[x1+1,y1]=0) then begin x:=x1+1;y:=y1 end else
    if (pole[x1-2,y1]=0) then begin x:=x1-2;y:=y1 end else
    begin x:=x1-3;y:=y1 end;
 3: if (pole[x1-1,y1]=0) then begin x:=x1-1;y:=y1 end else
    if (pole[x1+1,y1]=0) then begin x:=x1+1;y:=y1 end else
    if (pole[x1-2,y1]=0) then begin x:=x1-2;y:=y1 end else
    begin x:=x1+2;y:=y1 end;
 2: if (pole[x1-1,y1]=0) then begin x:=x1-1;y:=y1 end else
    if (pole[x1+1,y1]=0) then begin x:=x1+1;y:=y1 end else
    if (pole[x1+2,y1]=0) then begin x:=x1+2;y:=y1 end else
    begin x:=x1+3;y:=y1 end;
 1: if (pole[x1+1,y1]=0) then begin x:=x1+1;y:=y1 end else
    if (pole[x1+2,y1]=0) then begin x:=x1+2;y:=y1 end else
    if (pole[x1+3,y1]=0) then begin x:=x1+3;y:=y1 end else
    begin x:=x1+4;y:=y1 end;
 end;
end;
Procedure FindYX(x1,y1,d:byte);
begin
case d of
 5: if (pole[x1-1,y1-1]=0) then begin x:=x1-1;y:=y1-1 end else
    if (pole[x1-2,y1-2]=0) then begin x:=x1-2;y:=y1-2 end else
    if (pole[x1-3,y1-3]=0) then begin x:=x1-3;y:=y1-3 end else
    begin x:=x1-4;y:=y1-4 end;
 4: if (pole[x1-1,y1-1]=0) then begin x:=x1-1;y:=y1-1 end else
    if (pole[x1+1,y1+1]=0) then begin x:=x1+1;y:=y1+1 end else
    if (pole[x1-2,y1-2]=0) then begin x:=x1-2;y:=y1-2 end else
    begin x:=x1-3;y:=y1-3 end;
 3: if (pole[x1-1,y1-1]=0) then begin x:=x1-1;y:=y1-1 end else
    if (pole[x1+1,y1+1]=0) then begin x:=x1+1;y:=y1+1 end else
    if (pole[x1-2,y1-2]=0) then begin x:=x1-2;y:=y1-2 end else
    begin x:=x1+2;y:=y1+2 end;
 2: if (pole[x1-1,y1-1]=0) then begin x:=x1-1;y:=y1-1 end else
    if (pole[x1+1,y1+1]=0) then begin x:=x1+1;y:=y1+1 end else
    if (pole[x1+2,y1+2]=0) then begin x:=x1+2;y:=y1+2 end else
    begin x:=x1+3;y:=y1+3 end;
 1: if (pole[x1+1,y1+1]=0) then begin x:=x1+1;y:=y1+1 end else
    if (pole[x1+2,y1+2]=0) then begin x:=x1+2;y:=y1+2 end else
    if (pole[x1+3,y1+3]=0) then begin x:=x1+3;y:=y1+3 end else
    begin x:=x1+4;y:=y1+4 end;
 end;
end;

Procedure Find_YX(x1,y1,d:byte);
begin
case d of
 5: if (pole[x1+1,y1-1]=0) then begin x:=x1+1;y:=y1-1 end else
    if (pole[x1+2,y1-2]=0) then begin x:=x1+2;y:=y1-2 end else
    if (pole[x1+3,y1-3]=0) then begin x:=x1+3;y:=y1-3 end else
    begin x:=x1+4;y:=y1-4 end;
 4: if (pole[x1+1,y1-1]=0) then begin x:=x1+1;y:=y1-1 end else
    if (pole[x1-1,y1+1]=0) then begin x:=x1-1;y:=y1+1 end else
    if (pole[x1+2,y1-2]=0) then begin x:=x1+2;y:=y1-2 end else
    begin x:=x1+3;y:=y1-3 end;
 3: if (pole[x1+1,y1-1]=0) then begin x:=x1+1;y:=y1-1 end else
    if (pole[x1-1,y1+1]=0) then begin x:=x1-1;y:=y1+1 end else
    if (pole[x1+2,y1-2]=0) then begin x:=x1+2;y:=y1-2 end else
    begin x:=x1-2;y:=y1+2 end;
 2: if (pole[x1+1,y1-1]=0) then begin x:=x1+1;y:=y1-1 end else
    if (pole[x1-1,y1+1]=0) then begin x:=x1-1;y:=y1+1 end else
    if (pole[x1-2,y1+2]=0) then begin x:=x1-2;y:=y1+2 end else
    begin x:=x1-3;y:=y1+3 end;
 1: if (pole[x1-1,y1+1]=0) then begin x:=x1-1;y:=y1+1 end else
    if (pole[x1-2,y1+2]=0) then begin x:=x1-2;y:=y1+2 end else
    if (pole[x1-3,y1+3]=0) then begin x:=x1-3;y:=y1+3 end else
    begin x:=x1-4;y:=y1+4 end;
 end;
end;

Procedure FindKR(x1,y1:word);
Begin
  if (pole[x1-2,y1-2]=0) then begin x:=x1-2;y:=y1-2 end else
  if (pole[x1-2,y1+2]=0) then begin x:=x1-2;y:=y1+2 end else
  if (pole[x1+2,y1-2]=0) then begin x:=x1+2;y:=y1-2 end else
  begin x:=x1+2;y:=y1+2 end;
End;

Procedure FindNewKR(x1,y1:word);
Begin
  if (pole[x1-2,y1]=0) then begin x:=x1-2;y:=y1 end else
  if (pole[x1,y1-2]=0) then begin x:=x1;y:=y1-2 end else
  if (pole[x1-2,y1-2]=0) then begin x:=x1-2;y:=y1-2 end else
  begin x:=x1-1; y := y1-1; end;
End;

{}

Procedure AnalY(x1,y1:byte;c:boolean);
var pr,cz1,j,i : byte;
begin
 if c then cz1 := cz else cz1:=3-cz;
 if c then pr := 3-cz else pr := cz;
 for i := 5 downto 1 do
  if (pole[x1,y1-i+1]<>pr) and
     (pole[x1,y1-i+2]<>pr) and
     (pole[x1,y1-i+3]<>pr) and (y1-i+1>0) and (y1+5-i<n+1) and
     (pole[x1,y1-i+4]<>pr) and
     (pole[x1,y1-i+5]<>pr) then
       begin

         tmp := true;
         for j := 1 to 5 do if pole[x1,y1-i+j] = cz1 then
           if c then inc(ar[i]) else inc(aPr[i]);
       end;
end;
Procedure AnalX(x1,y1:byte;c:boolean);
var pr,cz1,j,i : byte;
begin
 if c then cz1 := cz else cz1:=3-cz;
 if c then pr := 3-cz else pr := cz;
 for i := 5 downto 1 do
  if (pole[x1-i+1,y1]<>pr) and
     (pole[x1-i+2,y1]<>pr) and
     (pole[x1-i+3,y1]<>pr) and (x1-i+1>0) and (x1+5-i<n+1) and
     (pole[x1-i+4,y1]<>pr) and
     (pole[x1-i+5,y1]<>pr) then
       begin
         tmp := true;
         for j := 1 to 5 do if pole[x1-i+j,y1] = cz1 then
           if c then inc(ar[5+i]) else inc(aPr[5+i]);
       end;
end;
Procedure AnalYX(x1,y1:byte;c:boolean);
var pr,cz1,j,i : byte;
begin
 if c then cz1 := cz else cz1:=3-cz;
 if c then pr := 3-cz else pr := cz;
 for i := 5 downto 1 do
  if (pole[x1-i+1,y1-i+1]<>pr) and
     (pole[x1-i+2,y1-i+2]<>pr) and
     (pole[x1-i+3,y1-i+3]<>pr) and (x1-i+1>0) and (x1+5-i<n+1) and
     (pole[x1-i+4,y1-i+4]<>pr) and (y1-i+1>0) and (y1+5-i<n+1) and
     (pole[x1-i+5,y1-i+5]<>pr) then
       begin
         tmp := true;
         for j := 1 to 5 do if pole[x1-i+j,y1-i+j] = cz1 then
           if c then inc(ar[10+i]) else inc(aPr[10+i]);
       end;
end;
Procedure Anal_YX(x1,y1:byte;c:boolean);
var pr,cz1,j,i : byte;
begin
 if c then cz1 := cz else cz1:=3-cz;
 if c then pr := 3-cz else pr := cz;
 for i := 5 downto 1 do
  if (pole[x1+i-1,y1-i+1]<>pr) and
     (pole[x1+i-2,y1-i+2]<>pr) and
     (pole[x1+i-3,y1-i+3]<>pr) and (x1+i-1<n+1) and (x1-5+i>0) and
     (pole[x1+i-4,y1-i+4]<>pr) and (y1-i+1>0) and (y1+5-i<n+1) and
     (pole[x1+i-5,y1-i+5]<>pr) then
       begin
         tmp := true;
         for j := 1 to 5 do if pole[x1+i-j,y1-i+j] = cz1 then
           if c then inc(ar[15+i]) else inc(aPr[15+i]);
       end;
end;

Procedure NewKr(X1,Y1:word);
Begin
  if (pole[x1-2,y1]<>pr) and
     (pole[x1,y1-2]<>pr) and
     (pole[x1-2,y1-2]<>pr) and
     (pole[x1-1,y1]=0) and
     (pole[x1,y1-1]=0) and
     (pole[x1-2,y1-1]=0) and
     (pole[x1-1,y1-1]=0) and
     (pole[x1-1,y1-2]=0) and
     (pole[x1-3,y1+1]=0) and
     (pole[x1-3,y1-3]=0) and
     (pole[x1+1,y1-3]=0) and (x1-1>0) and (x1+2<n) and (y1-1>0) and (y1+2<n) and
     (pole[x1+1,y1+1]=0) then
       begin
         maxx:=x1;
         maxy:=y1;
         fnkr:=true;
         found:=true;
       end;
End;{}

Procedure AnalKR(x1,y1:byte;c:boolean);
var pr,cz1,j,i : byte;
begin
 if c then cz1 := cz else cz1:=3-cz;
 if c then pr := 3-cz else pr := cz;
 if (pole[x1,y1]=cz) and
    (pole[x1-1,y1-1]=cz) and
    (pole[x1-1,y1+1]=cz) and
    (pole[x1+1,y1+1]=cz) and
    (pole[x1-2,y1-2]<>pr)and
    (pole[x1-2,y1+2]<>pr)and
    (pole[x1+2,y1+2]<>pr)and
    (pole[x1+2,y1-2]<>pr)then
       begin
         FoundKrest := true;
         found:=true;
         maxx:=x1;
         maxy:=y1;
       end;
end;

Begin
  randomize;
  pr := 3 - cz;
  found := false;
  for i := 1 to 20 do ar[i] := 0;
  for i := 1 to 20 do apr[i] := 0;
  FoundPR := false;
  MAXP := 0;
  MAXprP := 0;
  KON := false;
  foundkrest:=false;
  fnkr:=false;
  for y1 := 1 to n do
    for x1 := 1 to n do
      if Pole[x1,y1] = cz then
        begin
         if not kon then begin
         tmp := false;
         AnalKR(X1,Y1,true);
         if not foundkrest then begin
         NewKr(x1,Y1);
         if not FNKR then begin
         AnalX(x1,y1,true);
         AnalY(x1,y1,true);
         AnalYX(x1,y1,true);
         Anal_YX(x1,y1,true);
        if tmp then
         begin
           max := 1;
           for i := 2 to 20 do if ar[i] > ar[max] then max := i;
           if (ar[max] > MAXP) or ((ar[max] = MAXP) and (Random(1)=1))then
             begin
               MAXP := ar[max];
               MAXI := max;
               MAXX := x1;
               MAXY := y1;
               if maxp > 3 then begin KON := true; FoundPr := false; end;
               found := true;
             end;
           for i := 1 to 20 do ar[i] := 0;
         end;
        end;
        end;
        end;
        end else if pole[x1,y1] = PR then if not foundPR then
        begin
        if not kon then begin
        tmp := false;
        AnalX(x1,y1,false);
        AnalY(x1,y1,false);
        AnalYX(x1,y1,false);
        Anal_YX(x1,y1,false);
        if tmp then
         begin
           max := 0;
           for i := 1 to 20 do if apr[i] > 2 then max := i;
           if max <> 0 then
            if apr[max] > MAXprP then
             begin
               MAXprP := apr[max];
               MAXprI := max;
               MAXprX := x1;
               MAXprY := y1;
               foundPR := true;
               Found := true;
             end;
           for i := 1 to 20 do apr[i] := 0;
         end;
        end;
        end;

  if not found then
  repeat
    x:=random(n)+1;
    y:=random(n)+1;
  until Pole[x,y] = 0
  else if foundPR then
   begin
    if (maxprI in [1..5]) then FindY(maxprx,maxpry,maxprI) else
    if (maxprI in [6..10]) then FindX(maxprx,maxpry,maxprI-5) else
    if (maxprI in [11..15]) then FindYX(maxprx,maxpry,maxprI-10) else
    if (maxprI in [16..20]) then Find_YX(maxprx,maxpry,maxprI-15)
   end
  else
  if foundkrest then FindKR(maxx,maxy) else begin
   if fnkr then FindNewKR(maxx,maxy) else begin
   if (maxI<6) then FindY(MAXx,MAXy,maxI) else
   if (maxI in [6..10]) then FindX(MAXx,MAXy,maxI-5) else
   if (maxI in [11..15]) then FindYX(MAXx,MAXy,maxI-10) else
   Find_YX(MAXx,MAXy,maxI-15);
   end;
   end;
End;