BitCell

by **DarkByte** » 19 Apr 2011, 01:09

M-am gandit, recent, sa implementez niste algoritmi clasici in niste programe mai ... vizuale, pentru a facilita intelegerea tehnicilor de programare si a problemelor.

Am sa incep cu problema damelor, o aplicatie clasica de backtracking (in varianta in care se doreste gasirea tuturor solutiilor, evident).

Un exemplu animat al cautarii solutiilor (imagine luata de pe Wikipedia):

Programul meu afiseaza damele pe masura ce sunt cautate, aratand fiecare pas al cautarii, iar daca vreo dama asezata pe tabla inaintea damei curente o ataca pe aceasta, un chenar rosu va fi afisat in jurul damei curente. Damele pot ataca pe rectangular (orizontal sau vertical) si pe diagonala (daca nu stiti juca sah, acum este momentul sa va apucati

). Am folosit un backtracking recursiv pentru ca mi s-a parut mai usor de scris ... so sue me

- chiar si asa, comentariile din cod ar trebui sa va ajute sa intelegeti. If all else fails, sunteti invitati sa puneti intrebari

O imagine cu programul:

Asa cum se observa si din screenshot, programul permite oprirea, pauzarea sau setarea vitezei de afisare a algoritmului. Thought they might come in handy. Programul e limitat sa foloseasca o tabla minima de 4x4 si o tabla maxima de 12x12 - nu exista solutii pentru table mai mici (decat la 1x1

) si, cu siguranta, nu veti sta sa "urmariti" cautarea tuturor solutiilor pentru o tabla de 12x12 (nici macar la viteza maxima)

Acestea fiind zise, in speranta ca v-am convins sa cumparati (

), urmeaza codul sursa al programului:

Line number On/Off | Expand/Contract | Select all

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ComCtrls, Spin, ExtCtrls, ShellAPI;
 
type
  TForm1 = class(TForm)
    Label1: TLabel;
    seDame: TSpinEdit;
    Label2: TLabel;
    lblCountSol: TLabel;
    btnStart: TButton;
    imgQueenW: TImage;
    imgQueenB: TImage;
    imgBackW: TImage;
    imgBackB: TImage;
    imgBoard: TImage;
    btnStop: TButton;
    lblCredits: TLabel;
    imgCheck: TImage;
    seWait: TSpinEdit;
    Label3: TLabel;
    btnPause: TButton;
    procedure btnStartClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure lblCreditsClick(Sender: TObject);
    procedure btnPauseClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure CalculateSolution(aLine: Integer);
    procedure DrawTable(aCount: Integer; inCheck: Boolean = False; aFinal: Boolean = False);
  end;
 
var
  Form1: TForm1;
 
var solution : array [1 .. 12] of Integer; // it takes too long for more, anyway!
    linCount: integer;
    solCount : integer;
    DoPause: Boolean;
    MustStop: Boolean;
    WaitInterval: Cardinal;
 
implementation
 
{$R *.dfm}
 
function PositionOK(aLin, aCol : Integer): Boolean;
var
  i: Integer;
begin
  Result := True;
  if aLin = 1 then // it's on the first line, for cryin' out loud :)
    Exit;
 
  for i := 1 to aLin - 1 do // check for attacks on this queen from EVERY other queen on the table
    begin
      if not Result then
        break;
 
      if (abs(aCol - solution[i]) = abs(aLin - i)) or // check diagonally ...
         (aCol = solution[i]) then                    // and vertically
        Result := False;
    end;
end;
 
procedure TForm1.CalculateSolution(aLine: Integer); // recursive backtracking
var i: Integer;
begin
  if MustStop then
    Exit;
  while DoPause do
    Application.ProcessMessages;
 
  if (aLine <= linCount) // while we didn't find a solution
    then
      begin
        for i := 1 to linCount do // iterate through all possible positions on this level
          begin
            if MustStop then
              Exit;
            while DoPause do
              Application.ProcessMessages;
 
            solution[aLine] := i;
            DrawTable(aLine, not PositionOK(aLine, i));
 
            if PositionOK(aLine, i) then // if this position is suitable, use it
              begin
                solution[aLine] := i;
                CalculateSolution(aLine + 1); // and continue looking for the solution
                                              // then we return and continue looking for another solutions
                if MustStop then
                  Exit;
                while DoPause do
                  Application.ProcessMessages;
 
                DrawTable(aLine - 1);
                solution[aLine] := 0;
              end;
          end
      end
    else
      begin // we found a solution !!!
        if MustStop then
          Exit;
        while DoPause do
          Application.ProcessMessages;
 
        inc(solCount);
        lblCountSol.Caption := IntToStr(solCount);
        DrawTable(aLine, False, True);
      end;
end;
 
procedure TForm1.btnStartClick(Sender: TObject);
begin
  btnStart.Enabled := False;
  btnStop.Enabled := True;
  seDame.Enabled := False;
  btnPause.Enabled := True;
  MustStop := False;
  DoPause := False;
 
  lblCountSol.Caption := '0';
  solCount := 0;
  linCount := seDame.Value;
 
  Self.ClientWidth := imgBoard.Left + linCount * imgBackW.Width + 16;
  Self.ClientHeight := imgBoard.Top + linCount * imgBackW.Height + 32;
  imgBoard.Picture := nil;
  imgBoard.Width := linCount * imgBackW.Width;
  imgBoard.Height := linCount * imgBackW.Height;
 
  DrawTable(0);
  CalculateSolution(1);
  DrawTable(0);
 
  lblCountSol.Caption := IntToStr(solCount);
 
  btnStart.Enabled := True;
  btnStop.Enabled := False;
  seDame.Enabled := True;
  btnPause.Enabled := False;
end;
 
procedure TForm1.DrawTable(aCount: Integer; inCheck: Boolean = False; aFinal: Boolean = False);
var
  lin, col: Integer;
begin
  WaitInterval := seWait.Value;
 
  // drawing the chess board
  for lin := 0 to linCount - 1 do
    for col := 0 to linCount - 1 do
      begin
        if odd(lin + col + 1)
          then imgBoard.Canvas.Draw(col * imgBackW.Width, lin * imgBackW.Height, imgBackW.Picture.Graphic)
          else imgBoard.Canvas.Draw(col * imgBackW.Width, lin * imgBackW.Height, imgBackB.Picture.Graphic);
      end;
 
  // draw a red square if the current queen is attacked by a previously set queen
  if inCheck then
    imgBoard.Canvas.Draw((solution[aCount] - 1) * imgBackW.Width, (aCount - 1) * imgBackW.Height, imgCheck.Picture.Graphic);
 
  // drawing the queens
  for lin := 1 to aCount do
    begin
      if (lin < aCount) and (not aFinal)
        then imgBoard.Canvas.Draw((solution[lin] - 1) * imgBackW.Width + 4, (lin - 1) * imgBackW.Height + 4, imgQueenW.Picture.Graphic)
        else imgBoard.Canvas.Draw((solution[lin] - 1) * imgBackW.Width + 4, (lin - 1) * imgBackW.Height + 4, imgQueenB.Picture.Graphic);
    end;
 
  Application.ProcessMessages;
  if aFinal
    then Sleep(WaitInterval * 4)
    else Sleep(WaitInterval);
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  DoubleBuffered := True; // ensure less flickering
end;
 
procedure TForm1.btnStopClick(Sender: TObject);
begin
  MustStop := True;
end;
 
procedure TForm1.btnPauseClick(Sender: TObject);
begin
  DoPause := not DoPause;
end;
 
procedure TForm1.lblCreditsClick(Sender: TObject);
begin
  ShellExecute(Handle, 'open', 'http://www.bitcell.info', nil, nil, SW_SHOWNORMAL);
end;
 
end.

Pentru mai multe informatii despre aceasta problema, aruncati un ochi pe Wikipedia.

Sursa (imagini incluse) si executabilul in atasament.

Bafta

BitCell

Problema damelor

Problema damelor

Who is online