imported>Unknown at 05:23, 7 February 2021

2021-02-07T05:23:11Z

New page

일단 찍어 놓을테니까 좀 세줘- 라는 개념의 소스...다소 엽기 소스라 볼 수있을지도...-_-;;;
버튼1을 누르면 찾는 과정이 애니메이션(?) 됩니다..
여기 있는 소스들중 가장 인간적인(?) 소스라 자부함.. :) (다들 어쩌면 그렇게 아이디어들이 번뜩이시는지)

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(TForm)
Button1: TButton;
procedure FormPaint(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

var
Table: array[0..8-1, 0..8-1] of Boolean;

procedure ClearTable;
var
i, j: Integer;
begin
for i := 0 to 8 -1 do
for j := 0 to 8 -1 do
Table[i, j] := False;
end;

function CountRow(row: Integer): Integer;
var
i: Integer;
begin
Result := 0;
for i := 0 to 8-1 do
if Table[i, row] then
Inc(Result);
end;

procedure SetQueens(n: Integer); // 퀸 배치하기. 이 소스의 핵심함수. n은 현재 사용안한다. 처음엔 RandomSeed로 쓰려했음..-_-;
var
i, row: Integer;
begin
ClearTable;
for i := 0 to 8-1 do // 가로 세로만 조건에 일치하도록 랜덤하게 배치함.
while True do
begin
row := random(8);
Table[i, row] := True;
if CountRow(row) > 1 then
Table[i, row] := False
else
Break;
end;
end;

function CheckQueens: Boolean; // 제대로 배치되었는지 검사하는 함수.
function CountColumn(column: Integer): Integer;
var
i: Integer;
begin
Result := 0;
for i := 0 to 8-1 do
if Table[column, i] then
Inc(Result);
end;

function CountSlash(column: Integer): Integer;
var
i: Integer;
x, y: Integer;
begin
Result := 0;
for i := 0 to 8*2-1 do
begin
x := column - i;
y := i;
if (x > 7) or (y > 7) or (x < 0) or (y < 0) then
Continue;
if Table[x, y] then
Inc(Result);
end;
end;

function CountBackSlash(column: Integer): Integer;
var
i: Integer;
x, y: Integer;
begin
Result := 0;
for i := 0 to 8*2-1 do
begin
x := column + i;
y := i;
if (x > 7) or (y > 7) or (x < 0) or (y < 0) then
Continue;
if Table[x, y] then
Inc(Result);
end;
end;

var
i: Integer;
begin
Result := False;
for i := 0 to 8-1 do
begin
if CountRow(i) > 1 then
Exit;
if CountColumn(i) > 1 then
Exit;
end;

for i := 0 to 16-1 do
if CountSlash(i) > 1 then
Exit;
for i := -8 to 8-1 do
if CountBackSlash(i) > 1 then
Exit;
Result := True;
end;

procedure DrawQueens;
var
i, j: Integer;
x, y: Integer;
r: TRect;
begin
for i := 0 to 8 -1 do
for j := 0 to 8 -1 do
begin
x := i * 32;
y := j * 32;
r := Bounds(x, y, 32, 32);
if Table[i, j] then
Form1.Canvas.Brush.Color := clRed
else
Form1.Canvas.Brush.Color := clWhite;
Form1.Canvas.Rectangle(r);
end;
end;

procedure TForm1.FormPaint(Sender: TObject);
begin
DrawQueens;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
n: Integer;
begin
Randomize;
n := 0;
repeat
SetQueens(n);
Inc(n);
DrawQueens;
until CheckQueens;
end;

end.

모든 퀸 찾기. 이런건 반칙이다- 하셔도 별 할말이 없음 -_-;;;
30분동안 뭔가 다른 방법을 찾아 볼라고 고민을 했습니다만 포기.......-_-;;

procedure FindAllQueens;
var
n: Integer;
i0, i1, i2, i3, i4, i5, i6, i7: Integer;
begin
n := 0;
for i0 := 0 to 8-1 do
for i1 := 0 to 8-1 do
for i2 := 0 to 8-1 do
for i3 := 0 to 8-1 do
for i4 := 0 to 8-1 do
for i5 := 0 to 8-1 do
for i6 := 0 to 8-1 do
for i7 := 0 to 8-1 do
begin
ClearTable;
Table[0, i0] := True;
Table[1, i1] := True;
Table[2, i2] := True;
Table[3, i3] := True;
Table[4, i4] := True;
Table[5, i5] := True;
Table[6, i6] := True;
Table[7, i7] := True;
if CheckQueens then
begin
DrawQueens;
Inc(n);
form1.Caption := inttostr(n);
end;
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
FindAllQueens;
end;

EightQueenProblem/밥벌레 - Revision history

imported>Unknown at 05:23, 7 February 2021