Prolog Round-robin schedule Home and Away - prolog

I'm currently trying to program a round robin schedule in Prolog and have managed to get all teams to play each other once, I would now like to program it such that all teams play each other twice, both home and away, e.g. [1, 2] and [2, 1]. The code I have so far is as follows:
%table of allocated matches
:- dynamic(match_table/2).
%get all teams from 1 .. NumTeams
forTeams(T, T, X) :-
T =< X.
forTeams(I, T, X) :-
T < X,
T1 is T + 1,
forTeams(I, T1, X).
%teams represented by integers more than 1
check_num_input(T) :-
integer(T),
T > 1.
%resets the allocation table of matches
reset_allocations :-
retractall(match_table(_, _)).
%check the match has not already been allocated
%empty list for once recursion is complete
check_not_allocated(_, []).
%recursively search through allocation list to see if team is allocated
check_not_allocated(T, [X | CurrentMatchesTail]) :-
\+ match_table(T, X),
\+ match_table(X, T),
check_not_allocated(T, CurrentMatchesTail).
%recursively fetch match allocation
get_match_allocation(_, 0, CurrentMatches, CurrentMatches).
get_match_allocation(NumTeams, RemainingNumTeamsPerMatch, CurrentMatches,
Matches) :-
RemainingNumTeamsPerMatch > 0,
forTeams(T, 1, NumTeams),
\+ member(T, CurrentMatches),
check_not_allocated(T, CurrentMatches),
append(CurrentMatches, [T], NewMatches),
Remaining1 is RemainingNumTeamsPerMatch - 1,
get_match_allocation(NumTeams, Remaining1, NewMatches, Matches).
%recursively store/ add matches into allocation list
store_allocation_1(_, []).
store_allocation_1(T, [X | MatchesTail]) :-
assertz(match_table(T, X)),
store_allocation_1(T, MatchesTail).
%recursively store allocation from match list
store_allocation([_]).
store_allocation([T | MatchesTail]) :-
store_allocation_1(T, MatchesTail),
store_allocation(MatchesTail).
%recursively check all required matches are allocated
check_plays_all(_, []).
check_plays_all(T, [Team | TeamsTail]) :-
%check head team from teams list plays next head team from remaining
teams list
( match_table(T, Team)
; match_table(Team, T)
),
check_plays_all(T, TeamsTail).
check_all_play_all([_]).
%get head team of teams list
check_all_play_all([T | TeamsTail]) :-
check_plays_all(T, TeamsTail),
check_all_play_all(TeamsTail).
do_round_robin(NumTeams, _, T, []) :-
T > NumTeams.
do_round_robin(NumTeams, NumTeamsPerMatch, T, [Matches | MatchesTail]) :-
T =< NumTeams,
get_match_allocation(NumTeams, NumTeamsPerMatch, [T], Matches),
!,
store_allocation(Matches),
do_round_robin(NumTeams, NumTeamsPerMatch, T, MatchesTail).
do_round_robin(NumTeams, NumTeamsPerMatch, T, Matches) :-
T =< NumTeams,
T1 is T + 1,
do_round_robin(NumTeams, NumTeamsPerMatch, T1, Matches).
round_robin(NumTeams, NumTeamsPerMatch, Matches) :-
check_num_input(NumTeams),
check_num_input(NumTeamsPerMatch),
reset_allocations,
NumTeamsPerMatch1 is NumTeamsPerMatch - 1, %1
do_round_robin(NumTeams, NumTeamsPerMatch1, 1, Matches), %(NumTeams, 1,
1, Matches_List)
findall(T, forTeams(T, 1, NumTeams), Teams), %finds all teams from 1 ..
NumTeams
check_all_play_all(Teams),
!,
reset_allocations.
round_robin(_, _, _) :-
reset_allocations,
fail.
To output the schedule where 2 teams play in one game the query is round_robin(6, 2, Schedule). Where 6 is the number of teams and 2 is the amount of teams playing each game.
I'm quite new to Prolog and logic programming so would appreciate the help :)
Thank you,
BD.

Maybe even better?
home_away(N, A-B) :-
between(1, N, A),
between(1, N, B),
A \== B.
This will order all possibilities lexicographically.
?- findall(X, home_away(3, X), Xs).
Xs = [1-2, 1-3, 2-1, 2-3, 3-1, 3-2].
Below the older answers.
Easier to do with between/3.
home_away(N, X) :-
succ(N0, N), between(1, N0, A),
succ(A, A1), between(A1, N, B),
( X = A-B
; X = B-A
).
Now not even choicepoint:
?- home_away(3, X).
X = 1-2 ;
X = 2-1 ;
X = 1-3 ;
X = 3-1 ;
X = 2-3 ;
X = 3-2.
Below you find still older answer.
Your code is really difficult. Maybe this is not useful idea but you can try to give number of teams and get all possible games where each pair of numbers is home-guest.
home_away(N, X) :-
numlist(1, N, Teams),
append(_, [A|T], Teams),
member(B, T),
( X = A-B
; X = B-A
).
Now with this you can give number of teams and you get teams numbered 1,2,...,N as home and away
?- home_away(3, X).
X = 1-2 ;
X = 2-1 ;
X = 1-3 ;
X = 3-1 ;
X = 2-3 ;
X = 3-2 ;
false.
?- bagof(X, home_away(4, X), Xs).
Xs = [1-2, 2-1, 1-3, 3-1, 1-4, 4-1, 2-3, 3-2, 2-4, 4-2, 3-4, 4-3].

