Prolog, 3 in a row, any direction - prolog

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).

Related

Prolog: Determine answers to Multiple Choice Question test where students' answers and grades are known

This is a prolog problem that I have to solve. I can't seem to find a starting point.
In a MCQ test where:
each question has 4 choices [a,b,c,d]
each question has only one correct answer (choice)
there are 10 questions
all questions have the same grade value (1 point, totalling 10 points)
4 students have taken this test and we have their grades:
student1: [b, c, b, a, c, c, c, d, c, c] Grade: 7/10
student2: [b, d, c, a, d, d, c, c, a, b] Grade: 6/10
student3: [d, a, b, b, d, d, c, d, a, b] Grade: 5/10
student4: [c, d, c, b, d, b, b, c, a, a] Grade: 3/10
From the informations above I need to write a prolog script that can determine the set of questions that are correct to get a 10/10 grade

We can branch over the possible choices, and do bookkeeping on the score of the students. When we reach the end of the list, then the users need to have the correct score.
We thus can generate lists of choices with:
option(a).
option(b).
option(c).
option(d).
sequence(N, L) :-
length(L, N),
maplist(option, L).
For example for a sequence of two items, we get:
?- sequence(2, L).
L = [a, a] ;
L = [a, b] ;
L = [a, c] ;
L = [a, d] ;
L = [b, a] ;
L = [b, b] ;
L = [b, c] ;
L = [b, d] ;
L = [c, a] ;
L = [c, b] ;
L = [c, c] ;
L = [c, d] ;
L = [d, a] ;
L = [d, b] ;
L = [d, c] ;
L = [d, d].
Next we can make a predicate mark/3 that calculates the score given the hypothetical correct sequence, and the sequence of a student. We thus need to implement something like:
mark([], [], 0).
mark(…, …, …) :-
….
I leave the implementation of mark/3 as an exercise.
Then we thus can find the sequence of correct answers with:
correct(C) :-
sequence(10, C),
mark(C, [b, c, b, a, c, c, c, d, c, c], 7),
mark(C, [b, d, c, a, d, d, c, c, a, b], 6),
mark(C, [d, a, b, b, d, d, c, d, a, b], 5),
mark(C, [c, d, c, b, d, b, b, c, a, a], 3).
You can later optimize the approach to an interleaved generate-and-test and not first generating sequences and then testing these. But I would first start with a simple solution that works.
When I implement this myself, there is exactly one solution. That solution has b as first answer.

You can use library(clfd) and reification, everything is here : https://www.swi-prolog.org/pldoc/man?section=clpfd-reification-predicates
(as already explain on another forum !)

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).

Prolog creating a list of sets from ith elements of lists

I have list structure
L=[[a,b,c,d],[a,f,c,h]]
Length of L can be greater than 2.I want to unite the elements of list so that L or a NewL become
L=[a,[b,f],c,[d-h]]

This is probably what you want:
unite([[],[]], []).
unite([[X|Ls], [X|Rs]], [X|Rest]) :- unite([Ls, Rs], Rest).
unite([[L|Ls], [R|Rs]], [[L,R]|Rest]) :- L \= R, unite([Ls, Rs], Rest).
However, I agree with #false because this is a strange API and there are a lot of unhandled edge cases.

What you're requiring is an aggregation schema. I think I got it:
unite(Ls, [E|Es]) :-
aggreg(Ls, E, Ns),
unite(Ns, Es).
unite(_, []).
aggreg(L, E, LLs) :-
maplist(first, L, Fs, LLs),
setof(X, member(X, Fs), S),
( [E] = S -> true ; E = S ).
first([E|Es], E, Es).
yields
?- L=[[a,b,c,d],[a,f,c,h],[a,f,c,g]],unite(L,U).
L = [[a, b, c, d], [a, f, c, h], [a, f, c, g]],
U = [a, [b, f], c, [d, g, h]] ;
L = [[a, b, c, d], [a, f, c, h], [a, f, c, g]],
U = [a, [b, f], c] .
I think that a cut after the first solution would be well placed (use once/1 for that).
Note that the schema it's rather general: just substitute in setof/3 some more applicative task (if any) than unification (you could call into your DB, for instance).

using prolog to generate sentences

Consider the following list of states:
[Sin,S2,S3,...,Sout]
and following rules:
it is possible to go back from S(n) to S(n-1) if there is such
S(n-1)
it is not possible to go back from S(out)
a sentence always begins with S(in) and ends with S(out)
I would like to have a rule that could be activated like this:
?- sentence(X, backs)
in which 'backs' means how many times a "back" is allowed.
For this list [a,b,c,d]
?- sentence(x, 2)
would generate:
[a,b,c,d] %no backs
[a,b,a,b,c,d] %one back
[a,b,c,b,c,d] %from d we cannot go back
[a,b,a,b,c,b,c,d] %two backs
[a,b,c,b,a,b,c,d] %two backs

Here's something that seems to be working:
sentence( [A|B], N, [A|X]) :- B=[_|_] -> sentence(B,[A],N,X)
; B = X.
sentence( B, _, 0, B). % no more moves back left
sentence( [B,C], _, N, [B,C]):- N>0. % no going back from end node
sentence( [B|C], A, N, [B|X]):- N>0, C=[_|_],
sentence( C, [B|A], N, X). $ fore
sentence( [B|C], [A|D], N, [B|X]):- N>0, C=[_|_], N1 is N-1,
sentence( [A,B|C], D, N1, X). $ aft
Running it gives me
23 ?- sentence([a,b,c,d],2,X).
X = [a, b, c, d] ;
X = [a, b, c, b, c, d] ;
X = [a, b, c, b, c, b, c, d] ;
X = [a, b, c, b, a, b, c, d] ;
X = [a, b, a, b, c, d] ;
X = [a, b, a, b, c, b, c, d] ;
X = [a, b, a, b, a, b, c, d] ;
No

Prolog mystery(c,[a,b,c,d],Z)

I think the answer is 3 but I am not sure, can anyone provide some help?
Suppose the following two statements are entered into Prolog:
mystery(X,[X|L],L).
mystery(X,[Y|L],[Y|M]) :- mystery(X,L,M).
What would Prolog return if one then gives it the following goal?
?- mystery(c,[a,b,c,d],Z).

So, mystery/3 is defined as:
mystery(X, [X|L], L).
mystery(X, [Y|L], [Y|M]) :- mystery(X, L, M).
There are (at least) three ways to look at mystery:
It takes an element X (first parameter), looks for its existence in a given list (second parameter) and returns that same list, minus one occurrence of X (third parameter). Thus:
?- mystery(c, [a, b, c, d], Z).
Z = [a, b, d] ;
fail.
?- mystery(c, [a, b, c, d, c], Z).
Z = [a, b, d, c] ;
Z = [a, b, c, d] ;
fail.
Another way to look at mystery is that it checks whether the lists constituting its second and third argument only differ with respect to one element, i.e. that the second list equals the third list, except that it has one additional element in one place. Thus:
?- mystery(X, [a, b, c, d], [a, b]).
fail.
?- mystery(X, [a, b, c, d], [a, b, c]).
X = d ;
fail.
Note that order is important:
?- mystery(X, [a, b, c, d], [a, c, b]).
fail.
Lastly, mystery can also generate all ways in which the first argument can be interspersed in the list of the third argument. Thus:
?- mystery(d, Y, [a, b, c]).
Y = [d, a, b, c] ;
Y = [a, d, b, c] ;
Y = [a, b, d, c] ;
Y = [a, b, c, d] ;
fail.

Resources