/******************************************************************
 Example B-Prolog programs Neng-Fa Zhou posted to comp.lang.prolog
******************************************************************/

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% L=[1,2,3,...,N]
% Posted July 23, 2011
create_list(N,L) :- L @= [I : I in 1..N]. 


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Cartesian product of lists Options 
% Posted July 1, 2011
cartprod([L1,L2],R):-!, 
    R @= [[X1,X2] : X1 in L1, X2 in L2]. 
cartprod([L|Ls],R):- 
    cartprod(Ls,R1), 
    R @= [[X|P] : X in L, P in R1]. 

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% All possible pairs
% Posted Nov. 25, 2010
all_pairs(List,Pairs):-
    Pairs @= [[I-J] : I in List, J in List, I<J] 

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% No-three-in-a-line
% Posted March 11, 2010 (reformulated)
/*
On an NxN grid locate markers so that no three are in a line and 
no further marker can be placed without violating that restriction. 
Problem posted by Chip Eastham, March 11, 2010
Program by Neng-Fa Zhou, for B-Prolog version 7.4 and up
*/
go:-
    N=8,
    no3_build(N).

no3_build(N):-
    new_array(Board,[N,N]),
    Vars @= [Board[I,J] : I in 1..N, J in 1..N],
    Vars :: 0..1,
    Sum #= sum(Vars),
    Sum #=< 2*N,
    foreach(X1 in 1..N, Y1 in 1..N, [L,SL],  % L and SL are local
            (L @= [Slope : X2 in 1..N, Y2 in 1..N,
                           [Slope],    % Slope is local
                           (X2\==X1,Slope is (Y2-Y1)/(X2-X1))],
            sort(L,SL),
            foreach(Slope in SL,
                 sum([Board[X,Y] : X in 1..N, Y in 1..N, 
                                  (X\==X1,Slope=:=(Y-Y1)/(X-X1))]) #< 3))),
    foreach(X in 1..N, sum([Board[X,Y] : Y in 1..N])#<3),  
    labeling([down],[Sum|Vars]),
    outputBoard(Board,Sum,N).

outputBoard(Board,Sum,N):-
    writeln(marks=Sum),
    foreach(I in 1..N,[Row],
            (Row @= [Board[I,J] : J in 1..N], writeln(Row))).


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Formulating and Solving the Farmer's Dilemma Options 
% Posted Aug. 17, 2010
/*********************************************************** 
taken from "Extension Table Built-ins for Prolog", 
by Chang-Guan Fa & Suzanne W. Dietrich 
Software Practive and Experience, Vol22, No.7, 573-597, 1992. 
Modified by Neng-Fa Zhou for B-Prolog 
***********************************************************/ 

go:- 
    cputime(Start), 
    state(s,s,s,s,Path,Len), 
    cputime(End), 
    write(Path),nl, 
    T is End-Start, 
    write('TIME:'),write(T),nl. 


:-table state(+,+,+,+,-,min). 
state(n,n,n,n,Path,Len):-Path=[],Len=0. 
state(F,F,G,C,Path,Len):- 
    safe(F,F,G,C), 
    Path=[takes(farmer,wolf)|Path1], 
    opp(F,F1), 
    state(F1,F1,G,C,Path1,Len1), 
    Len is Len1+1. 
state(F,W,F,C,Path,Len):- 
    safe(F,W,F,C), 
    Path=[takes(farmer,goat)|Path1], 
    opp(F,F1), 
    state(F1,W,F1,C,Path1,Len1), 
    Len is Len1+1. 
state(F,W,G,F,Path,Len):- 
    safe(F,W,G,F), 
    Path=[takes(farmer,cabbage)|Path1], 
    opp(F,F1), 
    state(F1,W,G,F1,Path1,Len1), 
    Len is Len1+1. 
state(F,W,G,C,Path,Len):- 
    safe(F,W,G,C), 
    Path=[go_alone(farmer)|Path1], 
    opp(F,F1), 
    state(F1,W,G,C,Path1,Len1), 
    Len is Len1+1. 


opp(n,s). 
opp(s,n). 


safe(F,W,F,C). 
safe(F,F,G,F):- 
    opp(F,G). 


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/* 
    Triangularize a given matrix (for B-Prolog 7.4 and up). 
    by Neng-Fa Zhou, Feb. 16, 2010 
*/ 
triangle_matrix(Matrix):- 
    foreach(I in 1..Matrix^length-1, 
          [Row,J],                              % Row and J are local 
          (select_nonzero_row(I,I,Matrix,J)-> 
              (I\==J->(Row @= Matrix[I],        % swap row I and J 
                   Matrix[I] @:= Matrix[J], 
                   Matrix[J] @:= Row) 
                ; 
                    true 
                ), 
               foreach(K in I+1..Matrix^length,trans_row(I,K,Matrix)) 
            ; 
               true 
             )). 


% select a row J where  Matrix[J,I] is not zero 
select_nonzero_row(I,J0,Matrix,J):- 
    Matrix[J0,I]=\=0,!,J=J0. 
select_nonzero_row(I,J0,Matrix,J):- 
    J0 < Matrix^length, 
    J1 is J0+1, 
    select_nonzero_row(I,J1,Matrix,J). 


% transform row K to make Matrix[K,I] zero 
trans_row(I,K,Matrix):- 
    Matrix[K,I]=:=0,!.   % is already zero 
trans_row(I,K,Matrix):- 
    foreach(J in I+1..Matrix[K]^length, 
          [NewCoe], 
          (NewCoe is Matrix[K,J]/Matrix[K,I]-Matrix[I,J]/Matrix[I,I], 
           Matrix[K,J] @:= NewCoe)), 
    Matrix[K,I] @:= 0. 


% It uses destructive updates (@:=) and thus is not so clean, but it 
% should be much faster than your program. Here are some matrices to 
% test on. 


test:- 
    matrix(Ls), 
    lists_to_matrix(Ls,Matrix), 
    triangle_matrix(Matrix), 
    foreach(I in 1..Matrix^length,[Row],(Row@=Matrix[I], 
writeln(Row))), 
    nl,nl, 
    fail. 


lists_to_matrix(Ls,Matrix):- 
    NRows is Ls^length, 
    NCols is Ls[1]^length, 
    new_array(Matrix,[NRows,NCols]), 
    foreach(I in 1..NRows, J in 1..NCols, Matrix[I,J] is Ls[I,J]). 


matrix(M):- 
    M=[[1,1,1,0], 
       [1,-2,2,4], 
       [1,2,-1,2]]. 


matrix(M):- 
    M=[[2,1,-1,8], 
       [-3,-1,2,-11], 
       [-2,1,2,-3]]. 


matrix(M):- 
    M=[[2,-3,-1,2,3,4], 
       [4,-4,-1,4,11,4], 
       [2,-5,-2,2,-1,9], 
       [0,2,1,0,4,-5]]. 

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% quickk sort, permutation generation, queens
% Posted January 5, 2010
qsort([],[]). 
qsort([H|T],S):- 
    L1 @= [X : X in T, X<H], 
    L2 @= [X : X in T, X>=H], 
    qsort(L1,S1), 
    qsort(L2,S2), 
    append(S1,[H|S2],S). 

perms([],[[]]).
perms([X|Xs],Ps):-
    perms(Xs,Ps1),
    Ps @= [P : P1 in Ps1, I in 0..Xs^length,[P],insert(X,I,P1,P)].

% insert(X,I,L1,L): insert X into L1 in Ith position to get L
insert(X,0,L,[X|L]).
insert(X,I,[Y|L1],[Y|L]):-
    I>0,
    I1 is I-1,
    insert(X,I1,L1,L).

queens(N):- 
    length(Qs,N), 
    Qs :: 1..N, 
    foreach(I in 1..N-1, J in I+1..N, 
               (Qs[I] #\= Qs[J], 
                abs(Qs[I]-Qs[J]) #\= J-I)), 
    labeling([ff],Qs), 
    writeln(Qs). 

bool_queens(N):- 
    new_array(Qs,[N,N]), 
    Vars @= [Qs[I,J] : I in 1..N, J in 1..N], 
    Vars :: 0..1, 
    foreach(I in 1..N, 
            sum([Qs[I,J] : J in 1..N]) #= 1), 
    foreach(J in 1..N, 
            sum([Qs[I,J] : I in 1..N]) #= 1), 
    foreach(K in 1-N..N-1, 
            sum([Qs[I,J] : I in 1..N, J in 1..N, I-J=:=K]) #=< 1), 
    foreach(K in 2..2*N, 
            sum([Qs[I,J] : I in 1..N, J in 1..N, I+J=:=K]) #=< 1), 
    labeling(Vars), 
    foreach(I in 1..N,[Row], 
            (Row @= [Qs[I,J] : J in 1..N], writeln(Row))). 

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Magic square
% Posted Nov. 16, 2009 (reformulated)
magicSquare(N):-
    new_array(Board,[N,N]),
    NN is N*N,
    Vars @= [Board[I,J] : I in 1..N, J in 1..N],
    Vars :: 1..NN,
    Sum is NN*(NN+1)//(2*N),
    foreach(I in 1..N,sum([Board[I,J] : J in 1..N]) #= Sum),
    foreach(J in 1..N,sum([Board[I,J] : I in 1..N]) #= Sum),
    sum([Board[I,I] : I in 1..N]) #= Sum,
    sum([Board[I,N-I+1] : I in 1..N]) #= Sum,
    all_different(Vars),
    labeling([ffc],Vars),
    foreach(I in 1..N, 
	    (foreach(J in 1..N, [Bij], (Bij @= Board[I,J], format("~4d ",[Bij]))),nl)).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Shortest path
% Posted Sep. 9, 2009
> My problem now is to find the shortest path between two vertices. 
> Three lines of Prolog solve this  really easy, but the problem arises 
> when I try to find a path between two vertices that are not in the 
> same graph (that means, there is no such path!). It falls in an 
> endless loop. 

:-table sp(+,+,-,min). 
sp(X,Y,[(X,Y)],1):-edge(X,Y). 
sp(X,Y,[(X,Z)|Path],Len):- 
    edge(X,Z), 
    sp(Z,Y,Path,Len1), 
    Len is Len1+1.