domains
queen    = q(integer, integer)
queens   = queen*
freelist = integer*
board    = board(queens, freelist, freelist, freelist, freelist)
facts - counter
single counter(integer)
predicates
nondeterm placeN(integer,board,board)
nondeterm place_a_queen(integer,board,board)
nondeterm nqueens(integer SizeOfBoard,integer NumberOfQ)
nondeterm makelist(integer, freelist)
nondeterm findandremove(integer, freelist, freelist)
nextrow(integer, freelist, freelist)
nondeterm rows(integer, freelist, freelist)

clauses
nqueens(N,Q):- 
    makelist(N,L),
    Diagonal=N*2-1,
    makelist(Diagonal,LL),
    rows(Q,L,Rows),
    placeN(N,board([],Rows,L,LL,LL),Final),
    Final=board(Queens,_,_,_,_),
    write(Queens),nl,
    counter(I),I1=I+1,assert(counter(I1)),
    fail;
    true.

placeN(_,board(D,[],L,D1,D2),board(D,[],L,D1,D2)):- !.
placeN(N,Board1,Result):- 
    place_a_queen(N,Board1,Board2),
    placeN(N,Board2,Result).

place_a_queen(N,board(Queens,Rows,Columns,Diag1,Diag2),
         board([q(R,C)|Queens],NewR,NewC,NewD1,NewD2)):-
    nextrow(R,Rows,NewR),
    findandremove(C,Columns,NewC),D1=N+C-R,
    findandremove(D1,Diag1,NewD1),D2=R+C-1,
    findandremove(D2,Diag2,NewD2).

findandremove(X,[X|Rest],Rest).
findandremove(X,[Y|Rest],[Y|Tail]):- findandremove(X,Rest,Tail).

makelist(1,[1]).
makelist(N,[N|Rest]):- N>1,N1=N-1, makelist(N1,Rest).

nextrow(Row,[Row|Rest],Rest).

rows(0,_,[]).
rows(N,[R|L],[R|S]):- N1=N-1,rows(N1,L,S).
rows(N,[_|L],S):- N>0,rows(N,L,S).

counter(0).
goal
nqueens(4,2),counter(N),write(N),exit.

program Ferzi;

{$APPTYPE CONSOLE}

uses
  SysUtils;

const
  Ferz = '*';
  Empty = '1';
  War = '0';
  N=4;

type
  TDoska = array[1..N, 1..N] of char;

var
  Count: word;
  Dos: TDoska;

function SetFerz(D: TDoska; i,k: word): TDoska;
var
  i1,k1: word;
begin
  result := D;
  if (i>N)or(k>N) then exit;
  if result[i,k]<>Empty then exit;
  for i1:=1 to n do
    for k1:=1 to n do
      begin
        if result[i1,k1]=Empty then
        begin
          if (i1 = i)or(k1 = k) then result[i1,k1] := War;
          if (i1-i=k1-k) then result[i1,k1] := War;
          if (k1+i1=i+k) then result[i1,k1] := War;
        end;
      end;
  result[i,k] := Ferz;
end;

procedure ShowDoska(D: TDoska);
var
  i,k: word;
begin
  for i := 1 to n do
    begin
      writeln;
      for k:=1 to n do
      write(D[i,k]:2);
    end;
 writeln;
end;

procedure Perestanovka(D: TDoska; h, c: integer);
var
  i,k: word;
begin
  if c = N then
    begin
      ShowDoska(D);
      inc(Count);
    end;
  for k := 1 to N do
    begin
      if h < N then
      if D[h+1,k]=Empty then
      Perestanovka(SetFerz(D,h+1,k),h+1,c+1);
    end;
end;

begin
  FillChar(Dos,sqr(N),Empty);
  Perestanovka(Dos, 0, 0);
  writeln(#13#10,Count);
  readln;
end.