const
  MaxBoardSize= 1000;
type
  TSolution= array[0..MaxBoardSize-1] of integer;
var
  BoardSize: integer= 0;
  QueenCount: integer;                             //for completion problem only
  QueenToRow: array[0..MaxBoardSize-1] of integer; //for completion problem only
  CanRow: array[0..MaxBoardSize-1] of boolean;     //for completion problem only
  CanCol: array[0..MaxBoardSize-1] of boolean;
  CanDiagP: array[0..2*MaxBoardSize] of boolean;
  CanDiagM: array[-MaxBoardSize..MaxBoardSize] of boolean;
  RowToCol: TSolution;
  Solution: TSolution;
  SolCount: int64;
  ModCount: int64;

procedure InitBoard(Size: integer= 1);
var
  i: integer;
begin;
  BoardSize:=Size;
  QueenCount:=Size;
  for i:=0 to MaxBoardSize-1 do QueenToRow[i]:=i;
  FillChar(CanRow, SizeOf(CanRow), true);
  FillChar(CanCol, SizeOf(CanCol), true);
  FillChar(CanDiagP, SizeOf(CanDiagP), true);
  FillChar(CanDiagM, SizeOf(CanDiagM), true);
  FillChar(RowToCol, SizeOf(RowToCol), 0);
  SolCount:=0;
  ModCount:=0;
  end;

procedure ReinitBoard(Size: integer);
var
  i: integer;
begin;
  BoardSize:=Size;
  QueenCount:=Size;
  for i:=0 to MaxBoardSize-1 do QueenToRow[i]:=i;
  SolCount:=0;
  ModCount:=0;
  end;

procedure TForm1.DrawGrid1DrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect; State: TGridDrawState);
begin;
  if (ACol<BoardSize)
  and (ARow<BoardSize)
  and (ACol=Solution[ARow])
  then begin;
    TDrawGrid(Sender).Canvas.Brush.Color:=clGray;
    TDrawGrid(Sender).Canvas.FillRect(Rect);
    end;
  end;

procedure ShowFirstSolution;
begin;
  Solution:=RowToCol;
  with Form1.DrawGrid1 do begin;
    ColCount:=BoardSize;
    RowCount:=BoardSize;
    Repaint;
    SetFocus;
    end;
  end;

procedure CountSolution;
var
  i: integer;
begin;
  if SolCount=0 then ShowFirstSolution;
  inc(SolCount); //total
  for i:=0 to BoardSize-1 do
    if (CanDiagP[i]=CanDiagP[i+BoardSize])
    or (CanDiagM[i]=CanDiagM[i-BoardSize]) then exit;
  if ModCount=0 then ShowFirstSolution;
  inc(ModCount); //modular
  end;

procedure PushColRow(Col, Row: integer);
begin;
  RowToCol[Row]:=Col;
  CanCol[Col]:=false;
  CanDiagP[Col+Row]:=false;
  CanDiagM[Col-Row]:=false;
  end;

procedure PopColRow(Col, Row: integer);
begin;
  CanCol[Col]:=true;
  CanDiagP[Col+Row]:=true;
  CanDiagM[Col-Row]:=true;
  end;

function CanColRow(Col, Row: integer): boolean;
begin;
  Result:=CanCol[Col] and CanDiagP[Col+Row] and CanDiagM[Col-Row];
  end;

procedure BackTrackRecursion(Row: integer);
var
  Col: integer;
begin;
  for Col:=0 to BoardSize-1 do begin;
    if CanColRow(Col, Row) then begin;
      PushColRow(Col, Row);
      if Row>0 then BackTrackRecursion(Row-1) else CountSolution;
      PopColRow(Col, Row);
      end;
    end;
  end;

procedure TForm1.bBackTrackRecursionClick(Sender: TObject);
var
  Size: integer;
  Tick: cardinal;
begin;
  InitBoard;
  for Size:=1 to 16 do begin;
    Tick:=GetTickCount;
    ReinitBoard(Size); BackTrackRecursion(Size-1);
    Tick:=GetTickCount-Tick;
    Memo1.Lines.Add(Format('Size=%d, SolCount=%d, ModCount=%d, Tick=%d',
      [Size, SolCount, ModCount, Tick]));
    end;
  end;

procedure BackTrackIteration;
var
  Col, Row: integer;
begin;
  Row:=BoardSize-1;
  Col:=BoardSize-1;
  while true do begin;
    while Col>=0 do begin;
      if CanCol[Col] and CanDiagP[Col+Row] and CanDiagM[Col-Row] then begin;
        RowToCol[Row]:=Col;
        CanCol[Col]:=false;
        CanDiagP[Col+Row]:=false;
        CanDiagM[Col-Row]:=false;
        if Row>0 then begin;
          dec(Row);
          Col:=BoardSize-1;
          continue;
          end;
        CountSolution;
        CanCol[Col]:=true;
        CanDiagP[Col+Row]:=true;
        CanDiagM[Col-Row]:=true;
        end;
      dec(Col);
      end;
    inc(Row);
    if Row>=BoardSize then break;
    Col:=RowToCol[Row];
    CanCol[Col]:=true;
    CanDiagP[Col+Row]:=true;
    CanDiagM[Col-Row]:=true;
    dec(Col);
    end;
  end;

procedure TForm1.bBackTrackIterationClick(Sender: TObject);
var
  Size: integer;
  Tick: cardinal;
begin;
  InitBoard;
  for Size:=1 to 16 do begin;
    Tick:=GetTickCount;
    ReinitBoard(Size); BackTrackIteration;
    Tick:=GetTickCount-Tick;
    Memo1.Lines.Add(Format('BoardSize=%d, SolCount=%d, ModCount=%d, Tick=%d',
      [BoardSize, SolCount, ModCount, Tick]));
    end;
  end;

procedure BackTrackCompletion;
var
  Col, Row, Queen: integer;
begin;
  Queen:=QueenCount-1;
  Row:=QueenToRow[Queen];
  Col:=BoardSize-1;
  while true do begin;
    while Col>=0 do begin;
      if CanCol[Col] and CanDiagP[Col+Row] and CanDiagM[Col-Row] then begin;
        RowToCol[Row]:=Col;
        CanCol[Col]:=false;
        CanDiagP[Col+Row]:=false;
        CanDiagM[Col-Row]:=false;
        if Queen>0 then begin;
          dec(Queen);
          Row:=QueenToRow[Queen];
          Col:=BoardSize-1;
          continue;
          end;
        CountSolution;
        //exit;                     //comment this statement to calculate all solutions
        CanCol[Col]:=true;
        CanDiagP[Col+Row]:=true;
        CanDiagM[Col-Row]:=true;
        end;
      dec(Col);
      end;
    inc(Queen);
    if Queen>=QueenCount
    then break;
    Row:=QueenToRow[Queen];
    Col:=RowToCol[Row];
    CanCol[Col]:=true;
    CanDiagP[Col+Row]:=true;
    CanDiagM[Col-Row]:=true;
    dec(Col);
    end;
  end;

procedure TForm1.bBackTrackCompletionClick(Sender: TObject);
var
  Size, i, r, c: integer;
  Tick: cardinal;
begin;
  InitBoard(8);

  Tick:=GetTickCount;
  if SetColRow(2, 2)
  and SetColRow(4, 7)
  and (QueenCount>0)
  then BackTrackCompletion;
  Tick:=GetTickCount-Tick;

  Memo1.Lines.Add(Format('BoardSize=%d, SolCount=%d, ModCount=%d, Tick=%d',
    [BoardSize, SolCount, ModCount, Tick]));
  end;