Related

Build a new list of elements which appears more than 3 times in old list in Prolog

My main task - build a new list of elements (numbers) that appear in the old list more than three times.
Asking query: res([1,2,2,3,3,3,4,4,4,4,5,5,5,5,5],X).
Expected result: X = [4, 5]
I have a code that counts the number of occurrences of each number:
count(_, [], 0).
count(Num, [H|T], X) :- dif(Num,H), count(Num, T, X).
count(Num, [H|T], X) :- Num = H, count(Num, T, X1), X is X1 + 1.
res(A, X) :- findall(X,count(_,A,X),X).
But it works little bit wrong - it gives X = [0, 5, 4, 3, 2, 1] instead X = [1, 2, 3, 4, 5].
I ignored this problem for while and tried this to finish main task:
count(_, [], 0).
count(Num, [H|T], X) :- dif(Num,H), count(Num, T, X).
count(Num, [H|T], X) :- Num = H, count(Num, T, X1), X is X1 + 1, X<3, X is Num.
res(A, X) :- findall(X,count(_,A,X),X).
But gives strange result: X = [0, 1]
Where i'm wrong? Thank you.
Reusing your first count predicate,
%countElement(Element, List, Nb_Element_in_List)
countElement(_, [], 0).
countElement(Num, [H|T], X) :- dif(Num,H), countElement(Num, T, X).
countElement(Num, [H|T], X) :- Num = H, countElement(Num, T, X1), X is X1 + 1.
Here is the predicate query/1
query(X) :-
L = [1,2,2,3,3,3,4,4,4,4,5,5,5,5,5],
countOneByOne(L, L, [], X).
%countOneByOne(A1,A2,In,Out)
%For each Element of A1, if it satisfies countElement(Element,A2,N) & N>4, is accumulated with In, to give Out
%Out is the list of Elements of A1 that satisfies countElement(Element,A2,N) & N>4, added to In
countOneByOne([], _, X, X).
countOneByOne([H|Xs], L, X1, X2) :-
countElement(H, L, N), N<4, !,
countOneByOne(Xs, L, X1, X2).
countOneByOne([H|Xs], L, X1, X2) :-
removeElement(Xs, H, Ss),
countOneByOne(Ss, L, [H|X1], X2).
%remove(List, Element, List_Without_Element)
removeElement( [], _, []).
removeElement([X|Xs], H, [X|R1]) :-
dif(X,H), removeElement(Xs, H, R1).
removeElement([X|Xs], X, R1) :-
removeElement(Xs, X, R1).
Not an answer but another approach using foldl/4 and the dict of SWI-Prolog.
Whenever I hear "scan through a list to perform a computation with a final result at the end", the appropriate approach is probably the "accumulator idiom". One hands a data structure (the "accumulator") between the calls where something happens with a list element, "accumulating" the result. foldl/N is meant to provide boilerplate code around this.
In this case the accumulator is the SWI_prolog dict accumulating "occurrence counts", which happens at each call to inc_for_key/3. At the end, we just need to select the entries with a high enough occurence count:
filter_occurrences(List,Limit,Reacheds,Finals) :-
foldl(inc_for_key,List,_{},Finals),
findall(Key,(Finals.Key >= Limit),Reacheds).
inc_for_key(Key,DictIn,DictOut) :-
(get_dict(Key,DictIn,X) -> succ(X,XP) ; XP=1),
put_dict(Key,DictIn,XP,DictOut).
Testing using plunit
:- begin_tests(filter_occurrences_less_than_n).
test("filter empty list",true(R == [])) :-
filter_occurrences([],3,R,_).
test("filter nonempty list #1 (limit 3)",true([R,Finals] == [[a,c],foo{a:4,b:2,c:3,d:1,e:1,f:1}])) :-
filter_occurrences([a,b,c,d,c,e,b,a,a,f,a,c],3,R,Finals),
dict_pairs(Finals,foo,_). % Sets the tag of the Finals dict to "foo"
test("filter nonempty list #2 (limit 4)",true([R,Finals] == [[a],foo{a:4,b:2,c:3,d:1,e:1,f:1}])) :-
filter_occurrences([a,b,c,d,c,e,b,a,a,f,a,c],4,R,Finals),
dict_pairs(Finals,foo,_). % Sets the tag of the Finals dict to "foo"
test("filter nonempty list #3 (limit 5)",true([R,Finals] == [[],foo{a:4,b:2,c:3,d:1,e:1,f:1}])) :-
filter_occurrences([a,b,c,d,c,e,b,a,a,f,a,c],5,R,Finals),
dict_pairs(Finals,foo,_). % Sets the tag of the Finals dict to "foo"
:- end_tests(filter_occurrences_less_than_n).
And so:
?- run_tests.
% PL-Unit: filter_occurrences_less_than_n .... done
% All 4 tests passed
true.

Digital root sums of factorisations in prolog

The problem is about adding the multiples of the possible factorizations in the number that is input by the user.
I tried this code.
sum_factors(N,Fs) :-
integer(N) ,
N > 0 ,
setof(F , factor(N,F) , Fs ).
factor(N,F) :-
L is floor(sqrt(N)),
between(1,L,X),
( F = X ; F is N // X),
write(F), write('x'), write(X), write('='),
write(N), nl.
output of my code if i input 24:
1x1=24
24x1=24
2x2=24
12x2=24
3x3=24
8x3=24
4x4=24
6x4=24
Fs = [1, 2, 3, 4, 6, 8, 12, 24].
the correct output if i input 24 should be:
24 = 2x2x2x3
24 = 2x3x4
24 = 2x2x6
24 = 4x6
24 = 3x8
24 = 2x12
24 = 24
Can somebody explain this code line by line for me, and if possible, tell what's i'm missing from the code.
Try this solution, I think now is complete.
% The first ten prime numbers
% You may want include more, use this URL http://primes.utm.edu/lists/small/1000.txt
prime_numbers([2,3,5,7,11,13,17,19,23,29]).
% Find the lower number in a list of numbers that divide a number N
% We asume that the list of numbers is sorted in ascendent order
lower_splitter(N, [H|_], H):- N mod H =:= 0, !.
lower_splitter(N, [_|T], H):- lower_splitter(N, T, H).
% Find factors
factors(1, []):- !.
factors(N, [R|L]):- prime_numbers(P), lower_splitter(N, P, R), N1 is N div R, factors(N1, L).
% Verify is a list contains a subset
sub_set([], []).
sub_set([X|L1], [X|L2]):- sub_set(L1, L2).
sub_set([_|L1], L2):- sub_set(L1, L2).
% Find all subset in the list X.
combinations(X, R):- setof(L, X^sub_set(X, L), R).
% Auxilary predicates
list([]).
list([_|_]).
lt(X,Y):-var(X);var(Y).
lt(X,Y):-nonvar(X),nonvar(Y),X<Y.
difference([],_,[]).
difference(S,[],S):-S\=[].
difference([X|TX],[X|TY],TZ):-
difference(TX,TY,TZ).
difference([X|TX],[Y|TY],[X|TZ]):-
lt(X,Y),
difference(TX,[Y|TY],TZ).
difference([X|TX],[Y|TY],TZ):-
lt(Y,X),
difference([X|TX],TY,TZ).
%Multiply members of a list
multiply([X], X):-!.
multiply([H|T], X):-multiply(T, M), X is M *H.
start(N):- factors(N, L),
setof(R, L^S^T^D^M^(sub_set(L, S),
length(S, T),
T>1,difference(L, S, D),
multiply(S,M),
append(D,[M], R)), F), writeall(N,[L|F]).
writeall(_,[]).
writeall(N,[H|T]):- write(N),write('='),writelist(H),nl, writeall(N,T).
writelist([X]):- write(X).
writelist([X,Y|T]):- write(X),write(x), writelist([Y|T]).
Consult using the start predicate, like this:
?- start(24).
24=2x2x2x3
24=2x2x6
24=2x3x4
24=2x12
24=3x8
24=24

Solution to Smullyan's numerical machines

Here I propose to find a solution to Smullyan's numerical machines as defined here.
Problem statement
They're machines that take a list of digits as input, and transform it to another list of digits following some rules based on the pattern of the input.
Here are the rules of the machine given in the link above, expressed a bit more formally.
Let say M is the machine, and M(X) is the transformation of X.
We define a few rules like this:
M(2X) = X
M(3X) = M(X)2M(X)
M(4X) = reverse(M(X)) // reverse the order of the list.
M(5X) = M(X)M(X)
And anything that does not match any rule is rejected.
Here are a few examples:
M(245) = 45
M(3245) = M(245)2M(245) = 45245
M(43245) = reverse(M(3245)) = reverse(45245) = 54254
M(543245) = M(43245)M(43245) = 5425454254
And the questions are, find X such that:
M(X) = 2
M(X) = X
M(X) = X2X
M(X) = reverse(X)
M(X) = reverse(X2X)reverse(X2X)
Here is a second example a bit more complex with the exhaustive search (especially if I want the first 10 or 100 solutions).
M(1X2) = X
M(3X) = M(X)M(X)
M(4X) = reverse(M(X))
M(5X) = truncate(M(X)) // remove the first element of the list truncate(1234) = 234. Only valid if M(X) has at least 2 elements.
M(6X) = 1M(X)
M(7X) = 2M(X)
Questions:
M(X) = XX
M(X) = X
M(X) = reverse(X)
(Non-)Solutions
Writing a solver in Prolog is pretty straightforward. Except that it's just exhaustive exploration (a.k.a brute force) and may take some time for some set of rules.
I tried but couldn't express this problem in terms of logic constraints with CLP(FD), so I tried CHR (Constraint Handling Rules) to express this in terms of constraints on lists (especially append constraints), but no matter how I express it, it always boils down to an exhaustive search.
Question
Any idea what approach I could take to resolve any problem of this kind in a reasonable amount of time?
Ideally I would like to be able to generate all the solutions shorter than some bound.
Let's look at your "a bit more complex" problem. Exhaustive search works excellently!
Here is a comparison with Серге́й's solution which can be improved significantly by factoring the common goals:
m([1|A], X) :-
A = [_|_],
append(X, [2], A).
m([E | X], Z) :-
m(X, Y),
( E = 3,
append(Y, Y, Z)
; E = 4,
reverse(Y, Z)
; E = 5,
Y = [_ | Z]
; E = 6,
Z = [1 | Y]
; E = 7,
Z = [2 | Y]
).
For query time(findall(_, (question3(X), write(X), nl), _)). I get with B 8.1, SICStus 4.3b8:
Серге́й B tabled 104.542s
Серге́й B 678.394s
false B 16.013s
false B tabled 53.007s
Серге́й SICStus 439.210s
false SICStus 7.990s
Серге́й SWI 1383.678s, 5,363,110,835 inferences
false SWI 44.743s, 185,136,302 inferences
The additional questions are not that difficult to answer. Only SICStus with above m/2 and
call_nth/2:
| ?- time(call_nth( (
length(Xs0,N),append(Xs0,Xs0,Ys),m(Xs0,Ys),
writeq(Ys),nl ), 10)).
[4,3,7,4,3,1,4,3,7,4,3,1,2,4,3,7,4,3,1,4,3,7,4,3,1,2]
[3,4,7,4,3,1,3,4,7,4,3,1,2,3,4,7,4,3,1,3,4,7,4,3,1,2]
[4,3,7,3,4,1,4,3,7,3,4,1,2,4,3,7,3,4,1,4,3,7,3,4,1,2]
[3,4,7,3,4,1,3,4,7,3,4,1,2,3,4,7,3,4,1,3,4,7,3,4,1,2]
[3,5,4,5,3,1,2,2,1,3,5,4,5,3,1,2,3,5,4,5,3,1,2,2,1,3,5,4,5,3,1,2]
[3,5,5,3,4,1,2,1,4,3,5,5,3,4,1,2,3,5,5,3,4,1,2,1,4,3,5,5,3,4,1,2]
[5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2]
[4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2]
[5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2]
[3,5,4,7,4,3,1,_2735,3,5,4,7,4,3,1,2,3,5,4,7,4,3,1,_2735,3,5,4,7,4,3,1,2]
196660ms
| ?- time(call_nth( (
length(Xs0,N),m(Xs0,Xs0),
writeq(Xs0),nl ), 10)).
[4,7,4,3,1,4,7,4,3,1,2]
[4,7,3,4,1,4,7,3,4,1,2]
[5,4,7,4,3,1,_2371,5,4,7,4,3,1,2]
[4,7,4,5,3,1,_2371,4,7,4,5,3,1,2]
[5,4,7,3,4,1,_2371,5,4,7,3,4,1,2]
[3,5,4,7,4,1,2,3,5,4,7,4,1,2]
[4,3,7,4,5,1,2,4,3,7,4,5,1,2]
[3,4,7,4,5,1,2,3,4,7,4,5,1,2]
[4,7,5,3,6,4,1,4,7,5,3,6,4,2]
[5,4,7,4,3,6,1,5,4,7,4,3,6,2]
6550ms
| ?- time(call_nth( (
length(Xs0,N),reverse(Xs0,Ys),m(Xs0,Ys),
writeq(Ys),nl ), 10)).
[2,1,3,4,7,1,3,4,7]
[2,1,4,3,7,1,4,3,7]
[2,1,3,5,4,7,_2633,1,3,5,4,7]
[2,1,5,4,7,3,2,1,5,4,7,3]
[2,4,6,3,5,7,1,4,6,3,5,7]
[2,6,3,5,4,7,1,6,3,5,4,7]
[2,_2633,1,5,3,4,7,_2633,1,5,3,4,7]
[2,_2633,1,5,4,3,7,_2633,1,5,4,3,7]
[2,1,3,4,4,4,7,1,3,4,4,4,7]
[2,1,3,4,5,6,7,1,3,4,5,6,7]
1500ms
Here is another improvement to #Celelibi's improved version (cele_n). Roughly, it gets a factor of two by constraining the length of the first argument, and another factor of two by pretesting the two versions.
cele_n SICStus 2.630s
cele_n SWI 12.258s 39,546,768 inferences
cele_2 SICStus 0.490s
cele_2 SWI 2.665s 9,074,970 inferences
appendh([], [], Xs, Xs).
appendh([_, _ | Ws], [X | Xs], Ys, [X | Zs]) :-
appendh(Ws, Xs, Ys, Zs).
m([H|A], X) :-
A = [_|_], % New
m(H, X, A).
m(1, X, A) :-
append(X, [2], A).
m(3, X, A) :-
appendh(X, B, B, X),
m(A, B).
m(4, X, A) :-
reverse(X, B),
m(A, B).
m(5, X, A) :-
X = [_| _],
m(A, [_|X]).
m(H1, [H2 | B], A) :-
\+ \+ ( H2 = 1 ; H2 = 2 ), % New
m(A, B),
( H1 = 6, H2 = 1
; H1 = 7, H2 = 2
).
answer3(X) :-
between(1, 13, N),
length(X, N),
reverse(X, A),
m(X, A).
run :-
time(findall(X, (answer3(X), write(X), nl), _)).
I propose here another solution which is basically exhaustive exploration. Given the questions, if the length of the first argument of m/2 is known, the length of the second is known as well. If the length of the second argument is always known, this can be used to cut down the search earlier by propagating some constraints down to the recursive calls. However, this is not compatible with the optimization proposed by false.
appendh([], [], Xs, Xs).
appendh([_, _ | Ws], [X | Xs], Ys, [X | Zs]) :-
appendh(Ws, Xs, Ys, Zs).
m([1 | A], X) :-
append(X, [2], A).
m([3 | A], X) :-
appendh(X, B, B, X),
m(A, B).
m([4 | A], X) :-
reverse(X, B),
m(A, B).
m([5 | A], X) :-
B = [_, _ | _],
B = [_ | X],
m(A, B).
m([H1 | A], [H2 | B]) :-
m(A, B),
( H1 = 6, H2 = 1
; H1 = 7, H2 = 2
).
answer3(X) :-
between(1, 13, N),
length(X, N),
reverse(X, A),
m(X, A).
Here is the time taken respectively by: this code, this code when swapping recursive calls with the constraints of each case (similar to solution of Sergey Dymchenko), and the solution of false which factor the recursive calls. The test is run on SWI and search for all the solution whose length is less or equal to 13.
% 36,380,535 inferences, 12.281 CPU in 12.315 seconds (100% CPU, 2962336 Lips)
% 2,359,464,826 inferences, 984.253 CPU in 991.474 seconds (99% CPU, 2397214 Lips)
% 155,403,076 inferences, 47.799 CPU in 48.231 seconds (99% CPU, 3251186 Lips)
All measures are performed with the call:
?- time(findall(X, (answer3(X), writeln(X)), _)).
(I assume that this is about a list of digits, as you suggest. Contrary to the link you gave, which talks about numbers. There might be differences with leading zeros. I did not take the time to think that through)
First of all, Prolog is an excellent language to search brute force. For, even in that case, Prolog is able to mitigate combinatorial explosion. Thanks to the logic variable.
Your problem statements are essentially existential statements: Does there exist an X such that such and such is true. That's where Prolog is best at. The point is the way how you are asking the question. Instead of asking with concrete values like [1] and so on, simply ask for:
?- length(Xs, N), m(Xs,Xs).
Xs = [3,2,3], N = 3
; ... .
And similarly for the other queries. Note that there is no need to settle for concrete values! This makes the search certainly more expensive!
?- length(Xs, N), maplist(between(0,9),Xs), m(Xs,Xs).
Xs = [3,2,3], N = 3
; ... .
In this manner it is quite efficiently possible to find concrete solutions, should they exist. Alas, we cannot decide that a solution does not exist.
Just to illustrate the point, here is the answer for the "most complex" puzzle:
?- length(Xs0,N),
append(Xs0,[2|Xs0],Xs1),reverse(Xs1,Xs2),append(Xs2,Xs2,Xs3), m(Xs0,Xs3).
Xs0 = [4, 5, 3, 3, 2, 4, 5, 3, 3], N = 9, ...
; ... .
It comes up in no time. However, the query:
?- length(Xs0,N), maplist(between(0,9),Xs0),
append(Xs0,[2|Xs0],Xs1),reverse(Xs1,Xs2),append(Xs2,Xs2,Xs3), m(Xs0,Xs3).
is still running!
The m/2 I used:
m([2|Xs], Xs).
m([3|Xs0], Xs) :-
m(Xs0,Xs1),
append(Xs1,[2|Xs1], Xs).
m([4|Xs0], Xs) :-
m(Xs0, Xs1),
reverse(Xs1,Xs).
m([5|Xs0],Xs) :-
m(Xs0,Xs1),
append(Xs1,Xs1,Xs).
The reason why this is more effective is simply that a naive enumeration of all n digits has 10n different candidates, whereas Prolog will only search for 3n given by the 3 recursive rules.
Here is yet another optimization: All 3 rules have the very same recursive goal. So why do this thrice, when once is more than enough:
m([2|Xs], Xs).
m([X|Xs0], Xs) :-
m(Xs0,Xs1),
( X = 3,
append(Xs1,[2|Xs1], Xs)
; X = 4,
reverse(Xs1,Xs)
; X = 5,
append(Xs1,Xs1,Xs)
).
For the last query, this reduces from 410,014 inferences, 0.094s CPU down to 57,611 inferences, 0.015s CPU.
Edit: In a further optimization the two append/3 goals can be merged:
m([2|Xs], Xs).
m([X|Xs0], Xs) :-
m(Xs0,Xs1),
( X = 4,
reverse(Xs1,Xs)
; append(Xs1, Xs2, Xs),
( X = 3, Xs2 = [2|Xs1]
; X = 5, Xs2 = Xs1
)
).
... which further reduces execution to 39,096 inferences and runtime by 1ms.
What else can be done? The length is bounded by the length of the "input". If n is the length of the input, then 2(n-1)-1 is the longest output. Is this helping somehow? Probably not.
Tabling (memoization) can help with harder variants of the problem.
Here is my implementation for the third question of second example in B-Prolog (returns all solutions of length 13 or less):
:- table m/2.
m(A, X) :-
append([1 | X], [2], A).
m([3 | X], Z) :-
m(X, Y),
append(Y, Y, Z).
m([4 | X], Z) :-
m(X, Y),
reverse(Y, Z).
m([5 | X], Z) :-
m(X, Y),
Y = [_ | Z].
m([6 | X], Z) :-
m(X, Y),
Z = [1 | Y].
m([7 | X], Z) :-
m(X, Y),
Z = [2 | Y].
question3(X) :-
between(1, 13, N),
length(X, N),
reverse(X, Z), m(X, Z).
Run:
B-Prolog Version 8.1, All rights reserved, (C) Afany Software 1994-2014.
| ?- cl(smullyan2).
cl(smullyan2).
Compiling::smullyan2.pl
compiled in 2 milliseconds
loading...
yes
| ?- time(findall(_, (question3(X), writeln(X)), _)).
time(findall(_, (question3(X), writeln(X)), _)).
[7,3,4,1,7,3,4,1,2]
[7,4,3,1,7,4,3,1,2]
[3,7,4,5,1,2,3,7,4,5,1,2]
[7,4,5,3,1,_678,7,4,5,3,1,2]
[7,4,5,3,6,1,7,4,5,3,6,2]
[7,5,3,6,4,1,7,5,3,6,4,2]
[4,4,7,3,4,1,4,4,7,3,4,1,2]
[4,4,7,4,3,1,4,4,7,4,3,1,2]
[5,6,7,3,4,1,5,6,7,3,4,1,2]
[5,6,7,4,3,1,5,6,7,4,3,1,2]
[5,7,7,3,4,1,5,7,7,3,4,1,2]
[5,7,7,4,3,1,5,7,7,4,3,1,2]
[7,3,4,4,4,1,7,3,4,4,4,1,2]
[7,3,4,5,1,_698,7,3,4,5,1,_698,2]
[7,3,4,5,6,1,7,3,4,5,6,1,2]
[7,3,4,5,7,1,7,3,4,5,7,1,2]
[7,3,5,6,4,1,7,3,5,6,4,1,2]
[7,3,5,7,4,1,7,3,5,7,4,1,2]
[7,3,6,5,4,1,7,3,6,5,4,1,2]
[7,4,3,4,4,1,7,4,3,4,4,1,2]
[7,4,3,5,1,_698,7,4,3,5,1,_698,2]
[7,4,3,5,6,1,7,4,3,5,6,1,2]
[7,4,3,5,7,1,7,4,3,5,7,1,2]
[7,4,4,3,4,1,7,4,4,3,4,1,2]
[7,4,4,4,3,1,7,4,4,4,3,1,2]
[7,4,5,6,3,1,7,4,5,6,3,1,2]
[7,4,5,7,3,1,7,4,5,7,3,1,2]
[7,5,6,3,4,1,7,5,6,3,4,1,2]
[7,5,6,4,3,1,7,5,6,4,3,1,2]
[7,5,7,3,4,1,7,5,7,3,4,1,2]
[7,5,7,4,3,1,7,5,7,4,3,1,2]
[7,6,5,3,4,1,7,6,5,3,4,1,2]
[7,6,5,4,3,1,7,6,5,4,3,1,2]
CPU time 25.392 seconds.
yes
So it's less than a minute for this particular problem.
I don't think constraint programming will be of any help with this type of problem, especially with "find 20 first solutions" variant.
Update: running times of the same program on my computer on different systems:
B-Prolog 8.1 with tabling: 26 sec
B-Prolog 8.1 without tabling: 128 sec
ECLiPSe 6.1 #187: 122 sec
SWI-Prolog 6.2.6: 330 sec

Factors of a number

So I am relatively new to Prolog, and while this problem is easy in many other languages I am having a lot of trouble with it. I want to generate a List of factors for a number N. I have already built a predicate that tells me if a number is a factor:
% A divides B
% A is a factor of B
divides(A,B) :- A =\= 0, (B mod A) =:= 0.
% special case where 1 // 2 would be 0
factors(1,[1]) :- !.
% general case
factors(N,L):- N > 0, factor_list(1, N, L).
factor_list(S,E,L) :- S =< E // 2, f_list(S,E,L).
f_list(S,E,[]) :- S > E // 2, !.
f_list(S,E,[S|T]) :- divides(S,E), !, S1 is S+1, f_list(S1, E, T).
f_list(S,E,L) :- S1 is S+1, f_list(S1,E,L).
Any help would be appreciated.
EDIT
I pretty much changed my entire solution, but for some reason predicates like factors(9, [1]) return true, when I only want factors(9, [1,3]) to return true. Any thoughts?
Here's why factors(9,[1]) is true: the timing of attempted instantiations (that is to say, unifications) is off:
f_list(S,E,[]) :- S > E // 2, !.
f_list(S,E,[S|T]) :- divides(S,E), !, S1 is S+1, f_list(S1, E, T).
f_list(S,E,L) :- S1 is S+1, f_list(S1,E,L).
%% flist(1,9,[1]) -> (2nd clause) divides(1,9), S1 is 2, f_list(2,9,[]).
%% flist(2,9,[]) -> (3rd clause) S1 is 3, f_list(3,9,[]).
%% ...
%% flist(5,9,[]) -> (1st clause) 5 > 9 // 2, !.
because you pre-specify [1], when it reaches 3 the tail is [] and the match with the 2nd clause is prevented by this, though it would succeed due to divides/2.
The solution is to move the unifications out of clauses' head into the body, and make them only at the appropriate time, not sooner:
f_list(S,E,L) :- S > E // 2, !, L=[].
f_list(S,E,L) :- divides(S,E), !, L=[S|T], S1 is S+1, f_list(S1, E, T).
f_list(S,E,L) :- S1 is S+1, f_list(S1,E,L).
The above usually is written with the if-else construct:
f_list(S,E,L) :-
( S > E // 2 -> L=[]
; divides(S,E) -> L=[S|T], S1 is S+1, f_list(S1, E, T)
; S1 is S+1, f_list(S1, E, L)
).
Also you can simplify the main predicate as
%% is not defined for N =< 0
factors(N,L):-
( N =:= 1 -> L=[1]
; N >= 2 -> f_list(1,N,L)
).
Personally, I use a somewhat simpler looking solution:
factors(1,[1]):- true, !.
factors(X,[Factor1|T]):- X > 0,
between(2,X,Factor1),
NewX is X // Factor1, (X mod Factor1) =:= 0,
factors(NewX,T), !.
This one only accepts an ordered list of the factors.
Here is a simple enumeration based procedure.
factors(M, [1 | L]):- factors(M, 2, L).
factors(M, X, L):-
residue(M, X, M1),
((M==M1, L=L1); (M1 < M, L=[X|L1])),
((M1=1, L1=[]); (M1 > X, X1 is X+1, factors(M1, X1, L1))).
residue(M, X, M1):-
((M < X, M1=M);
(M >=X, MX is M mod X,
(MX=0, MM is M/X, residue(MM, X, M1);
MX > 0, M1=M))).

Prolog Programming

I have made two programs in Prolog for the nqueens puzzle using hill climbing and beam search algorithms.
Unfortunately I do not have the experience to check whether the programs are correct and I am in dead end.
I would appreciate if someone could help me out on that.
Unfortunately the program in hill climbing is incorrect. :(
The program in beam search is:
queens(N, Qs) :-
range(1, N, Ns),
queens(Ns, [], Qs).
range(N, N, [N]) :- !.
range(M, N, [M|Ns]) :-
M < N,
M1 is M+1,
range(M1, N, Ns).
queens([], Qs, Qs).
queens(UnplacedQs, SafeQs, Qs) :-
select(UnplacedQs, UnplacedQs1,Q),
not_attack(SafeQs, Q),
queens(UnplacedQs1, [Q|SafeQs], Qs).
not_attack(Xs, X) :-
not_attack(Xs, X, 1).
not_attack([], _, _) :- !.
not_attack([Y|Ys], X, N) :-
X =\= Y+N,
X =\= Y-N,
N1 is N+1,
not_attack(Ys, X, N1).
select([X|Xs], Xs, X).
select([Y|Ys], [Y|Zs], X) :- select(Ys, Zs, X).
I would like to mention this problem is a typical constraint satisfaction problem and can be efficiency solved using the CSP module of SWI-Prolog. Here is the full algorithm:
:- use_module(library(clpfd)).
queens(N, L) :-
N #> 0,
length(L, N),
L ins 1..N,
all_different(L),
applyConstraintOnDescDiag(L),
applyConstraintOnAscDiag(L),
label(L).
applyConstraintOnDescDiag([]) :- !.
applyConstraintOnDescDiag([H|T]) :-
insertConstraintOnDescDiag(H, T, 1),
applyConstraintOnDescDiag(T).
insertConstraintOnDescDiag(_, [], _) :- !.
insertConstraintOnDescDiag(X, [H|T], N) :-
H #\= X + N,
M is N + 1,
insertConstraintOnDescDiag(X, T, M).
applyConstraintOnAscDiag([]) :- !.
applyConstraintOnAscDiag([H|T]) :-
insertConstraintOnAscDiag(H, T, 1),
applyConstraintOnAscDiag(T).
insertConstraintOnAscDiag(_, [], _) :- !.
insertConstraintOnAscDiag(X, [H|T], N) :-
H #\= X - N,
M is N + 1,
insertConstraintOnAscDiag(X, T, M).
N is the number of queens or the size of the board (), and , where , being the position of the queen on the line .
Let's details each part of the algorithm above to understand what happens.
:- use_module(library(clpfd)).
It indicates to SWI-Prolog to load the module containing the predicates for constraint satisfaction problems.
queens(N, L) :-
N #> 0,
length(L, N),
L ins 1..N,
all_different(L),
applyConstraintOnDescDiag(L),
applyConstraintOnAscDiag(L),
label(L).
The queens predicate is the entry point of the algorithm and checks if the terms are properly formatted (number range, length of the list). It checks if the queens are on different lines as well.
applyConstraintOnDescDiag([]) :- !.
applyConstraintOnDescDiag([H|T]) :-
insertConstraintOnDescDiag(H, T, 1),
applyConstraintOnDescDiag(T).
insertConstraintOnDescDiag(_, [], _) :- !.
insertConstraintOnDescDiag(X, [H|T], N) :-
H #\= X + N,
M is N + 1,
insertConstraintOnDescDiag(X, T, M).
It checks if there is a queen on the descendant diagonal of the current queen that is iterated.
applyConstraintOnAscDiag([]) :- !.
applyConstraintOnAscDiag([H|T]) :-
insertConstraintOnAscDiag(H, T, 1),
applyConstraintOnAscDiag(T).
insertConstraintOnAscDiag(_, [], _) :- !.
insertConstraintOnAscDiag(X, [H|T], N) :-
H #\= X - N,
M is N + 1,
insertConstraintOnAscDiag(X, T, M).
Same as previous, but it checks if there is a queen on the ascendant diagonal.
Finally, the results can be found by calling the predicate queens/2, such as:
?- findall(X, queens(4, X), L).
L = [[2, 4, 1, 3], [3, 1, 4, 2]]
If I read your code correctly, the algorithm you're trying to implement is a simple depth-first search rather than beam search. That's ok, because it should be (I don't see how beam search will be effective for this problem and it can be hard to program).
I'm not going to debug this code for you, but I will give you a suggestion: build the chess board bottom-up with
queens(0, []).
queens(N, [Q|Qs]) :-
M is N-1,
queens(M, Qs),
between(1, N, Q),
safe(Q, Qs).
where safe(Q,Qs) is true iff none of Qs attack Q. safe/2 is then the conjunction of a simple memberchk/2 check (see SWI-Prolog manual) and your not_attack/2 predicate, which on first sight seems to be correct.
A quick check on Google has found a few candidates for you to compare with your code and find what to change.
My favoured solution for sheer clarity would be the second of the ones linked to above:
% This program finds a solution to the 8 queens problem. That is, the problem of placing 8
% queens on an 8x8 chessboard so that no two queens attack each other. The prototype
% board is passed in as a list with the rows instantiated from 1 to 8, and a corresponding
% variable for each column. The Prolog program instantiates those column variables as it
% finds the solution.
% Programmed by Ron Danielson, from an idea by Ivan Bratko.
% 2/17/00
queens([]). % when place queen in empty list, solution found
queens([ Row/Col | Rest]) :- % otherwise, for each row
queens(Rest), % place a queen in each higher numbered row
member(Col, [1,2,3,4,5,6,7,8]), % pick one of the possible column positions
safe( Row/Col, Rest). % and see if that is a safe position
% if not, fail back and try another column, until
% the columns are all tried, when fail back to
% previous row
safe(Anything, []). % the empty board is always safe
safe(Row/Col, [Row1/Col1 | Rest]) :- % see if attack the queen in next row down
Col =\= Col1, % same column?
Col1 - Col =\= Row1 - Row, % check diagonal
Col1 - Col =\= Row - Row1,
safe(Row/Col, Rest). % no attack on next row, try the rest of board
member(X, [X | Tail]). % member will pick successive column values
member(X, [Head | Tail]) :-
member(X, Tail).
board([1/C1, 2/C2, 3/C3, 4/C4, 5/C5, 6/C6, 7/C7, 8/C8]). % prototype board
The final link, however, solves it in three different ways so you can compare against three known solutions.

Resources