Iterating into a list within a list in Prolog - prolog

I currently have this code that inserts an element into a list:
listpicket(_,[],[k]).
listpicket(K,[H|T],[K,H|L]) :-
listpicket(K,T,L).
It currently produces this result:
L = [k, a, k, b, k, [c, d], k, e, k]
However, I am trying to get the program to insert a k into [c,d] such as shown:
L = [k, a, k, b, k, [k, c, k, d, k], k, e, k]
I have a feeling I'm supposed to use is_list to check if the tail is a proper list or not, and then create another recursion inside to insert the k element just like the outside. However, I'm quite new to Prolog and I'm trying to understand how I can introduce a conditional inside the listpicket method.


You need to check whether the head of the List [k, a, k, b, k, [c, d], k, e, k] contains any list or not. If the head is a list then add k to the list [c,d] the resultant list is [k,c,k,d]. Now add this resultant list to the Main List. My approach is attached below.
is_list1([_|_]).
addK([X],k,[k,X,k]).
addK([H|T],k,[k,H|T1]):- addK(T,k,T1).
addElement([],[]).
addElement([H|T],[H1|Z]):- is_list1(H) , addK(H,k,H1) , addElement(T,Z) .
addElement([H|T],[H|Z]):- \+is_list(H) , addElement(T,Z).
is_list1() function is used to determine whether a given head is a list or not.
addK() function adds k before and after the head to the list given to it.
addElement() is uses all the above functions to achieve the goal you wanted.
OUTPUT
?- addElement([k, a, k, b, k, [c, d], k, e, k],Z).
Z = [k, a, k, b, k, [k, c, k, d, k], k, e, k]
?- addElement([1,2,[3,4,5],4,5],Z).
Z = [1, 2, [k, 3, k, 4, k, 5, k], 4, 5]
what you have to do is append my code to your existing code, which should look like this.
listpicket(_,[],[k]).
listpicket(K,[H|T],[K,H|L]) :-
listpicket(K,T,L).
is_list1([_|_]).
addK([X],k,[k,X,k]).
addK([H|T],k,[k,H|T1]):- addK(T,k,T1).
addElement([],[]).
addElement([H|T],[H1|Z]):- is_list1(H) , addK(H,k,H1) , addElement(T,Z) .
addElement([H|T],[H|Z]):- \+is_list(H) , addElement(T,Z).
goal(X,FinalList):- listpicket(k,X,L) , addElement(L,FinalList).
OUTPUT
?- goal([1,2,[3,4],5],FinalList).
FinalList = [k, 1, k, 2, k, [k, 3, k, 4, k], k, 5, k]
?- goal([a,b,[c,d],e],FinalList).
FinalList = [k, a, k, b, k, [k, c, k, d, k], k, e, k]
Hope this helped you.

Related

Algorithm: generate list permutation by preference

I have a function f that takes a list of items as it's single parameter and returns true if the ordering of the items is accepted or false if the ordering of the items is not accepted.
There exists at least one or more permutations of list l which f(l) returns true.
Function f is a black box (we don't have it's source code) and the type of the elements held by list l are also unknown or generic.
p is a permutation of list l according to user preferences. The most preferred item has index 0 the least preferred item has index l.size()-1
list p will always contain all elements of list l.
The goal is to find a permutation of l let's call it p_accepted where f(p_accepted) returns true and preference p is maximized.
Here's an example
given l = [a, b, c, d, e, f]
given p = [c, a, f, b, e, d]
given f([ a, b, c, d, e, f ]) = false
given f([ c, a, f, b, e, d ]) = false
given f([ d, e, b, f, a, c ]) = true
given f([ f, e, d, c, b, a ]) = true
given f([ c, b, f, a, d, e ]) = true
given f([ a, c, f, b, e, d ]) = true
given f([ anything else ]) = false
the expected output for p_accepted is [c, b, f, a, d, e]
it is accepted because f(p_accepted) returns true and no other permutation of l ranks the item 'c' as high. item 'c' is the most preferred by the user since it has index 0
Implementations in pseudo code or any language are accepted.
[EDIT]
Clarifications
list p will always contain all elements of list l
list l items can only be compared by identity, i.e.: by reference
so an item in list p can be found in list l by l[i] == p[j]
list l items cannot always be compared like in the example where a compare function c might determine that a < b i.e.: c('a', 'b') = 1.
[EDIT 2]
To understand preferences better
Imagine Alice and Bob being forced to do 4 tasks together at the same time in order. [task a, task b, task c, task d].
Alice has one preferred order for doing the tasks [a,b,c,d]. Bob has two preferred orders for doing the tasks [a,c,b,d], [a,d,b,c]. If you are Alice, the function f would return true only for [a,c,b,d] and [a,d,b,c] which are Bob's preferences, since both like to do task a first p_accepted should start with a.
Note that this is an analogy function f does not accept permutations based on multiple user's order preference.

