I am currently working on implementing a source-removal topological sorting algorithm for a directed graph. Basically the algorithm goes like this:
Find a node in a graph with no incoming edges
Remove that node and all edges coming out from it and write its value down
Repeat 1 and 2 until you eliminate all nodes
So, for example, the graph
would have a topological sort of a,e,b,f,c,g,d,h. (Note: topological sorts aren't unique and thus there can be a different topological sort as well)
I am currently working on a Prolog implementation of this with the graph being represented in list form as follows:
[ [a,[b,e,f]], [b,[f,g]], [c,[g,d]], [d,[h]], [e,[f]], [f,[]],
[g,[h]], [h,[]] ]
Where the [a, [b,e,f] ] term for example represents the edges going from a to b, e, and f respectively, and the [b, [f,g] ] term represents the edges going from b to f and g. In other words, the first item in the array "tuple" is the "from" node and the following array contains the destinations of edges coming from the "from" node.
I am also operating under assumption that there is one unique name for each vertex and thus when I find it, I can delete it without worrying about any potential duplicates.
I wrote the following code
% depends_on shows that D is adjacent to A, i.e. I travel from A to D on the graph
% returns true if A ----> D
depends_on(G,A,D) :- member([A,Ns],G), member(D,Ns).
% doesnt_depend_on shows that node D doesnt have paths leading to it
doesnt_depend_on(G, D) :- \+ depends_on(G, _, D).
% removes node from a graph with the given value
remove_graph_node([ [D,_] | T], D, T). % base case -- FOUND IT return the tail only since we already popped it
remove_graph_node([ [H,Ns] | T], D, R) :- \+ H=D,remove_graph_node( T, D, TailReturn), append([[H,Ns]], TailReturn, R).
%----------------------------------------------------
source_removal([], []]). % Second parameter is empty list due to risk of a cycle
source_removal(G,Toposort):-member([D,_], G),
doesnt_depend_on(G,D),
remove_graph_node(G,D,SubG),
source_removal(SubG, SubTopoSort),
append([D], SubTopoSort, AppendResult),
Toposort is AppendResult.
And I tested the depends_on, doesnt_depend_on, and remove_graph_node by hand using the graph [ [a,[b,e,f]], [b,[f,g]], [c,[g,d]], [d,[h]], [e,[f]], [f,[]], [g,[h]], [h,[]] ] and manually changing the parameter variables (especially when it comes to node names like a, b, c and etc). I can vouch after extensive testing that they work.
However, my issue is debugging the source_removal command. In it, I repeatedly remove a node with no directed edge pointing towards it along with its outgoing edges and then try to add the node's name to the Toposort list I am building.
At the end of the function's running, I expect to get an array of output like [a,e,b,f,c,g,d,h] for its Toposort parameter. Instead, I got
?- source_removal([ [a,[b,e,f]], [b,[f,g]], [c,[g,d]], [d,[h]], [e,[f]], [f,[]], [g,[h]], [h,[]] ], Result).
false.
I got false as an output instead of the list I am trying to build.
I have spent hours trying to debug the source_removal function but failed to come up with anything. I would greatly appreciate it if anyone would be willing to take a look at this with a different pair of eyes and help me figure out what the issue in the source_removal function is. I would greatly appreciate it.
Thanks for the time spent reading this post and in advance.
The first clause for source_removal/2 contained a typo (one superfluous closing square bracket).
The last line for the second clause in your code says Toposort is AppendResult. Note that is is used in Prolog to denote the evaluation of an arithmetic expression, e.g., X is 3+4 yields X = 7 (instead of just unifying variable X with the term 3+4). When I change that line to use = (assignment, more precisely unification) instead of is (arithmetic evaluation) like so
source_removal([], []). % Second parameter is empty list due to risk of a cycle
source_removal(G,Toposort):-member([D,_], G),
doesnt_depend_on(G,D),
remove_graph_node(G,D,SubG),
source_removal(SubG, SubTopoSort),
append([D], SubTopoSort, AppendResult),
Toposort = AppendResult.
I get the following result:
?- source_removal([ [a,[b,e,f]], [b,[f,g]], [c,[g,d]], [d,[h]], [e,[f]], [f,[]], [g,[h]], [h,[]] ], Result).
Result = [a, b, c, d, e, f, g, h] ;
Result = [a, b, c, d, e, g, f, h] ;
Result = [a, b, c, d, e, g, h, f] ;
Result = [a, b, c, d, g, e, f, h] ;
Result = [a, b, c, d, g, e, h, f] ;
Result = [a, b, c, d, g, h, e, f] ;
Result = [a, b, c, e, d, f, g, h] ;
Result = [a, b, c, e, d, g, f, h] ;
Result = [a, b, c, e, d, g, h, f] ;
Result = [a, b, c, e, f, d, g, h] ;
Result = [a, b, c, e, f, g, d, h] ;
...
Result = [c, d, a, e, b, g, h, f] ;
false.
(Shortened, it shows 140 solutions in total.)
Edit: I didn't check all the solutions, but among the ones it finds is the one you gave in your example ([a,e,b,f,c,g,d,h]), and they look plausible in the sense that each either starts with a or with c.
Related
For some practise; I'm trying to create a program that simulates a maze and shows every possible route between entry and exit. The code creates one of the lists, however it doesn't show both and doesn't stop when it's found them (route 1: entry,a,b,e,f,exit and route 2: entry,a,b,c,d,e,f,exit), and continuously loops into bigger and bigger routes.
% length(X, _), route(entry,exit, X).
%Facts, indicating an adjacent link between one room and another.
link(entry, a).
link(a, b).
link(b, c).
link(c, d).
link(d, e).
link(b, e).
link(e, f).
link(f, c).
link(f, exit).
%Searches for the path in an increasing order of length 'route'.
route(X, Y, [X, Y]) :- link(X,Y).
route(X, Y, [X | TY]) :- link(X, T), route(T, Y, TY).
Example from console:
| ?- route(entry, exit, A).
A = [entry,a,b,c,d,e,f,exit] ;
A = [entry,a,b,c,d,e,f,c,d,e,f,exit] ;
A = [entry,a,b,c,d,e,f,c,d,e,f,c,d,e,f,exit] ;
A = [entry,a,b,c,d,e,f,c,d,e,f,c,d,e,f,c,d,e,f,exit]
Can anyone help me?
The simplest way to make this iterative deepening path search stop from looking for further successes after the first one is to cut at the end of the goal:
?- length(X, _), route(entry,exit, X), !.
X = [entry,a,b,e,f,exit].
Once success brings Prolog's "finger" past the !, any attempt to redo and move the finger back leftwards is disallowed. So Prolog stops after the first success.
For multiple solutions: hopefully there is something like library(solution_sequences) around.
There we have limit(+Count,:Goal):
?- limit(2,route(entry, exit, A)).
A = [entry,a,b,c,d,e,f,exit] ;
A = [entry,a,b,c,d,e,f,c,d,e,f,exit].
The source code for limit, which is written in Prolog. It uses state-changing predicates, but can it be written without those?
1. First path predicate is the base case.
2. Second path predicate searches all possible routes for the given Start and End Node.
link(entry, a).
link(a, b).
link(b, c).
link(c, d).
link(d, e).
link(b, e).
link(e, f).
%link(f, c).
link(f, exit).
path(Node,Node,[Node]):-!.
path(StartN,EndN,[StartN|List]):-
link(StartN,NextN),
path(NextN,EndN,List).
Example:
?-path(entry,exit,Route).
Route = [entry, a, b, c, d, e, f, exit]
Route = [entry, a, b, e, f, exit]
?-path(entry,a,Route).
Route = [entry, a]
?-path(entry,b,Route).
Route = [entry, a, b]
?-path(entry,c,Route).
Route = [entry, a, b, c]
false
?-path(entry,d,Route).
Route = [entry, a, b, c, d]
false
?-path(entry,e,Route).
Route = [entry, a, b, c, d, e]
Route = [entry, a, b, e]
?-path(entry,f,Route).
Route = [entry, a, b, c, d, e, f]
Route = [entry, a, b, e, f]
Note: I had to comment link(f,c) to get the correct route for exit or else it'll give you stack limit exceeded, I'm not sure why.
I need to do an exercise similar to this:
Prolog - Split a list in two halves, reversing the first half.
I am asked to take a list of letters into two lists that are either equal in size (even sized original list I guess) or one is larger than the other by one element (odd sized list), and reverse the first one while I'm at it, but using only difference lists.
These are the required query and output
?-dividelist2([a,b,c,d,e,f | T] - T, L1-[], L2-[]).
L1 = [c,b,a]
L2 = [d,e,f]
?-dividelist2([a,b,c,d,e | T] - T, L1-[], L2-[]).
L1 = [c,b,a]
L2 = [d,e]
% OR
L1 = [b,a]
L2 = [c,d,e]
This is my code using the previous example but modified, I don't know how to properly compare the two lists
"deduct" them from the input and produce [d,e,f]?
dividelist2(In -[], L1-[], L2-[]) :-
length_dl(In - [],L), % length of the list
FL is L//2, % integer division, so half the length, Out1 will be 1 shorter than Out2 if L is odd
( \+ (FL*2 =:= L), % is odd
FLP is FL + 1 % odd case
; FLP = FL % odd and even case
),
take(In,FLP,FirstHalf),
conc([FirstHalf| L2]-l2,L2-[],In-[]),
reverse1(FirstHalf-[], L1-[]). % do the reverse
reverse1(A- Z,L - L):-
A == Z , !.
reverse1([X|Xs] - Z,L - T):-
reverse1(Xs - Z, L - [X|T]).
length_dl(L- L,0):-!.
length_dl([X|T] - L,N):-
length_dl(T- L,N1),
N is N1 + 1 .
take(Src,N,L) :- findall(E, (nth1(I,Src,E), I =< N), L).
conc(L1-T1,T1-T2,L1-T2).
This is the current trace:
Call:dividelist2([a, b, c, d, e, f|_22100]-_22100, _22116-[], _22112-[])
Call:length_dl([a, b, c, d, e, f]-[], _22514)
Call:length_dl([b, c, d, e, f]-[], _22520)
Call:length_dl([c, d, e, f]-[], _22526)
Call:length_dl([d, e, f]-[], _22532)
Call:length_dl([e, f]-[], _22538)
Call:length_dl([f]-[], _22544)
Call:length_dl([]-[], _22550)
Exit:length_dl([]-[], 0)
Call:_22554 is 0+1
Exit:1 is 0+1
Exit:length_dl([f]-[], 1)
Call:_22560 is 1+1
Exit:2 is 1+1
Exit:length_dl([e, f]-[], 2)
Call:_22566 is 2+1
Exit:3 is 2+1
Exit:length_dl([d, e, f]-[], 3)
Call:_22572 is 3+1
Exit:4 is 3+1
Exit:length_dl([c, d, e, f]-[], 4)
Call:_22578 is 4+1
Exit:5 is 4+1
Exit:length_dl([b, c, d, e, f]-[], 5)
Call:_22584 is 5+1
Exit:6 is 5+1
Exit:length_dl([a, b, c, d, e, f]-[], 6)
Call:_22590 is 6//2
Exit:3 is 6//2
Call:3*2=:=6
Exit:3*2=:=6
Call:_22590=3
Exit:3=3
Call:take([a, b, c, d, e, f], 3, _22594)
Call:'$bags' : findall(_22518, (nth1(_22514, [a, b, c, d, e, f], _22518),_22514=<3), _22614)
Exit:'$bags' : findall(_22518, '251db9a2-f596-4daa-adae-38a38a13842c' : (nth1(_22514, [a, b, c, d, e, f], _22518),_22514=<3), [a, b, c])
Exit:take([a, b, c, d, e, f], 3, [a, b, c])
Call:conc([[a, b, c]|_22112]-l2, _22112-[], [a, b, c, d, e, f]-[])
Fail:conc([[a, b, c]|_22112]-l2, _22112-[], [a, b, c, d, e, f]-[])
Fail:dividelist2([a, b, c, d, e, f|_22100]-_22100, _22116-[], _22112-[])
false
thanks
This is not an answer but testing and debugging suggestions that doesn't fit the comment length limit. The suggestions use Logtalk, which you can run with most Prolog systems.
From your question, the dividelist2/3 predicate needs to satisfy a couple of properties, one of them describing the lengths of the resulting lists. We can express this property easily using a predicate, p/1:
p(DL) :-
difflist::length(DL, N),
dividelist2(DL, DL1, DL2),
difflist::length(DL1, N1),
difflist::length(DL2, N2),
N is N1 + N2,
abs(N1 - N2) =< 1.
Here I'm using Logtalk's difflist library object to compute the length of the difference lists. Given this predicate, we can now perform some property-testing of your dividelist2/3 predicate.
Using Logtalk lgtunit tool implementation of property-testing, we get:
?- lgtunit::quick_check(p(+difference_list(integer))).
* quick check test failure (at test 1 after 0 shrinks):
* p(A-A)
false.
I.e. your code fails for the trivial case of an empty difference list. In the query, we use the difference_list(integer) type simply to simplify the generated counter-examples.
Let's try to fix the failure by adding the following clause to your code:
dividelist2(A-A, B-B, C-C).
Re-trying our test query, we now get:
?- lgtunit::quick_check(p(+difference_list(integer))).
* quick check test failure (at test 2 after 0 shrinks):
* p([0|A]-A)
false.
I.e. the dividelist2/3 predicate fails for a difference list with a single element. You can now use the difference list in the generated counter-example as a starting point for debugging:
?- dividelist2([0|A]-A, L1, L2).
A = [0|A],
L1 = _2540-_2540,
L2 = _2546-_2546 ;
false.
You can also use property-testing with your auxiliary predicates. Take the length_dl/2 predicate. We can compare it with another implementation of a predicate that computes the length of a difference list, e.g. the one in the Logtalk library, by defining another property:
q(DL) :-
difflist::length(DL, N),
length_dl(DL, N).
Testing it we get:
?- lgtunit::quick_check(q(+difference_list(integer))).
* quick check test failure (at test 3 after 0 shrinks):
* q([-113,446,892|A]-A)
false.
Effectively, using the counter.example, we get:
?- length_dl([-113,446,892|A]-A, N).
A = [-113, 446, 892|A],
N = 0.
Hope that this insight helps in fixing your code.
Ok, my idea can work, but seems somewhat inelegant. We'll begin with a handy utility that'll turn a list into a difference list:
list_dl([], W-W).
list_dl([H|T1], [H|T2]-W) :-
list_dl(T1, T2-W).
Now we want a predicate to take the first and last element from the difference list. The case where there's only one element left will need to be handled differently, so we'll make that one unique.
head_last(Head, Head, DL-Hole, one) :-
once(append([Head|_], [Last, Hole], DL)),
var(Last), !.
head_last(Head, Last, DL-Hole, New) :-
once(append([Head|Mid], [Last, Hole], DL)),
list_dl(Mid, New).
Now we can create our recursive split and reverse predicate, which has 3 base cases:
splitrev(W-W, [], []) :- var(W), !. % Empty base case.
splitrev(DL, [V|[]], []) :- head_last(V, V, DL, one).
splitrev(DL, [], [V|[]]) :- head_last(V, V, DL, one).
splitrev(DL, [Head|Front], [Last|Back]) :-
head_last(Head, Last, DL, Rest),
splitrev(Rest, Front, Back).
Unfortunately it's much easier to add an element to the back of a difference list than it is to get an element from the back, plus getting that element closed the hole in the list. Therefore I think a different strategy would be better.
Given facts:
edges(a,[b,c]).
edges(b,[d]).
edges(c,[a]).
edges(d,[e]).
For now, I can write following predicate:
find(F, L) :-
edges(F, Nodes) ->
findall([X|Y], (member(X, Nodes), find(X, Y)), L);
L = [].
It works fine when there is no cycle, for example, find(b,L). gives me d and e. But it's not working when cycle exists. So how can I modify my code to handle the cycle? e.g find(c,L) will output a, b, c, d, e as well as find(a,L).
Any helps are appreciated.
You could opt to use an accumulator to keep track of the nodes you visited. In order to do this you need a list as an additional argument. Since this lists is empty at the beginning of your search, you'd always call the predicate with [], so you might as well hide it by using a calling predicate, let's maybe call it start_dest/2:
start_dest(S,D) :-
dif(S,D), % start and destination nodes are different
start_dest_(S,D,[]). % actual relation called with empty accumulator
The first goal dif/2 is only necessary in order to prevent solutions where the start node and the destination node are the same. If you want to permit such solutions just remove that goal. The actual relation will search for reachable nodes by traversing the graph node by node. You can distinguish two cases.
If the two nodes are equal you found a possible destination node.
If the nodes are different, there has to be to be an intermediate node in the adjacence list of the node you are currently at. The current node must not have been visited in the search so far (to avoid cycles). There has to be a path from the intermediate node to the destination and the current node must not appear in that path, so it has to be added to the list of visited nodes.
You can express these two cases in Prolog like so:
start_dest_(D,D,_Visited). % case 1: destination found
start_dest_(S,D,Visited) :- % case 2:
maplist(dif(S),Visited), % S has not been visited yet
edges(S,Reachable), % Reachable is the adjacence list
member(X,Reachable), % that has to contain the intermediate node X
start_dest_(X,D,[S|Visited]). % there has to be a path from X to D that
% does not include S
Your example queries yield the desired result:
?- start_dest(b,N).
N = d ;
N = e ;
false.
?- start_dest(c,N).
N = a ;
N = b ;
N = d ;
N = e ;
false.
If you remove the first goal (dif(S,D)) in start_dest/2, you get an additional solution. This corresponds to the view that every node is reachable from itself.
?- start_dest(b,N).
N = b ;
N = d ;
N = e ;
false.
Note that this predicate can be used in all directions, e.g. From which nodes can e be reached?:
?- start_dest(S,e).
S = a ;
S = b ;
S = c ;
S = d ;
false.
Or the most general query: Which nodes are reachable from any node?:
?- start_dest(S,D).
S = a,
D = b ;
S = a,
D = d ;
S = a,
D = e ;
S = a,
D = c ;
S = b,
D = d ;
S = b,
D = e ;
S = c,
D = a ;
S = c,
D = b ;
S = c,
D = d ;
S = c,
D = e ;
S = d,
D = e ;
false.
As opposed to your predicate find/2, start_dest/2 gives you the reachable nodes one at a time. If you want to get all reachable nodes in a list, you can use predicates like findall/3, bagof/3 and setof/3 as you did in find/2, e.g.:
?- bagof(N, start_dest(b,N), Reachable).
Reachable = [d, e].
?- bagof(N, start_dest(c,N), Reachable).
Reachable = [a, b, d, e].
If you intend to always search for all reachable nodes but do not want to query with bagof/3 all the time, you can write a calling predicate like:
reachable_from(Reachable,Start) :-
bagof(N, start_dest(Start,N), Reachable).
?- reachable_from(Reachable,Start).
Reachable = [b, d, e, c],
Start = a ;
Reachable = [d, e],
Start = b ;
Reachable = [a, b, d, e],
Start = c ;
Reachable = [e],
Start = d.
Here is a possibility :
% we get a list of all edges
get_all_edges(Edges) :-
bagof(edges(X,Y), edges(X,Y), Edges).
% main predicate
find(F, L) :-
get_all_edges(Edges),
find(Edges, F, Out),
% the result you get is for example [[a, [b, [d, [e|e], [e]]], [c]]]
flatten(Out, FOut),
list_to_set(FOut, L).
% no more edges, work is done
find([], L, L).
find(Edges, F, L) :-
% we get the good nodes
select(edges(F, Nodes), Edges, Rest)
-> findall([X|Y], (member(X, Nodes), find(Rest, X, Y)), L)
; L = [].
Result :
?- find(c, L).
L = [a, b, d, e, c].
After you'll have learned the basic way, take a look to what libraries have to offer:
?- findall(V-U,(edges(V,Us),member(U,Us)),Es),
vertices_edges_to_ugraph([],Es,G),
reachable(a,G,Rs).
Es = [a-b, a-c, b-d, c-a, d-e],
G = [a-[b, c], b-[d], c-[a], d-[e], e-[]],
Rs = [a, b, c, d, e].
You could be tempted to go directly from your edges/2 to ugraph format, but better make use of predefined functionality (i.e. vertices_edges_to_ugraph/3)
I found this freaking great algorithm in SWI-prolog's source code.
It's so elegant that I want to share it with you.
This snippet is indeed a BFS algorithm.
%! reachable(+Vertex, +UGraph, -Vertices)
%
% True when Vertices is an ordered set of vertices reachable in
% UGraph, including Vertex. Example:
%
% ?- reachable(1,[1-[3,5],2-[4],3-[],4-[5],5-[]],V).
% V = [1, 3, 5]
reachable(N, G, Rs) :-
reachable([N], G, [N], Rs).
reachable([], _, Rs, Rs).
reachable([N|Ns], G, Rs0, RsF) :-
neighbours(N, G, Nei),
ord_union(Rs0, Nei, Rs1, D),
append(Ns, D, Nsi),
reachable(Nsi, G, Rs1, RsF).
Is there a sort issue with java7? I am using Collections.sort(list, comparator)
When I switched over to java7, I noticed that the sorting resulted in a different list compared to the result when I was using java6.
Example: List = [d, e, b, a, c, f, g, h]
In java6 Collections.sort(List, comparator) resulted in [a, b, c, d, e, f, g, h]
In java7 Collections.sort(List, comparator) resulted in [b, a, c, d, e, f, g, h]
The first two values in the list have been swapped.
Java 7 switched from Merge sort to Tim sort. It might result in slight changes in order with "broken comparators" (quoting comment in source code of Arrays class):
/**
* Old merge sort implementation can be selected (for
* compatibility with broken comparators) using a system property.
* Cannot be a static boolean in the enclosing class due to
* circular dependencies. To be removed in a future release.
*/
Try running your JVM with:
java -Djava.util.Arrays.useLegacyMergeSort=true
It's not clear what "broken comparator" means, but apparently it can result in different order of elements in sorted arrays.
One thing to note, that might be causing confusion. Collections.sort is a stable sort. This means for equal elements, it maintains their original ordering, so:
if a == b, then
Collections.sort([d, e, b, a, c, f, g, h]) = [b, a, c, d, e, f, g, h]
and
Collections.sort([d, e, a, b, c, f, g, h]) = [a, b, c, d, e, f, g, h]
Seems likely to me that either that is what your seeing, or the Comparator in question (or the objects being sorteds' natural ordering) isn't working the way you expect it to.
The creole of Paradise Island has 14 words: "abandon", "abalone", "anagram", "boat", "boatman", "child", "connect", "elegant", "enhance", "island", "man", "sand", "sun", and "woman".
The Paradise Times have
published this crossword:
The crossword contains some of the 14 words but no other words.
Write
a Prolog program that starts from
word(X) :-
member(X,
[
[a,b,a,n,d,o,n], [a,b,a,l,o,n,e], [a,n,a,g,r,a,m],
[b,o,a,t], [b,o,a,t,m,a,n], [c,h,i,l,d],
[c,o,n,n,e,c,t], [e,l,e,g,a,n,t], [e,n,h,a,n,c,e],
[i,s,l,a,n,d], [m, a, n], [s,a,n,d],
[s,u,n], [w, o, m, a, n]
]).
solution(H1,H2,H3,V1,V2,V3) :-
and defines the predicate solution in such a way that
solution(H1,H2,H3,V1,V2,V3)
is true if and only if H1, H2, H3, V1, V2, and V3 are valid words of Paradise
Island which form a valid crossword when written into the grid given above.
(For example, the second letter of H1 should coincide with the second letter
of V1.)
Use the query
?- solution(H1,H2,H3,V1,V2,V3).
to solve the crossword. Find all solutions to the crossword.
Hint: You might want to start from a smaller crossword and a less rich
lexicon.
Just look at the picture, words are written with letters, you have everything in the picture, translaste it in Prolog lines (my solution has 12 lines, 2 lines for one word).
[EDIT] As every body gives its own solution, here is mine :
solution(H1,H2,H3,V1,V2,V3) :-
H1 = [_,A2,_,A4,_,A6,_],
H2 = [_,B2,_,B4,_,B6,_],
H3 = [_,C2,_,C4,_,C6,_],
V1 = [_,A2,_,B2,_,C2,_],
V2 = [_,A4,_,B4,_,C4,_],
V3 = [_,A6,_,B6,_,C6,_],
maplist(word, [H1,H2,H3,V1,V2,V3]).
PS I originally
wrote word(H1),
word(H2) ...
Uniquely domain-selecting select/2 does the trick:
select([A|As],S):- select(A,S,S1),select(As,S1).
select([],_).
words(X) :- X = [
[a,b,a,n,d,o,n], [a,b,a,l,o,n,e], [a,n,a,g,r,a,m],
[b,o,a,t], [b,o,a,t,m,a,n], [c,h,i,l,d],
[c,o,n,n,e,c,t], [e,l,e,g,a,n,t], [e,n,h,a,n,c,e],
[i,s,l,a,n,d], [m, a, n], [s,a,n,d],
[s,u,n], [w, o, m, a, n]
].
solve(Crossword):- words(Words),
Crossword = [ [_,A2,_,A4,_,A6,_],
[_,B2,_,B4,_,B6,_],
[_,C2,_,C4,_,C6,_],
[_,A2,_,B2,_,C2,_],
[_,A4,_,B4,_,C4,_],
[_,A6,_,B6,_,C6,_] ],
select(Crossword, Words).
solve:- solve(Crossword),
maplist(writeln, Crossword), writeln(';'), fail
; writeln('No more solutions!').
Test:
7 ?- solve.
[a, b, a, n, d, o, n]
[e, l, e, g, a, n, t]
[e, n, h, a, n, c, e]
[a, b, a, l, o, n, e]
[a, n, a, g, r, a, m]
[c, o, n, n, e, c, t]
;
[a, b, a, l, o, n, e]
[a, n, a, g, r, a, m]
[c, o, n, n, e, c, t]
[a, b, a, n, d, o, n]
[e, l, e, g, a, n, t]
[e, n, h, a, n, c, e]
;
No more solutions!
This solution only allows for unique words to be used in the puzzle (no duplicates are allowed). This might or might not be what you intended.
Not a Prolog program per se, but a solution using Constraint Logic Programming can be found in Hakan Kjellerstrand's excellent blog on CP. It's in ECLiPSe, but easily adaptable to other Prolog systems with finite domain solvers. Using CLP instead of pure Prolog will make the search much faster.
solution(H1, H2, H3, V1, V2, V3) :-
crosswordize([H1,H2,H3], [V1,V2,V3]),
maplist(word, [H1,H2,H3,V1,V2,V3]).
crosswordize([], [[_],[_],[_]]).
crosswordize([[_, X1, _, X2, _, X3, _]|Lines],
[[_, X1|R1], [_, X2|R2], [_, X3|R3]]) :-
crosswordize(Lines, [R1,R2,R3]).
The algorithm isn't hard to get:
we build the grid through the crosswordize/2 predicate call
we tell prolog that every list is a word
The crosswordize/2 predicate is going through the columns two cells at a time while building lines. If you don't get it you still can "hardcode" it as Will did, it works too!
The theory here is to check for the letters which correspond to themselves in vertical and horizontal words. This can be achieved by using placeholders in the word rule. Checkout this gist https://gist.github.com/ITPol/f8f5418d4f95015b3586 it gives an answer which claims has no repetitions. However, coming from SQL, I think to properly curb repetitions will require a solution along the lines of V1 #< V2; because just using a "not equals to" is just not sufficient enough. Pardon the multiple "[k]nots"; it's actually not that complicated. Pun intended (: