I need help coding a program in Prolog that returns true if a list has n number of [a, c] and m number of b. But it must be in this order: a,b,c if there are the letters a,b,c in the list. In the list, the numbers of a and c must be the same, and the number of b can be whatever. Example : [] is true, [b] is true, [a,b,c] is true, [a,c] is true, [a,b,b,b,b,c] is true, [a,a,b,c,c] is true. But [b,c] is false, [a,b] is false, [a,a,b,c] is false.
Here is what I tried to do, I have n numbers of a and m numbers of b, but I just need to have the list to end with n numbers of c (same amount as a) :
langageAB([b]).
langageAB([b | S]):-
langageAB(S).
langage8([]).
langage8([a,b]).
langage8([a | S]):-
langage8(S).
langage8([a |S]):-
langageAB(S).
More performant answer:
abc_list3(ABCs) :-
length(ABCs, ABCsLen),
MaxAsLen is ABCsLen div 2,
between(0, MaxAsLen, AsLen),
% Same length for as and cs
length(As, AsLen),
length(Cs, AsLen),
BsLen is ABCsLen - (AsLen * 2),
length(Bs, BsLen),
% Length of As, Bs and Cs has already been defined
append([As, Bs, Cs], ABCs),
% Contents of the 3 segments
maplist(=(a), As),
maplist(=(b), Bs),
maplist(=(c), Cs).
Result in swi-prolog:
?- time(findnsols(13, L, abc_list3(L), Ls)).
% 554 inferences, 0.000 CPU in 0.000 seconds (100% CPU, 1735654 Lips)
Ls = [[],[b],[b,b],[a,c],[b,b,b],[a,b,c],[b,b,b,b],[a,b,b,c],[a,a,c,c],[b,b,b,b,b],[a,b,b,b,c],[a,a,b,c,c],[b,b,b,b,b,b]]
Original, less performant answer:
abc_list2(ABCs) :-
% Start at length 0, if ABCs is uninstantiated
length(ABCs, _ABCsLen),
append([As, Bs, Cs], ABCs),
% Same length for as and cs
length(As, AsLen),
length(Cs, AsLen),
% Contents of the 3 segments
maplist(=(a), As),
maplist(=(b), Bs),
maplist(=(c), Cs).
Result in swi-prolog:
?- time(findnsols(13, L, abc_list2(L), Ls)).
% 982 inferences, 0.001 CPU in 0.001 seconds (100% CPU, 1957806 Lips)
Ls = [[], [b], [b, b], [a, c], [b, b, b], [a, b, c], [b, b, b, b], [a, b, b, c], [a, a, c, c], [b, b, b, b, b], [a, b, b, b, c], [a, a, b, c, c], [b, b, b, b, b, b]]
Performance comparison:
?- time(findnsols(5000, _, abc_list3(_), _)).
% 1,542,075 inferences, 0.125 CPU in 0.124 seconds (101% CPU, 12337474 Lips)
?- time(findnsols(5000, _, abc_list2(_), _)).
% 37,702,800 inferences, 4.226 CPU in 4.191 seconds (101% CPU, 8921614 Lips)
Related
What I want is something like merge(Dict1, Dict2, Merged) that behaves like the following:
?- merge(counter{a: 1, b: 2}, counter{a: 3, c: 4, d: 5}, Merged).
Merged = counter{a: 4, b: 2, c: 4, d: 5}
What should I do to achieve this? I'm totally new to logic programming, so I end up failing trying to write something that looks like a terrible port of for loop of other languages.
dicts_merge_add(Dict1, Dict2, DictMerged) :-
% Convert to sorted key-value pairs
dict_pairs(Dict1, Tag, Pairs1),
dict_pairs(Dict2, Tag, Pairs2),
% Merge the pairs
pairs_merge_add(Pairs1, Pairs2, PairsMerged),
% Convert to dict
dict_pairs(DictMerged, Tag, PairsMerged).
% When reached end of 1 list, insert the remains of the other list
pairs_merge_add([], T, T) :- !.
pairs_merge_add(T, [], T) :- !.
pairs_merge_add([K-V1|T1], [K-V2|T2], L) :-
% Keys are same
!,
Sum is V1 + V2,
L = [K-Sum|Merg],
pairs_merge_add(T1, T2, Merg).
pairs_merge_add([K1-V1|T1], [K2-V2|T2], L) :-
K1 #< K2,
!,
L = [K1-V1|Merg],
pairs_merge_add(T1, [K2-V2|T2], Merg).
pairs_merge_add([K1-V1|T1], [K2-V2|T2], L) :-
K1 #> K2,
!,
L = [K2-V2|Merg],
pairs_merge_add([K1-V1|T1], T2, Merg).
Result in swi-prolog:
?- D1 = counter{a: 1, b: 2, z:6},
D2 = counter{a: 3, c: 4, z:8, d: 5},
time(dicts_merge_add(D1, D2, Merg)).
% 17 inferences, 0.000 CPU in 0.000 seconds (88% CPU, 389265 Lips)
D1 = counter{a:1,b:2,z:6},
D2 = counter{a:3,c:4,d:5,z:8},
Merg = counter{a:4,b:2,c:4,d:5,z:14}.
Simple performance test:
?- C = 30_000, numlist(1, C, L1N),
findall(N-N, member(N, L1N), L1),
dict_pairs(D1, v, L1), numlist(1, C, L2N),
findall(N-N, member(N, L2N), L2), dict_pairs(D2, v, L2),
time(merge(D1, D2, D3)), sleep(10).
% 180,005 inferences, 5.475 CPU in 5.486 seconds (100% CPU, 32877 Lips)
Vs mine: time(dicts_merge_add(D1, D2, D3))
% 60,005 inferences, 0.012 CPU in 0.012 seconds (100% CPU, 4987461 Lips)
This shows the huge performance advantage from using the fact that the lists are sorted.
This approach gets the entries from A, recurses over them and merges them into B:
merge(A, B, Merged) :-
dict_pairs(A, _, Pairs), % Pairs are an ordered set
merge_(Pairs, B, Merged).
merge_([], Merged, Merged). % No more pairs, merge finished.
merge_([K-V|Ps], B, Merged) :- % Merge Key-Value from A.
(get_dict(K, B, Bval) -> % Get the matching item from B.
Sum is V + Bval % if success, sum their values.
; Sum is V), % if not, just the value from A.
put_dict(K, B, Sum, B_), % merge into B.
merge_(Ps, B_, Merged). % merge remaining pairs into B.
On SWISH:
?- _D1 = counter{a: 1, b: 2, z:6},
_D2 = counter{a: 3, c: 4, z:8, d: 5},
time(merge(_D1, _D2, Merg)).
Merg = counter{a:4, b:2, c:4, d:5, z:14}
19 inferences, 0.000 CPU in 0.000 seconds (116% CPU, 827526 Lips)
I am using Prolog and I am trying to find the intersection or the common elements between two lists and the result should not contain duplicates. In addition, the case of lists with different lengths should be handled. The result of the predicate should be as follows:
?-no_duplicates_intersection([a,v,a,c],[a,a,a,a,a],L).
L = a.
Actually, I found a question or two tackling the same issue, but the answers were way too long. I was wondering if there was a more straightforward and easier method using the following predicate, which returns the intersection between two lists with duplicates:
intersection_with_dulpicates([], [], []).
intersection_with_dulpicates([],M,[]).
intersection_with_dulpicates([X|Y],M,[X|Z]):-
member(X,M),
intersection_with_dulpicates(Y,M,Z).
intersection_with_dulpicates([X|Y],M,Z):-
\+member(X,M),
intersection_with_dulpicates(Y,M,Z).
Taking advantage of the built-in sort (which also removes duplicates):
intersection_without_duplicates(Lst1, Lst2, Intersection) :-
% Sort and remove duplicates from both
% The built-in sort is quick
sort(Lst1, Lst1Sorted),
sort(Lst2, Lst2Sorted),
intersect_sorted(Lst1Sorted, Lst2Sorted, Intersection).
intersect_sorted([], _Lst2Sorted, []).
intersect_sorted([H|T], LstSorted, Intersection) :-
( member_listsorted(H, LstSorted)
-> Intersection = [H|Intersection0]
; Intersection0 = Intersection
),
intersect_sorted(T, LstSorted, Intersection0).
member_listsorted(H, LstSorted) :-
member_listsorted_(LstSorted, H).
member_listsorted_([H|T], Elem) :-
( H #< Elem
-> member_listsorted_(T, Elem)
; H = Elem
).
Sample output in swi-prolog:
?- time(intersection_without_duplicates([a, b, c, d, b, c, d], [b, c, b, c, d],
I)).
% 31 inferences, 0.000 CPU in 0.000 seconds (89% CPU, 586277 Lips)
I = [b,c,d].
?- numlist(1, 10000, Lst1), numlist(5000, 12345, Lst2), time((intersection_without_duplicates(Lst1, Lst2, Intersection))).
% 25,060,003 inferences, 1.313 CPU in 1.297 seconds (101% CPU, 19090034 Lips)
Performance comparison with #TessellatingHeckler's suggestion:
?- numlist(1, 10000, Lst1), numlist(5000, 12345, Lst2), time((intersection(Lst1, Lst2, Both), sort(Both, Answer))).
% 35,001 inferences, 2.193 CPU in 2.167 seconds (101% CPU, 15957 Lips)
Following the design of intersection_with_dulpicates you can try
no_duplicates_intersection([], _L2, []).
no_duplicates_intersection([X|Y],L, Intersection):-
no_duplicates_intersection(Y,L,Cur_intersection),
( (member(X, Cur_intersection); \+ member(X,L))
-> Intersection = Cur_intersection
; Intersection = [X | Cur_intersection]).
How can I make a program in Prolog that contains n numbers of a and n numbers of b, it's important to note here that the number of a and b in the list must be equal, also the list must always start with a and finish with b, otherwise it's false. Example : [a,b] is true, [a,a,a,b,b,b] is true, [a,a,a,a] is false and [a,a,a,b,b] is also false.
Here is what I tried to do :
langageB([b]).
langageB([b| S]):- langageB(S).
language([]).
langage([a,b]).
langage([a | S]):- langage(S).
langage([a| S]):- langageB(S).
But it does not work as I want it to.
Using DCG notation, the desired language can be defined as:
langage --> [a,b].
langage --> [a], langage, [b]. % For each a at the beginning of the list
% there must be a corresponding b at the end
langage(List) :- phrase(langage, List).
Examples:
?- langage([a,a,a,b,b,b]).
true .
?- langage([a,a,b,b,b]).
false.
?- langage(L).
L = [a, b] ;
L = [a, a, b, b] ;
L = [a, a, a, b, b, b] ;
L = [a, a, a, a, b, b, b, b] .
If you want to see how to define the predicate directly using difference lists, you can list the clauses of the predicate langage/2:
?- listing(langage).
langage([a, b|A], A).
langage([a|A], B) :-
langage(A, C),
C=[b|B].
So, an alternative solution is:
langage(List) :-
langage(List, []).
langage([a, b|A], A).
langage([a|A], B) :-
langage(A, C),
C = [b|B].
langage --> [a], ( [] | langage ) , [b].
?- phrase(langage, Xs).
Xs = "ab"
; Xs = "aabb"
; Xs = "aaabbb"
; Xs = "aaaabbbb"
; Xs = "aaaaabbbbb"
; ... .
Assuming e.g. [a, b, a, b] is an acceptable list:
go :-
findnsols(20, ABs, ab_list(ABs), ABsLst), !,
writeln(ABsLst).
ab_list(ABsWrapped) :-
length(ABs, Len),
ab_list_(Len, 0, [], ABs),
append([[a], ABs, [b]], ABsWrapped).
ab_list_(0, 0, ABs, ABs) :- !.
ab_list_(CharsToAdd, Bal, SoFar, ABs) :-
succ(CharsToAdd0, CharsToAdd),
add_char(Char, Inc),
Bal1 is Bal + Inc,
% Ensure that the balance can be zero for the complete list
CharsToAdd0 >= abs(Bal1),
ab_list_(CharsToAdd0, Bal1, [Char|SoFar], ABs).
add_char(b, -1).
add_char(a, 1).
Results:
?- time(go).
[[a,b],[a,a,b,b],[a,b,a,b],[a,a,a,b,b,b],[a,a,b,a,b,b],[a,b,a,a,b,b],[a,a,b,b,a,b],[a,b,a,b,a,b],[a,b,b,a,a,b],[a,a,a,a,b,b,b,b],[a,a,a,b,a,b,b,b],[a,a,b,a,a,b,b,b],[a,b,a,a,a,b,b,b],[a,a,a,b,b,a,b,b],[a,a,b,a,b,a,b,b],[a,b,a,a,b,a,b,b],[a,a,b,b,a,a,b,b],[a,b,a,b,a,a,b,b],[a,b,b,a,a,a,b,b],[a,a,a,b,b,b,a,b]]
% 935 inferences, 0.001 CPU in 0.001 seconds (100% CPU, 1419728 Lips)
Original: Here's a (very inefficient) solution as a one-liner in swi-prolog:
length(As, 2), same_length(As, Bs), maplist(=(a), As), maplist(=(b), Bs), append([As, Bs], ABs), distinct(ABsPerm, permutation(ABs, ABsPerm)), append([[a], ABsPerm, [b]], Final).
Today, I found a puzzle at https://puzzling.stackexchange.com/questions/22064/the-5040-square:
Fill a 4x4 grid with positive integers so that:
Every cell has a different integer
The product of the numbers in each row is 5040, and similarly for the columns
Source: This was an NPR weekly listener challenge, aired on 2005-10-09
Here's my first shot at solving the puzzle using clpfd:
:- use_module(library(clpfd)).
m5040_(Mss,Zs) :-
Mss = [[A1,A2,A3,A4],
[B1,B2,B3,B4],
[C1,C2,C3,C4],
[D1,D2,D3,D4]],
Zs = [A1,A2,A3,A4,B1,B2,B3,B4,C1,C2,C3,C4,D1,D2,D3,D4],
Zs ins 1..sup, % domain: positive integers
5040 #= A1*A2*A3*A4, % rows
5040 #= B1*B2*B3*B4,
5040 #= C1*C2*C3*C4,
5040 #= D1*D2*D3*D4,
5040 #= A1*B1*C1*D1, % columns
5040 #= A2*B2*C2*D2,
5040 #= A3*B3*C3*D3,
5040 #= A4*B4*C4*D4,
all_different(Zs). % pairwise inequality
Sample query:
?- m5040_(Mss,Zs), time(labeling([],Zs)).
% 416,719,535 inferences, 55.470 CPU in 55.441 seconds (100% CPU, 7512588 Lips)
Mss = [[1,3,16,105],[10,14,9,4],[21,8,5,6],[24,15,7,2]], Zs = [1,3,16,105|...] ;
...
My actual question is twofold:
How can I speed up the backtracking search process for one / for all solutions?
Which symmetries / redundancies could I exploit?
my inference counters (using your code) don't match yours... not sure why...
the first solution i get (with your code)
?- puzzle_5040.
% 464,043,891 inferences, 158.437 CPU in 160.191 seconds (99% CPU, 2928894 Lips)
[[1,3,16,105],[10,14,9,4],[21,8,5,6],[24,15,7,2]]
true
I thought that reducing the domain could speedup the result
:- use_module(library(clpfd)).
:- use_module(library(ordsets)).
:- use_module(library(apply)).
m5040_(Mss,Zs) :-
matrix(Mss),
flatten(Mss, Zs),
all_factors(Fs),
make_domain(Fs, Dom),
Zs ins Dom,
all_distinct(Zs),
maplist(m5040, Mss),
transpose(Mss, Tss), maplist(m5040, Tss).
m5040([A,B,C,D]) :- 5040 #= A * B * C * D.
length_(L, Xs) :- length(Xs, L).
matrix(Mss) :-
length_(4, Mss),
maplist(length_(4), Mss).
factors(L) :-
L = [A,B,C,D],
5040 #= 1 * 2 * 3 * U,
L ins 1..U,
all_distinct(L),
A #< B, B #< C, C #< D,
5040 #= A * B * C * D.
all_factors(AllFs) :-
findall(L, (factors(L),label(L)), Fs),
foldl(ord_union, Fs, [], AllFs).
but I was wrong, it was slower actually...
Since some time ago I tried CLP(FD) solving some Project Euler, and in some cases I found it was slower than raw arithmetic, I arranged a program that doesn't use CLP(FD), but reduces the domain to make it manageable:
puzzle_5040_no_clp :- time(puzzle_5040_no_clp(S)), writeln(S).
puzzle_5040_no_clp(S) :-
findall(F, factors(F), Fs),
factors_group(Fs, G),
once(solution(G, S)).
disjoint(A, B) :-
forall(member(X, A), \+ memberchk(X, B)).
eq5040([A,B,C,D]) :-
5040 =:= A * B * C * D.
factors([A, B, C, D]) :-
5040 #= 1 * 2 * 3 * U,
[A, B, C, D] ins 1..U,
A #< B, B #< C, C #< D,
5040 #= A * B * C * D,
label([A, B, C, D]).
all_factors(AllFs) :- % no more used
findall(L, factors(L), Fs),
foldl(ord_union, Fs, [], AllFs).
factors_group(Fs, [A, B, C, D]) :-
nth1(Ap, Fs, A),
nth1(Bp, Fs, B), Ap < Bp, disjoint(A, B),
nth1(Cp, Fs, C), Bp < Cp, disjoint(A, C), disjoint(B, C),
nth1(Dp, Fs, D), Cp < Dp, disjoint(A, D), disjoint(B, D), disjoint(C, D).
/*
solution([A,B,C,D], S) :-
maplist(permutation, [B,C,D], [U,V,Z]),
transpose([A,U,V,Z], S),
maplist(eq5040, S).
*/
solution(T0, [U,V,X,Y]) :-
peek5040(T0, U, T1),
peek5040(T1, V, T2),
peek5040(T2, X, T3),
peek5040(T3, Y, [[],[],[],[]]).
peek5040([A,B,C,D], [M,N,P,Q], [Ar,Br,Cr,Dr]) :-
select(M,A,Ar),
select(N,B,Br), M*N < 5040,
select(P,C,Cr), M*N*P < 5040,
select(Q,D,Dr), M*N*P*Q =:= 5040.
% only test
validate(G) :- maplist(eq5040, G), transpose(G, T), maplist(eq5040, T).
with this approach, getting all solutions
?- time(aggregate(count,puzzle_5040_no_clp,N)).
% 6,067,939 inferences, 1.992 CPU in 1.994 seconds (100% CPU, 3046002 Lips)
[[1,24,14,15],[3,21,10,8],[16,5,9,7],[105,2,4,6]]
% 111,942 inferences, 0.041 CPU in 0.052 seconds (79% CPU, 2758953 Lips)
[[1,24,10,21],[3,15,14,8],[16,7,9,5],[105,2,4,6]]
...
% 62,564 inferences, 0.033 CPU in 0.047 seconds (70% CPU, 1894080 Lips)
[[1,10,12,42],[15,28,3,4],[16,9,7,5],[21,2,20,6]]
% 37,323 inferences, 0.017 CPU in 0.027 seconds (65% CPU, 2164774 Lips)
[[1,14,12,30],[15,2,28,6],[16,9,5,7],[21,20,3,4]]
% 2,281,755 inferences, 0.710 CPU in 0.720 seconds (99% CPU, 3211625 Lips)
% 48,329,065 inferences, 18.072 CPU in 27.535 seconds (66% CPU, 2674185 Lips)
N = 354.
I'm writing a permutation function [a,b]-->[[[a], [b]], [[a, b]]
I have this so far, but it doesn't work.
perm([],[]).
perm(L,[H|T]) :- append(V,[H|U],L), append(V,U,W), perm(W,T).
Given your example, it looks like you might actually be wanting the powerset, not the permutation, of the given list.
For instance, the powerset of [a,b] is the set {[a,b], [a], [b], []}.
To compute the powerset of a list of items in Prolog, look at this answer by #gusbro. If this helps you, also please upvote that answer.
If you want all solutions of the powerset of a list L at once, you can wrap the call to powerset/2 in a findall/3 call like this:
?- findall(S, powerset(L, S), Ss).
If, on the other hand, you're after the partitions (as you've mentioned in one of your earlier edits), consider the following:
partition(L, PL) :-
partition(L, [], PL).
partition([], [], []).
partition([X|Xs], As, R) :-
% add X into the new partition...
append(As, [X], NewAs),
partition(Xs, NewAs, R).
partition(L, [A|As], [[A|As]|R]) :-
% ...or, collect the current non-empty partition
partition(L, [], R).
The predicate partition/2 takes a list and returns all partitions, as you've described. For example:
?- partition([a,b,c],L).
L = [[a, b, c]] ;
L = [[a, b], [c]] ;
L = [[a], [b, c]] ;
L = [[a], [b], [c]] ;
false.
Really? It seems to work in SWI-Prolog:
?- [user].
|: perm([],[]).
|: perm(L,[H|T]) :- append(V,[H|U],L), append(V,U,W), perm(W,T).
|: % user://1 compiled 0.00 sec, 3 clauses
true.
?- perm([a,b,c], X).
X = [a, b, c] ;
X = [a, c, b] ;
X = [b, a, c] ;
X = [b, c, a] ;
X = [c, a, b] ;
X = [c, b, a] ;
false.
?- perm([a,b,c,d], X).
X = [a, b, c, d] ;
/* trimming 22 solutions */
X = [d, c, b, a] ;
false.
This also yields the number of answers you'd expect: 3! = 6, 4! = 24. What's not working for you?
Quick note: Prolog doesn't offer functions, but relations.
In this case, perm/2 will hold true when the arguments are one the permutation of the other.
I find this definition more readable than your.
perm([], []).
perm([E|Es], P) :-
perm(Es, Q),
select(E, P, Q).
It's almost the same as that of permutation/2 SWI-Prolog, but hides a bug...