Prolog, 3 in a row, any direction

I'm trying to write a procedure in prolog where a list might look something like this:
threeInRow(x,[b, b, a, threeInRow(x,[b, d, a,
c, a, b, c, d, b,
a, d, d]) b, d, a])
Both of these would return true. The list always contains 9 elements and can be any of character ranging from a-d.
threeInRow(x,[b, b, j
c, j, b,
j, d, d])
Would however return false, because it's not a character ranging from a-d.

If you want to verify only length of the list (9) and allowed elements:
item_allowed(Item) :-
member(Item, [a, b, c, d]).
threeInRow(List) :-
length(List, 9),
maplist(item_allowed, List).

How to get the value of many elements of a matrix (list of lists)

I have problems because I want to get the values of many grids of a matrix
Example:
I have this matrix (list of lists)
[[g,z,n,d,o,g,r,o,y,c],
[a,u,u,d,p,o,x,s,t,b],
[u,y,z,r,r,e,m,e,e,o],
[g,v,j,m,x,e,j,e,h,l],
[e,r,u,y,d,z,k,b,r,x],
[e,d,h,n,c,y,q,e,x,i],
[w,f,m,w,x,n,n,m,h,i],
[y,d,g,u,q,d,z,o,n,d],
[g,p,o,u,c,o,n,f,x,q],
[c,y,z,r,i,c,a,t,x,v]]
I want to get the word "dog" from this matrix, this word is in the coordinates (0 3) (0 4) (0 5).
Now the problem is how I can do this in prolog?
My code so far:
selectElementList(0,[H|_],H).
selectElementList(P,[H|T],E):-
length([H|T],Len),
( P < Len
-> P1 is P - 1,
selectElementList(P1,T,E),
!
; E = false,
!
).
With this predicate I get one value of the matrix.
selectGridMatrix(Matrix,X,Y,R):-
selectElementList(X,Matrix,Row), selectElementList(Y,Row,R).
Example:
?- selectGridMatrix([[0,1,2],[3,4,5]],0,0,R).
R = 0 ;

an example, using builtin nth0/3 and library(yall):
?- M= [[g,z,n,d,o,g,r,o,y,c],
[a,u,u,d,p,o,x,s,t,b],
[u,y,z,r,r,e,m,e,e,o],
[g,v,j,m,x,e,j,e,h,l],
[e,r,u,y,d,z,k,b,r,x],
[e,d,h,n,c,y,q,e,x,i],
[w,f,m,w,x,n,n,m,h,i],
[y,d,g,u,q,d,z,o,n,d],
[g,p,o,u,c,o,n,f,x,q],
[c,y,z,r,i,c,a,t,x,v]], maplist({M}/[(R,C),V]>>(nth0(R,M,Row),nth0(C,Row,V)),[(0,3),(0,4),(0,5)],Word).
M = [[g, z, n, d, o, g, r, o|...], [a, u, u, d, p, o, x|...], [u, y, z, r, r, e|...], [g, v, j, m, x|...], [e, r, u, y|...], [e, d, h|...], [w, f|...], [y|...], [...|...]|...],
Word = [d, o, g].
HTH

Trying to solve the peg jump puzzle in Prolog

