all.pas

象棋源码

    if ichess[i,1]<>none then
    if i<7 then begin cost[i,2]:=-10;flag[i,2]:=true;break;end
    else break;
for i:=8 downto 5 do
    if ichess[i,8]<>none then
    if i<7 then begin cost[i,7]:=-10;flag[i,7]:=true;break;end
    else break;
for i:=8 downto 5 do
    if ichess[1,i]<>none then
    if i<7 then begin cost[2,i]:=-10;flag[2,i]:=true;break;end
    else break;
for i:=8 downto 5 do
    if ichess[8,i]<>none then
    if i<7 then begin cost[7,i]:=-10;flag[7,i]:=true;break;end
    else break;
}
  temp := -9;
  for i := 2 to 7 do begin
    for j := 2 to 7 do begin
      if (ichess[i, j] <> none)
        and (not ((i = 2) and (j = 2))) and (not ((i = 7) and (j = 2))) and (not ((i = 2) and (j = 7))) and (not ((i = 7) and (j = 7)))
        then
      begin
        if (ichess[i + 1, j + 1] <> none) then inc(temp);
        if (ichess[i - 1, j - 1] <> none) then inc(temp);
        if (ichess[i + 1, j - 1] <> none) then inc(temp);
        if (ichess[i - 1, j + 1] <> none) then inc(temp);
        if (ichess[i + 1, j] <> none) then inc(temp);
        if (ichess[i, j + 1] <> none) then inc(temp);
        if (ichess[i - 1, j] <> none) then inc(temp);
        if (ichess[i, j - 1] <> none) then inc(temp);
        cost[i, j] := temp;
        temp := -9;
      end;
    end; end;

  if ichess[1, 8] <> none then begin cost[1, 7] := 40; cost[2, 8] := 40; end;
  if ichess[8, 8] <> none then begin cost[8, 7] := 40; cost[7, 8] := 40; end;
  if ichess[1, 1] <> none then begin cost[1, 2] := 40; cost[2, 1] := 40; end;
  if ichess[8, 1] <> none then begin cost[8, 2] := 40; cost[7, 1] := 40; end;

  if ichess[1, 1] <> none then
  begin
    for i := 3 to 6 do
    begin
      cost[i, 2] := -1;
      cost[2, i] := -1;
    end;
    cost[2, 2] := 20;
  end;
  if ichess[8, 8] <> none then
  begin
    for i := 3 to 6 do
    begin
      cost[7, i] := -1;
      cost[i, 7] := -1;
    end;
    cost[7, 7] := 20;
  end;
  if ichess[8, 1] <> none then
  begin
    for i := 3 to 6 do
      cost[i, 2] := -1;
    for i := 3 to 6 do
      cost[7, i] := -1;
    cost[7, 2] := 20;
  end;
  if ichess[1, 8] <> none then
  begin
    for i := 3 to 6 do
      cost[i, 7] := -1;
    for i := 3 to 6 do
      cost[2, i] := -1;
    cost[2, 7] := 20;
  end;


end;

procedure changecost2;
var
  i, j: integer;
begin
  for i := 1 to 8 do begin
    for j := 1 to 8 do begin
      cost[i, j] := 1; end; end;
end;

{
procedure changecost3;
var
i,j:integer;
begin
for i:=1 to 8 do begin
for j:=1 to 8 do begin
cost[i,j]:=1;end;end;
for i:=2 to 7 do begin
for j:=2 to 7 do begin
cost[i,j]:=-1;end;end;
cost[1,1]:=3;
cost[8,8]:=3;
cost[1,8]:=3;
cost[8,1]:=3;
end;
}
{procedure changecost4;
var
i:integer;
begin
for i:=2 to 7 do
begin
    cost[i,1]:=-6;
    cost[i,8]:=-6;
    cost[8,i]:=-6;
    cost[1,i]:=-6;
end;
end;
}

procedure printchess(x, y: integer; chess: Tbitmap);
var
  grid: trect;
begin
  grid := drawgrid.CellRect(x - 1, y - 1);
  if chess = nonechess then begin
    drawgrid.Canvas.FillRect(grid);
    exit;
  end;
  drawgrid.canvas.draw(grid.left, grid.top, chess);
end;

