Mega Code Archive
Neoturk - n adet veziri satranç tahtasına yerleştirelim [ recursive örneği ]
<![CDATA[
herkese merhaba,
artık kod uzmanı olmamız gerekiyor,
bu da .pas uzantılı bir dosyayı gözle incelerken,
forma neleri yerleştireceğimizi hemen farketmemiz gerek!
örnek:
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
Memo1: TMemo;
StringGrid2: TStringGrid;
ListBox1: TListBox;
Label2: TLabel;
Label3: TLabel;
Timer1: TTimer;
Label1: TLabel;
CheckBox1: TCheckBox;
Edit1: TEdit;
Button2: TButton;
Label4: TLabel;
yukarda görüldüğü gibi,
forma,
2 adet stringgrid
-bir tanesi yerleştirme animasyonunu gösterecek
-bir tanesi yerleştirilmiş pozisyonu gösterecek
2 adet button
-yerleştir düğmesi
-dur düğmesi
1 adet memo
-ayrıntıları yazmak için
4 adet label
-bilgilendirme amaçlı labeller
1 adet timer
-süre sayacı
1 adet checkbox
-tarama animasyonunu gösterip göstermeyeceği
1 adet edit
-kaç adet veziri yerleştireceğimizi buraya girecez sayı olarak
1 adet listbox
-bulunan çözümlerin listesini tutacak
kodun tamamı aşağıdadır ( pas olarak )
gereken click ve yordamları elle düzeltin ve yerine yazın
programı çalıştırıp test edebilirsiniz,
amaç: recursive ( öz yineli ) function kullanımını kavramak
hikayesi:
bir arkadaşım bilgisayar mühendisliğinde okuyordu ve mezun oldu.
ama kodlama alt yapısı sıfırdı...
örnek çalışmalarını incelediğimde piyasa gezen 8 veziri yerleştiren
pascal kodu ile uygulama yaptıklarını gördüm.
hocaların bile bu konu üzerinde durmayıp
NxN lik bir tahta için çözüm üretmemeleri beni kızdırdı açıkçası...
oturup sıfırdan yazmak istedim ve 3 saatte mantığını oluşturup
kodladım. çok da zorlanmadım açıkçası. zorlanırsam namerdim !!!
**************************************************************
**** N adet veziri satranç tahtasına yeleştiren programım ****
**************************************************************
{ written by neoturk 02.2005 }
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, Grids, ExtCtrls;
type
TForm1 = class(TForm)
StringGrid1: TStringGrid;
Button1: TButton;
Memo1: TMemo;
StringGrid2: TStringGrid;
ListBox1: TListBox;
Label2: TLabel;
Label3: TLabel;
Timer1: TTimer;
Label1: TLabel;
CheckBox1: TCheckBox;
Edit1: TEdit;
Button2: TButton;
Label4: TLabel;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ListBox1Click(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure goster(sender:Tobject);
procedure goster2(sender:Tobject);
end;
const
vezir='X';
crlf=#13#10;
var
Form1: TForm1;
timex,bulunan,positioncount:integer;
tempx,vezirlist:tstringlist;
tahta:array[1..100,1..100] of string;
maxvezir:byte;
kapat:boolean;
implementation
{$R *.dfm}
//************* copy + pos combination *******************
function left12(sender:Tobject;x:string;subkey:string;leftrayt:byte):string;
var x1,x2:string;posx:integer;lenx:integer;
begin
lenx:=length(subkey);
posx:=pos(subkey,x);
x1:=copy(x,1,posx-lenx);
x2:=copy(x,posx+lenx,999);
if leftrayt=1 then left12:=x1 else left12:=x2;
end;
{*********************** getlines ************************}
function getlines(x:string;apostrof:string):string;
var m,n,acount:integer;x2:string;tg:Tstringlist;
begin
//apostrof miktarını öğren
acount:=0;
n:=length(x);
for m:=1 to n do if x[m]=apostrof then inc(acount);
//apostrofları ayır
tg:=tstringlist.Create;
n:=acount;
for m:=1 to n do
begin
x2:=copy(x,1,pos(apostrof,x)-1);
//form1.memo1.lines.add(inttostr(pos(apostrof,x))+apostrof);
tg.add(trim(x2));
//form1.memo1.lines.add(x2);
x2:=copy(x,pos(apostrof,x)+1,9999);
//showmessage('ok');
x:=x2;
end;
if trim(x)<>'' then tg.add(trim(x));
result:=tg.text;
tg.free;
//final
end;
//*** form create (başlangıç)
procedure TForm1.FormCreate(Sender: TObject);
begin
tempx:=tstringlist.Create;
vezirlist:=Tstringlist.Create;
maxvezir:=8;
//final
end;
//*** goster
procedure Tform1.goster(sender:Tobject);
var m,n:integer;
begin
if checkbox1.Checked=false then exit;
for m:=1 to maxvezir do
for n:=1 to maxvezir do
stringgrid1.Cells[n-1,m-1]:=tahta[m,n];
//final
end;
//*** goster2
procedure Tform1.goster2(sender:Tobject);
var m,n:integer;
begin
for m:=1 to maxvezir do
for n:=1 to maxvezir do
if tahta[m,n]=vezir then form1.stringgrid2.Cells[n-1,m-1]:=tahta[m,n] else form1.StringGrid2.Cells[n-1,m-1]:=' ';
//final
end;
//*** goster
procedure goster3(sender:Tobject);
var m,n:integer;
begin
for m:=1 to maxvezir do
for n:=1 to maxvezir do
if tahta[m,n]=vezir then form1.stringgrid1.Cells[n-1,m-1]:=tahta[m,n] else form1.StringGrid1.Cells[n-1,m-1]:=' ';
//final
end;
//*** vezir say
function vezirsay(sender:Tobject):integer;
var m,n,vezirsayisi:integer;
begin
vezirsayisi:=0;
for m:=1 to maxvezir do
for n:=1 to maxvezir do
if tahta[m,n]=vezir then inc(vezirsayisi);
result:=vezirsayisi;
//final
end;
//*** path capture
function pathcapture(sender:Tobject):string;
var m,n:integer;x:string;bul:integer;
begin
x:='';bul:=0;
for m:=1 to maxvezir do
for n:=1 to maxvezir do
if tahta[m,n]=vezir then
begin
inc(bul);
if bul=maxvezir then
x:=x+inttostr(m)+ '-'+inttostr(n)
else
x:=x+inttostr(m)+ '-'+inttostr(n)+',';
end;
result:=x;
//final
end;
//*** yerlestir
procedure yerlestir(sender:Tobject;sat,sut:integer);
var xsat,xsut,m:integer;
begin
for m:=sut+1 to maxvezir do tahta[sat,m]:='1';//yatay
for m:=sut-1 downto 1 do tahta[sat,m]:='1';//yatay
for m:=sat+1 to maxvezir do tahta[m,sut]:='1';//dikey
for m:=sat-1 downto 1 do tahta[m,sut]:='1';//dikey
xsat:=sat;xsut:=sut;
repeat
xsat:=xsat-1;xsut:=xsut-1;
if (xsat>=1) and (xsut>=1) then tahta[xsat,xsut]:='1';
until (xsat<=1) or (xsut<=1);
xsat:=sat;xsut:=sut;
repeat
xsat:=xsat-1;xsut:=xsut+1;
if (xsat>=1) and (xsut<=maxvezir) then tahta[xsat,xsut]:='1';
until (xsat<=1) or (xsut>=maxvezir);
xsat:=sat;xsut:=sut;
repeat
xsat:=xsat+1;xsut:=xsut-1;
if (xsat<=maxvezir) and (xsut>=1) then tahta[xsat,xsut]:='1';
until (xsat>=maxvezir) or (xsut<=1);
xsat:=sat;xsut:=sut;
repeat
xsat:=xsat+1;xsut:=xsut+1;
if (xsat<=maxvezir) and (xsut<=maxvezir) then tahta[xsat,xsut]:='1';
until (xsat>=maxvezir) or (xsut>=maxvezir);
tahta[sat,sut]:=vezir;//veziri yerleştir
//final
end;
//*** rebuild tahta ( remove vezir )
procedure rebuildtahta(sender:Tobject);
var m,n:integer;x:string;sat,sut:integer;
begin
//vezir listesini oluştur
vezirlist.Clear;
for m:=1 to maxvezir do
for n:=1 to maxvezir do
if tahta[m,n]=vezir then vezirlist.Add(inttostr(m)+'-'+inttostr(n));
//clear tahta
for m:=1 to maxvezir do
for n:=1 to maxvezir do tahta[m,n]:='0';
//set tahta
n:=vezirlist.Count-1;
for m:=0 to n do
begin
x:=vezirlist.Strings[m];
sat:=strtoint(left12(sender,x,'-',1));
sut:=strtoint(left12(sender,x,'-',2));
tahta[sat,sut]:=vezir;
yerlestir(sender,sat,sut);
end;
form1.goster(sender);
end;
//************** recursive ****************
procedure r(sender:Tobject;satir,sutun,level:integer);
var xsat,xsut,m,n:integer;blsat,blsut:Tstringlist;x:string;
procedure getfreenodes;
var m,n:integer;
begin
//boş nokta listesini oluştur
tempx.Clear;
for m:=1 to maxvezir do
for n:=1 to maxvezir do
if tahta[m,n]='0' then
begin
blsat.Add(inttostr(m));
blsut.Add(inttostr(n));
tempx.Add(inttostr(m)+'-'+inttostr(n));
end;
//form1.Memo2.text:=tempx.Text;form1.Memo2.Refresh;
end;
//begin
begin
if kapat then exit;
blsat:=Tstringlist.Create;
blsut:=Tstringlist.Create;
yerlestir(sender,satir,sutun);
inc(positioncount);
form1.label1.caption:=inttostr(positioncount)+'/ L:'+inttostr(level);
inc(level);
if vezirsay(sender)=maxvezir then
begin
x:=pathcapture(sender);
//form1.Memo1.lines.add(x);
if form1.ListBox1.Items.IndexOf(x)=-1 then
begin
inc(bulunan);
form1.Label2.caption:=inttostr(bulunan)+' found';
form1.listbox1.Items.add(x);
goster3(sender);
end;
end
else
begin
if vezirsay(sender)<satir then exit;//bu satır gereksiz taramaları engeller
getfreenodes;//boş noktaları hesapla ve al
//analize başla
for m:=0 to blsat.Count-1 do
begin
xsat:=strtoint(blsat.strings[m]);
xsut:=strtoint(blsut.strings[m]);
//showmessage(inttostr(m)+' > '+inttostr(xsat)+'-'+inttostr(xsut)+crlf+'/position:'+inttostr(positioncount)+'/ L:'+inttostr(level));
r(sender,xsat,xsut,level);
tahta[xsat,xsut]:='0';rebuildtahta(sender);
application.ProcessMessages;
end;
end;
blsat.Free;
blsut.Free;
//final
end;
procedure clearboard;
var m,n:integer;
begin
for m:=1 to maxvezir do
for n:=1 to maxvezir do
tahta[m,n]:='0';
end;
procedure TForm1.Button1Click(Sender: TObject);
var m,n:integer;
begin
maxvezir:=strtointdef(edit1.Text,8);
kapat:=false;
stringgrid1.RowCount:=maxvezir;
stringgrid1.colCount:=maxvezir;
stringgrid2.RowCount:=maxvezir;
stringgrid2.colCount:=maxvezir;
timer1.Enabled:=true;
timex:=0;
bulunan:=0;
positioncount:=0;
memo1.Clear;listbox1.Clear;
clearboard;
//r(sender,1,1,0);
for m:=1 to maxvezir do
begin
clearboard;
r(sender,1,m,0);
end;
memo1.Lines.Add('ok. [ '+inttostr(positioncount)+' position searched... ]');
timer1.Enabled:=false;
//final
end;
procedure TForm1.ListBox1Click(Sender: TObject);
var m,n:integer;x:string;xsat,xsut:integer;
begin
m:=listbox1.ItemIndex;
if m<>-1 then
begin
x:=listbox1.items[m];
tempx.Text:=getlines(x,',');
for m:=1 to maxvezir do
for n:=1 to maxvezir do
begin
tahta[m,n]:='0';
stringgrid2.Cells[m-1,n-1]:='0';
end;
for m:=0 to tempx.Count-1 do
begin
x:=tempx.Strings[m];
xsat:=strtoint(left12(sender,x,'-',1));
xsut:=strtoint(left12(sender,x,'-',2));
tahta[xsat,xsut]:=vezir;
yerlestir(sender,xsat,xsut);
goster2(sender);
end;
end;
//final
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
inc(timex);
label3.Caption:=inttostr(timex)+' second';
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
kapat:=true;
end;
end.
**********************************************************************
işte piyasada gezen pascal kodu:
program Project1;
{$APPTYPE CONSOLE}
uses
SysUtils;
type
durum=array[1..8]of 1..8;
var
x,y,sayac,grd,grm,k,j:integer;
sakla:array[1..92]of durum;
durumlar:durum;
ihtimal:byte;
colon:array[1..8]of 1..8;
colfree:array[1..8]of boolean;
upfree:array[2..16]of boolean;
downfree:array[-7..7]of boolean;
sira:0..8;
procedure Bul; {8 Vezirin bir birini yemeden nerelere konulacag }
var s:1..8; { ihtimallerini bulan procedure}
i:byte;
begin
sira:=sira+1;
for s:=1 to 8 do
if colfree[s] and upfree[sira+s] and downfree[sira-s] then
begin
colon[sira]:=s; colfree[s]:=false;
upfree[sira+s]:=false; downfree[sira-s]:=false;
if sira=8 then
begin
sayac:=sayac+1; ;
Write(sayac:2,'. Durum : ');
for i:=1 to 8 do
begin
write(i,'-',colon[i],' ');
durumlar[i]:=colon[i];
end;
sakla[sayac]:=durumlar;
writeln;
if (sayac mod 23)=0 then
begin
writeln(' Di§er Durunlar G”rmek ˜‡in Bir TuŸa Basn');
readln;
end;
end {if}
else bul; {!!! PROCEDUR'UN KEND˜N˜ €AGIRDIGI YER !!!!!!}
colfree[s]:=true;
upfree[sira+s]:=true;
downfree[sira-s]:=true;
end;{if}
sira:=sira-1;
end; {procedure}
begin
{ TODO -oUser -cConsole Main : Insert code here }
writeln;
sira:=0;
sayac:=0;
for x:=1 to 8 do
colfree[x]:=true;
for x:=2 to 16 do
upfree[x]:=true;
for x:=-7 to 7 do
downfree[x]:=true;
bul;
repeat
writeln('92 durum söz konusu bir ihtimal numarası girin');
readln(ihtimal);
if (ihtimal>0) and (ihtimal<93) then
begin
durumlar:=sakla[ihtimal];
end;
until ihtimal=0;
end.
******************
gördüğünüz gibi alıntı bir kod olup, üzerinde türkçeleştirme yapılmış hali!
orjinali de bende mevcut.
ve benim yazdığım program ile hiç bir alakası ve benzerliği de yok.
yukardaki kodu NxN e çeviremezsiniz, çünkü,
for x:=1 to 8 do
colfree[x]:=true;
for x:=2 to 16 do
upfree[x]:=true;
for x:=-7 to 7 do
downfree[x]:=true;
görüldüğü gibi buradaki mantık ne için kullanılmış yazana sormak lazım!
fazla da kasmak istemiyorum zaten....
welhasıl istenilenin kodunu yazın ve soran kişinin yüzüne yapıştırın
başka bi söze gerek yok....
saygılarımla_
xxnt03@lycos.co.uk
]]>