There are 8 pegs in nine holes. At beginning, the four red pegs on the left and the four blue pegs are on the right, and one empty hole between them. The puzzle is to move all the red to the right, and blue pegs to the left(in other opposite). These are the legal moves to do so:
Pegs may only move forward (red may move right and blue left).
A peg may move forward one step into an open position.
A peg may skip over exactly one peg of the opposite color, if the position beyond it is open.
This is what I wrote, but it doesn't work
% Form of board, b for blue, r for red, o for empty.
% [ [r,r,r,r], [o], [b,b,b,b] ]
% jumps
linjmp([x, x, o | T], [o, o, x | T]).
linjmp([o, x, x | T], [x, o, o | T]).
linjmp([H|T1], [H|T2]) :- linjmp(T1,T2).
% Series of legal boards.
series(From, To, [From, To]) :- jump(From, To).
series(From, To, [From, By | Rest])
:- jump(From, By),
series(By, To, [By | Rest]).
% Print a series of boards. This puts one board per line and looks a lot
% nicer than the jumble that appears when the system simply beltches out
% a list of boards. The write_ln predicate is a built-in which always
% succeeds (is always satisfied), but prints as a side-effect. Therefore
% print_series(Z) will succeed with any list, and the members of the list
% will be printed, one per line, as a side-effect of that success.
print_series_r([]) :-
write_ln('*******************************************************').
print_series_r([X|Y]) :- write_ln(X), print_series_r(Y).
print_series(Z) :-
write_ln('\n*******************************************************'),
print_series_r(Z).
% A solution.
solution(L) :- series([[r,r,r,r], [o], [b,b,b,b]],
[[b,b,b,b], [o], [r,r,r,r]], L).
% Find a print the first solution.
solve :- solution(X), print_series(X).
% Find all the solutions.
solveall :- solve, fail.
% This finds each solution with stepping.
solvestep(Z) :- Z = next, solution(X), print_series(X).
It should be like so when it works:
?- consult(linejump).
% linejump compiled 0.00 sec, 3,612 bytes
true.
?- solve.
*******************************************************
[r, r, r, r, o, b, b, b, b]
[r, r, r, o, r, b, b, b, b]
[r, r, r, b, r, o, b, b, b]
[r, r, r, b, r, b, o, b, b]
[r, r, r, b, o, b, r, b, b]
[r, r, o, b, r, b, r, b, b]
[r, o, r, b, r, b, r, b, b]
[r, b, r, o, r, b, r, b, b]
[r, b, r, b, r, o, r, b, b]
[r, b, r, b, r, b, r, o, b]
[r, b, r, b, r, b, r, b, o]
[r, b, r, b, r, b, o, b, r]
[r, b, r, b, o, b, r, b, r]
[r, b, o, b, r, b, r, b, r]
[o, b, r, b, r, b, r, b, r]
[b, o, r, b, r, b, r, b, r]
[b, b, r, o, r, b, r, b, r]
[b, b, r, b, r, o, r, b, r]
[b, b, r, b, r, b, r, o, r]
[b, b, r, b, r, b, o, r, r]
[b, b, r, b, o, b, r, r, r]
[b, b, o, b, r, b, r, r, r]
[b, b, b, o, r, b, r, r, r]
[b, b, b, b, r, o, r, r, r]
[b, b, b, b, o, r, r, r, r]
*******************************************************
true ;
*******************************************************
[r, r, r, r, o, b, b, b, b]
[r, r, r, r, b, o, b, b, b]
[r, r, r, o, b, r, b, b, b]
[r, r, o, r, b, r, b, b, b]
[r, r, b, r, o, r, b, b, b]
[r, r, b, r, b, r, o, b, b]
[r, r, b, r, b, r, b, o, b]
[r, r, b, r, b, o, b, r, b]
[r, r, b, o, b, r, b, r, b]
[r, o, b, r, b, r, b, r, b]
[o, r, b, r, b, r, b, r, b]
[b, r, o, r, b, r, b, r, b]
[b, r, b, r, o, r, b, r, b]
[b, r, b, r, b, r, o, r, b]
[b, r, b, r, b, r, b, r, o]
[b, r, b, r, b, r, b, o, r]
[b, r, b, r, b, o, b, r, r]
[b, r, b, o, b, r, b, r, r]
[b, o, b, r, b, r, b, r, r]
[b, b, o, r, b, r, b, r, r]
[b, b, b, r, o, r, b, r, r]
[b, b, b, r, b, r, o, r, r]
[b, b, b, r, b, o, r, r, r]
[b, b, b, o, b, r, r, r, r]
[b, b, b, b, o, r, r, r, r]
*******************************************************
true .
?-