procedure changechess(x, y, chess, z: integer);
var
  i, j: integer;
  color: Tbitmap;
  opchess: integer;
begin
  chessable := 0;
  if ichess[x, y] <> none then exit;
  if (chess = black) then begin color := blackchess; opchess := white; end
  else begin color := whitechess; opchess := black; end;
  l := 0; r := 0; u := 0; d := 0; lu := 0; ld := 0; rd := 0; ru := 0;
  if (y > 2) and (ichess[x, y - 1] = opchess) then
  begin
    for i := y - 2 downto 1 do
    begin
      if (ichess[x, i] = 0) then break;
      if (ichess[x, i] = chess) then begin u := y - i - 1; chessable := 1; if z = 0 then exit; break; end;
    end;
  end;
  if (y < 7) and (ichess[x, y + 1] = opchess) then
  begin
    for i := y + 2 to 8 do
    begin
      if (ichess[x, i] = 0) then break;
      if (ichess[x, i] = chess) then begin d := i - y - 1; chessable := 1; if z = 0 then exit; break; end;
    end;
  end;
  if (x > 2) and (ichess[x - 1, y] = opchess) then
  begin
    for i := x - 2 downto 1 do
    begin
      if (ichess[i, y] = 0) then break;
      if (ichess[i, y] = chess) then begin l := x - i - 1; chessable := 1; if z = 0 then exit; break; end;
    end;
  end;
  if (x < 7) and (ichess[x + 1, y] = opchess) then
  begin
    for i := x + 2 to 8 do
    begin
      if (ichess[i, y] = 0) then break;
      if (ichess[i, y] = chess) then begin r := i - x - 1; chessable := 1; if z = 0 then exit; break; end;
    end;
  end;
  if (y > 2) and (x > 2) and (ichess[x - 1, y - 1] = opchess) then
  begin
    for i := 2 to 7 do
    begin
      if (x - i >= 1) and (y - i >= 1) then begin
        if (ichess[x - i, y - i] = 0) then break;
        if (ichess[x - i, y - i] = chess) then begin lu := i - 1; chessable := 1; if z = 0 then exit; break; end;
      end; end;
  end;
  if (y > 2) and (x < 7) and (ichess[x + 1, y - 1] = opchess) then
  begin
    for i := 2 to 7 do
    begin
      if (x + i <= 8) and (y - i >= 1) then begin
        if ichess[x + i, y - i] = 0 then break;
        if ichess[x + i, y - i] = chess then begin ru := i - 1; chessable := 1; if z = 0 then exit; break; end;
      end; end;
  end;
  if (y < 7) and (x < 7) and (ichess[x + 1, y + 1] = opchess) then
  begin
    for i := 2 to 7 do
    begin
      if (x + i <= 8) and (y + i <= 8) then begin
        if ichess[x + i, y + i] = 0 then break;
        if ichess[x + i, y + i] = chess then begin rd := i - 1; chessable := 1; if z = 0 then exit; break; end;
      end; end;
  end;
  if (y < 7) and (x > 2) and (ichess[x - 1, y + 1] = opchess) then
  begin
    for i := 2 to 7 do
    begin
      if (x - i >= 1) and (y + i <= 8) then begin
        if ichess[x - i, y + i] = 0 then break;
        if ichess[x - i, y + i] = chess then begin ld := i - 1; chessable := 1; if z = 0 then exit; break; end;
      end; end;
  end;
  if (chessable = 0) or (z = 0) or (z = 3) then exit;
  if (z = 1) then
  begin
    if (chess = black) then blcount := blcount + 1
    else whcount := whcount + 1;
  end;
  if (u > 0) then
  begin
    ichess[x, y] := chess;
    for i := y - 1 downto y - u do
    begin
      ichess[x, i] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(x, i);
        if (chess = white) then turntowh(x, i);
      end; end;
  end;

  if (d > 0) then
  begin
    ichess[x, y] := chess;
    for i := y + 1 to y + d do
    begin
      ichess[x, i] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(x, i);
        if (chess = white) then turntowh(x, i);
      end; end;
  end;
  if (l > 0) then
  begin
    ichess[x, y] := chess;
    for i := x - 1 downto x - l do
    begin
      ichess[i, y] := chess;
      if (z = 1) then
      begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(i, y);
        if (chess = white) then turntowh(i, y);
      end;
    end;
  end;
  if (r > 0) then
  begin
    ichess[x, y] := chess;
    for i := x + 1 to x + r do
    begin
      ichess[i, y] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(i, y);
        if (chess = white) then turntowh(i, y);
      end; end;
  end;
  if (lu > 0) then
  begin
    ichess[x, y] := chess;
    for i := 1 to lu do
    begin
      ichess[x - i, y - i] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(x - i, y - i);
        if (chess = white) then turntowh(x - i, y - i);
      end; end;
  end;
  if (ru > 0) then
  begin
    ichess[x, y] := chess;
    for i := 1 to ru do
    begin
      ichess[x + i, y - i] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(x + i, y - i);
        if (chess = white) then turntowh(x + i, y - i);
      end; end;
  end;
  if (rd > 0) then
  begin
    ichess[x, y] := chess;
    for i := 1 to rd do
    begin
      ichess[x + i, y + i] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(x + i, y + i);
        if (chess = white) then turntowh(x + i, y + i);
      end; end;
  end;
  if (ld > 0) then
  begin
    ichess[x, y] := chess;
    for i := 1 to ld do
    begin
      ichess[x - i, y + i] := chess;
      if (z = 1) then begin
        printchess(x, y, color);
        locate(irol, irow, clred);
        if (chess = black) then turntobl(x - i, y + i);
        if (chess = white) then turntowh(x - i, y + i);
      end; end;
  end;