A straightforward Prolog code which tries to be the simplest and clearest, and doesn't care about efficiency at all:
start([r,r,r,r,e,b,b,b,b]). % starting position
% can move from a position P1 to position P2
move(P1,P2):- append(A,[r,e|B],P1), append(A,[e,r|B],P2).
move(P1,P2):- append(A,[e,b|B],P1), append(A,[b,e|B],P2).
move(P1,P2):- append(A,[e,r,b|B],P1), append(A,[b,r,e|B],P2).
move(P1,P2):- append(A,[r,b,e|B],P1), append(A,[e,b,r|B],P2).
solved([b,b,b,b,e,r,r,r,r]). % the target position to be reached
pegs :- start(P), solve(P, [], R),
maplist(writeln, R), nl, nl, fail ; true.
% solve( ?InitialPosition, +PreviousPositionsList, ?ResultingPath)
solve(P, Prev, R):-
solved(P) -> reverse([P|Prev], R) ;
move(P, Q), \+memberchk(Q, Prev), solve(Q, [P|Prev], R).
Nothing special about it. Takes whole of 0.08 seconds on Ideone to find two solutions, both of 24 moves.
For an N-pegs problem, we only need to modify the start and solved predicates accordingly.
Kudos go to Cary Swoveland from whose answer I took the notation (that's half the solution). A more efficient code, following mat's answer, building the result list in Prolog's characteristic top-down manner (similar to difference-lists technique, cf. tailrecursion-modulo-cons ):
swap([r,e|B],[e,r|B]).
swap([e,b|B],[b,e|B]).
swap([e,r,b|B],[b,r,e|B]).
swap([r,b,e|B],[e,b,r|B]).
move(A,B):- swap(A,B).
move([A|B],[A|C]):- move(B,C).
moves(S,[S]):- solved(S).
moves(S,[S|B]):- move(S,Q), moves(Q,B).
pegs(PS) :- start(P), moves(P, PS), maplist( writeln, PS), nl.
In general, any board game with positions and moves between them can be seen as a search problem in a search space of positions, defined by the valid moves, that is to take us from the start to the end (final) position. Various search strategies can be used, depth first, breadth first, iterative deepening, best-first heuristics ... This views the search space as a graph where nodes are positions (board configurations), and edges are moves; otherwise we can say this is a transitive closure of a move relation.
Sometimes the move relation is defined such that it produces a new legal configuration (like here); sometimes it is easier to define a general move relation and check the produced position for legality (like in N-queens problem). It is also common to maintain the visited nodes list while searching, and check any newly discovered node for being one of those already visited - discarding that path, to avoid getting into a loop.
Breadth first search will explicitly maintain the frontier of the nodes being discovered, and maintain it as a queue while extending it by one move at a time; depth first as a stack. Best first search will reorder this frontier according to some heuristics. Here, moves/2 is depth-first implicitly, because it relies on Prolog search which is itself depth-first.
Sometimes the search space is guaranteed to not have these cycles (i.e. to be a DAG - directed acyclic graph) so the check for uniqueness is not necessary. As for the final node, sometimes it is defined by value (like here), sometimes we're interested in some condition to hold (like e.g. in chess). See this answer for how to enforce this uniqueness with a lazy all_dif/1 predicate upfront. With the predicates defined in it, this problem becomes simply
pegs(Ps):-
path( move, Ps, [r,r,r,r,e,b,b,b,b], [b,b,b,b,e,r,r,r,r]).

It is always nice to use a dcg when describing lists.
For example:
initial_state([r,r,r,r,o,b,b,b,b]).
final_state([b,b,b,b,o,r,r,r,r]).
move([E|Es]) --> [E], move(Es).
move([r,o|Ls]) --> [o,r], list(Ls).
move([o,b|Ls]) --> [b,o], list(Ls).
move([o,r,b|Ls]) --> [b,r,o], list(Ls).
move([r,b,o|Ls]) --> [o,b,r], list(Ls).
list([]) --> [].
list([L|Ls]) --> [L], list(Ls).
moves(S) --> [S], { final_state(S) }.
moves(S0) --> [S0], { phrase(move(S0), S) }, moves(S).
We can use iterative deepening to find a shortest solution:
?- length(Ms, _),
initial_state(S0),
phrase(moves(S0), Ms),
maplist(writeln, Ms).
[r,r,r,r,o,b,b,b,b]
[r,r,r,r,b,o,b,b,b]
[r,r,r,o,b,r,b,b,b]
[r,r,o,r,b,r,b,b,b]
[r,r,b,r,o,r,b,b,b]
[r,r,b,r,b,r,o,b,b]
[r,r,b,r,b,r,b,o,b]
[r,r,b,r,b,o,b,r,b]
[r,r,b,o,b,r,b,r,b]
[r,o,b,r,b,r,b,r,b]
[o,r,b,r,b,r,b,r,b]
[b,r,o,r,b,r,b,r,b]
[b,r,b,r,o,r,b,r,b]
[b,r,b,r,b,r,o,r,b]
[b,r,b,r,b,r,b,r,o]
[b,r,b,r,b,r,b,o,r]
[b,r,b,r,b,o,b,r,r]
[b,r,b,o,b,r,b,r,r]
[b,o,b,r,b,r,b,r,r]
[b,b,o,r,b,r,b,r,r]
[b,b,b,r,o,r,b,r,r]
[b,b,b,r,b,r,o,r,r]
[b,b,b,r,b,o,r,r,r]
[b,b,b,o,b,r,r,r,r]
[b,b,b,b,o,r,r,r,r]
with additional bindings for the lists of moves Ms and the initial state S0.

a purely syntactic variation of Will Ness's answer:
swap(X,P,Q) :- append([L,X,R],P), reverse(X,Y), append([L,Y,R],Q).
solve(P,Prev,R) :-
solved(P)
-> reverse([P|Prev], R)
; % move(P, Q)
phrase( (swap([r,e])|swap([e,b])|swap([e,r,b])|swap([r,b,e])), P, Q),
\+memberchk(Q, Prev),
solve(Q, [P|Prev], R).

I don't know prolog, but here's a recursive solution using Ruby. Even if you don't know Ruby, you should be able to figure out how the recursion works.
A Ruby primer:
a[space_pos-1], a[space_pos] = a[space_pos], a[space_pos-1] uses parallel assignment to swap the values at array indices space_pos-1 and space_pos without the need for a temporary variable.
FINAL, since it begins with a capital letter, is a constant.
a = arr.dup returns a "shallow" copy of the array arr, so swapping elements of a does not effect arr.
If a method contains no return statement, the value computed in the last line is returned by the method (e.g., the array a in red_slide).
soln=[] in def solve(arr, soln = []) assigns soln to an empty array if solve is called solve(arr).
soln + [:red_slide], where soln is an array and [:red_slide] is an array containing a single symbol (indicated by the colon) is a new array comprised of the elements of soln and the element :red_slide.
you can think of && as "and".
nil is returned by solve if the state of the moves given by solve's argument arr does not lead to a solution.
FINAL = [:b, :b, :b, :b, :e, :r, :r, :r, :r]
SIZE = FINAL.size
def red_slide(arr, space_pos)
a = arr.dup
a[space_pos-1], a[space_pos] = a[space_pos], a[space_pos-1]
a
end
def blue_slide(arr, space_pos)
a = arr.dup
a[space_pos], a[space_pos+1] = a[space_pos+1], a[space_pos]
a
end
def red_jump(arr, space_pos)
a = arr.dup
a[space_pos-2], a[space_pos] = a[space_pos], a[space_pos-2]
a
end
def blue_jump(arr, space_pos)
a = arr.dup
a[space_pos+2], a[space_pos] = a[space_pos], a[space_pos+2]
a
end
def solve(arr, soln = [])
return soln if arr == FINAL
space_pos = arr.index(:e)
# See if can slide red
if space_pos > 0 && arr[space_pos-1] == :r
ret = solve(red_slide(arr, space_pos), soln + [:red_slide])
return ret if ret
end
# See if can slide blue
if space_pos < SIZE-1 && arr[space_pos+1] == :b
ret = solve(blue_slide(arr, space_pos), soln + [:blue_slide])
return ret if ret
end
# See if can jump red over blue
if space_pos > 1 && arr[space_pos-2] == :r && arr[space_pos-1] == :b
ret = solve(red_jump(arr, space_pos), soln + [:red_jump])
return ret if ret
end
# See if can jump blue over red
if space_pos < SIZE-2 && arr[space_pos+2] == :b && arr[space_pos+1] == :r
ret = solve(blue_jump(arr, space_pos), soln + [:blue_jump])
return ret if ret
end
nil
end
solve [:r, :r, :r, :r, :e, :b, :b, :b, :b]
#=> [:red_slide, :blue_jump, :blue_slide, :red_jump, :red_jump, :red_slide,
# :blue_jump, :blue_jump, :blue_jump, :blue_slide, :red_jump, :red_jump,
# :red_jump, :red_jump, :blue_slide, :blue_jump, :blue_jump, :blue_jump,
# :red_slide, :red_jump, :red_jump, :blue_slide, :blue_jump, :red_slide]
I was surprised that it took just a fraction of a second to compute a solution. I guess the number of combinations of moves is not as great as I had imagined.
Note that this solution is for the "N peg problem", not just the "8 peg problem". For example,
FINAL = [:b, :b, :b, :e, :r, :r, :r]
SIZE = FINAL.size
solve [:r, :r, :r, :e, :b, :b, :b]
#=> [:red_slide, :blue_jump, :blue_slide, :red_jump, :red_jump, :red_slide,
# :blue_jump, :blue_jump, :blue_jump, :red_slide, :red_jump, :red_jump,
# :blue_slide, :blue_jump, :red_slide]

Board representation is important, here.
% Form of board, b for blue, r for red, o for empty.
% [r, r, r, r, o, b, b, b, b]
% Legal jumps.
linjmp([r, o | T], [o, r | T]).
linjmp([o, b | T], [b, o | T]).
linjmp([o, r, b | T], [b, r, o | T]).
linjmp([r, b, o | T], [o, b, r | T]).
linjmp([H|T1], [H|T2]) :- linjmp(T1,T2).
% Series of legal boards.
series(From, To, [From, To]) :- linjmp(From, To).
series(From, To, [From, By | Rest])
:- linjmp(From, By),
series(By, To, [By | Rest]).
% Print a series of boards. This puts one board per line and looks a lot
% nicer than the jumble that appears when the system simply beltches out
% a list of boards. The write_ln predicate is a built-in which always
% succeeds (is always satisfied), but prints as a side-effect. Therefore
% print_series(Z) will succeed with any list, and the members of the list
% will be printed, one per line, as a side-effect of that success.
print_series_r([]) :-
write_ln('*******************************************************').
print_series_r([X|Y]) :- write_ln(X), print_series_r(Y).
print_series(Z) :-
write_ln('\n*******************************************************'),
print_series_r(Z).
% A solution.
solution(L) :- series([r, r, r, r, o, b, b, b, b],
[b, b, b, b, o, r, r, r, r], L).
% Find a print the first solution.
solve :- solution(X), print_series(X).
% Find all the solutions.
solveall :- solve, fail.
% This finds each solution with stepping.
solvestep(Z) :- Z = next, solution(X), print_series(X).

Crossword solver in PROLOG

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 (:

Resources