end;


procedure locate(x, y: integer; color: tcolor);
var grid: trect;
begin
  grid := drawgrid.CellRect(x - 1, y - 1);
  drawgrid.canvas.pen.Color := color;
  drawgrid.canvas.pen.Width := 3;
  drawgrid.canvas.MoveTo(grid.left + 1, grid.top + 1);
  drawgrid.canvas.Lineto(grid.left + 5, grid.top + 1);
  drawgrid.canvas.MoveTo(grid.left + 1, grid.top + 1);
  drawgrid.canvas.Lineto(grid.left + 1, grid.top + 5);
  drawgrid.canvas.MoveTo(grid.right - 2, grid.bottom - 2);
  drawgrid.canvas.Lineto(grid.right - 6, grid.bottom - 2);
  drawgrid.canvas.MoveTo(grid.right - 2, grid.bottom - 2);
  drawgrid.canvas.Lineto(grid.right - 2, grid.bottom - 6);
  drawgrid.canvas.MoveTo(grid.right - 2, grid.top + 1);
  drawgrid.canvas.Lineto(grid.right - 6, grid.top + 1);
  drawgrid.canvas.MoveTo(grid.right - 2, grid.top + 1);
  drawgrid.canvas.Lineto(grid.right - 2, grid.top + 5);
  drawgrid.canvas.MoveTo(grid.left + 1, grid.bottom - 2);
  drawgrid.canvas.Lineto(grid.left + 5, grid.bottom - 2);
  drawgrid.canvas.MoveTo(grid.left + 1, grid.bottom - 2);
  drawgrid.canvas.Lineto(grid.left + 1, grid.bottom - 6);
end;

procedure turntobl(x: integer; y: integer);
var
  wavname: string;
begin
  wavname := path + 'bw.wav';
  printchess(x, y, whitechess2);
  if soundopen then sndplaysound(pchar(wavname), SND_SYNC);
  printchess(x, y, whitechess3);
  sleep(speed);
  printchess(x, y, blackchess3);
  sleep(speed);
  printchess(x, y, blackchess2);
  sleep(speed);
  printchess(x, y, blackchess);
  blcount := blcount + 1;
  whcount := whcount - 1;
end;

procedure turntowh(x: integer; y: integer);
var
  wavname: string;
begin
  wavname := path + 'bw.wav';
  printchess(x, y, blackchess2);
  if soundopen then sndplaysound(pchar(wavname), SND_SYNC);
  printchess(x, y, blackchess3);
  sleep(speed);
  printchess(x, y, whitechess3);
  sleep(speed);
  printchess(x, y, whitechess2);
  sleep(speed);
  printchess(x, y, whitechess);
  blcount := blcount - 1;
  whcount := whcount + 1;
end;

end.