Related
Can you help me, I can't figure out how to do this: the replace_last predicate to replace the last occurrence of a given element in the list with the specified new value
replace_last(InList, OutList) :-
append([[First], Middle, [Last]], InList),
append([[Last], Middle, [First]], OutList).
I would use negation:
replace_last(Input,Find,Replace,Output) :-
append(X,[Find|Y],Input),
\+ memberchk(Find,Y),
append(X,[Replace|Y],Output).
Using backtracking:
replace_last_elem_match(Find, Replacement, Lst, LstReplaced) :-
last_elem_match_copy(Find, Lst, LstReplaced, Tail, After),
Tail = [Replacement|After].
last_elem_match_copy(Find, Lst, LstReplaced, Tail, After) :-
last_elem_match_copy_(Lst, Find, LstReplaced, Tail, After).
last_elem_match_copy_([H|T], Find, [H|LstReplaced], Tail, After) :-
last_elem_match_copy_(T, Find, LstReplaced, Tail, After), !.
last_elem_match_copy_([Find|T], Find, Tail, Tail, T).
Result in swi-prolog:
?- time(replace_last_elem_match(a, z, [a,a,b,a,c,a], R)).
% 9 inferences, 0.000 CPU in 0.000 seconds (87% CPU, 399078 Lips)
R = [a,a,b,a,c,z].
However, #CapelliC's solution is faster (presumably because memberchk is native in swi-prolog) - performance comparisons:
?- numlist(1, 1_000_000, L), time(replace_last_elem_match(99999, z, L, R)).
% 1,000,003 inferences, 1.469 CPU in 1.472 seconds (100% CPU, 680792 Lips)
?- numlist(1, 1_000_000, L), time(replace_last(L, 99999, z, R)).
% 200,001 inferences, 0.023 CPU in 0.024 seconds (100% CPU, 8517234 Lips)
?- length(L, 1_000_000), maplist(=(a), L), time(replace_last_elem_match(a, z, L, R)).
% 1,000,003 inferences, 0.696 CPU in 0.698 seconds (100% CPU, 1436214 Lips)
?- length(L, 1_000_000), maplist(=(a), L), time(replace_last(L, a, z, R)).
% 4,000,001 inferences, 0.453 CPU in 0.454 seconds (100% CPU, 8824459 Lips)
I suppose you could use append/3 to do this, but that seems like using a shotgun to swat a fly:
replace_last( A , Bs , Cs ) :-
append( B1 , [_] , Bs ) ,
append( B1 , [A] , Cs )
.
But is that any simpler, or easier to understand than this?
replace_last( A , [_] , [A] ) .
replace_last( A , [B|Bs] , [B|Cs] ) :- replace_last(A,Bs,Cs) .
[It's certainly not as performant.]
You can fiddle with it at https://swish.swi-prolog.org/p/tAnrXzKn.pl
I think this is the fastest method found so far:
last_match_replace(Find, Replace, Lst, LstReplaced) :-
phrase(last_match_replace_(Find, Replace, LstReplaced, Tail), Lst, Tail), !.
last_match_replace_(Find, Replace, Before, BeforeTail, Lst, [Replace|Rem]) :-
match_find(Lst, Find, Before, BeforeTail, Rem),
\+ memberchk(Find, Rem).
match_find([Find|L], Find, T, T, L).
match_find([E|L], Find, [E|T], Tail, Rem) :-
match_find(L, Find, T, Tail, Rem).
Results in swi-prolog:
?- numlist(1, 1_000_000, L), time(last_match_replace(99999, z, L, R)).
% 100,011 inferences, 0.028 CPU in 0.028 seconds (100% CPU, 3514803 Lips)
?- length(L, 1_000_000), maplist(=(a), L), time(last_match_replace(a, z, L, R)).
% 3,000,010 inferences, 0.177 CPU in 0.177 seconds (100% CPU, 16962407 Lips)
I want to implement SKI combinators in Prolog.
There are just 3 simple rules:
(I x) = x
((K x) y) = x
(S x y z) = (x z (y z))
I came up with the following code by using epilog:
term(s)
term(k)
term(i)
term(app(X,Y)) :- term(X) & term(Y)
proc(s, s)
proc(k, k)
proc(i, i)
proc(app(i,Y), Y1) :- proc(Y,Y1)
proc(app(app(k,Y),Z), Y1) :- proc(Y,Y1)
proc(app(app(app(s,P1),P2),P3), Y1) :- proc(app( app(P1,P3), app(P2, P3) ), Y1)
proc(app(X, Y), app(X1, Y1)) :- proc(X, X1) & proc(Y, Y1)
proc(X,X)
It works for some cases but has 2 issues:
It takes too much time to execute simple queries:
term(X) & proc(app(app(k, X), s), app(s,k))
100004 unification(s)
It requires multiple queries to process some terms. For example:
((((S(K(SI)))K)S)K) -> (KS)
requires 2 runs:
proc(app(app(app(app(s,app(k,app(s,i))),k),s),k), X) ==>
proc(app(app(app(app(s,app(k,app(s,i))),k),s),k), app(app(app(s,i),app(k,s)),k))
proc(app(app(app(s,i),app(k,s)),k), X) ==>
proc(app(app(app(s,i),app(k,s)),k), app(k,s))
Can you please suggest how to optimize my implementation and make it work on complex combinators?
edit: The goal is to reduce combinators. I want to enumerate them (without duplicates) where the last one is in normal form (if it exists of course).
It can be implemented with iterative deepening like this:
term(s) --> "S".
term(k) --> "K".
term(i) --> "I".
term(a(E0,E)) --> "(", term(E0), term(E), ")".
reduce_(s, s).
reduce_(k, k).
reduce_(i, i).
% Level 1.
reduce_(a(s,A0), a(s,A)) :-
reduce_(A0, A).
reduce_(a(k,A0), a(k,A)) :-
reduce_(A0, A).
reduce_(a(i,A), A).
% level 2.
reduce_(a(a(s,E0),A0), a(a(s,E),A)) :-
reduce_(E0, E),
if_(E0 = E, reduce_(A0, A), A0 = A).
% reduce_(A0, A). % Without `reif`.
reduce_(a(a(k,E),_), E).
reduce_(a(a(i,E),A), a(E,A)).
% level 3.
reduce_(a(a(a(s,E),F),A), a(a(E,A),a(F,A))).
reduce_(a(a(a(k,E),_),A), a(E,A)).
reduce_(a(a(a(i,E),F),A), a(a(E,F),A)).
% Recursion.
reduce_(a(a(a(a(E0,E1),E2),E3),A0), a(E,A)) :-
reduce_(a(a(a(E0,E1),E2),E3), E),
if_(a(a(a(E0,E1),E2),E3) = E, reduce_(A0, A), A0 = A).
% reduce_(A0, A). % Without `reif`.
step(E, E0, E) :-
reduce_(E0, E).
reduce_(N, E0, E, [E0|Es]) :-
length(Es, N),
foldl(step, Es, E0, E).
reduce(N, E0, E) :-
reduce_(N, E0, E, _),
reduce_(E, E), % Fix point.
!. % Commit.
The term can be inputted and outputted as a list of characters with term//1. The grammar rule term//1 can also generate unique terms.
?- length(Cs, M), M mod 3 =:= 1, phrase(term(E0), Cs).
The goal is to be as lazy as possible when reducing a term thus dif/2 and the library reif is used in reduce_/2. The predicate reduce_/2 does a single reduction. If any of the argument of reduce_/2 is ground then termination is guarantee (checked with cTI).
To reduce a term, reduce_/4 can be used. The first argument specifies the depth, the last argument holds the list of terms. The predicate reduce_/4 is pure and does not terminate.
?- Cs = "(((SK)K)S)", phrase(term(E0), Cs), reduce_(N, E0, E, Es).
The predicate reduce/3 succeeds if there is a normal form. It is recommended to provide a maximum depth (e.g. Cs = "(((SI)I)((SI)(SI)))"):
?- length(Cs, M), M mod 3 =:= 1, phrase(term(E0), Cs), \+ reduce(16, E0, _).
Test with ((((S(K(SI)))K)S)K):
?- Cs0 = "((((S(K(SI)))K)S)K)", phrase(term(E0), Cs0),
reduce(N, E0, E), phrase(term(E), Cs).
Cs0="((((S(K(SI)))K)S)K)", E0=a(a(a(a(s,a(k,a(s,i))),k),s),k), N=5, E=a(k,s), Cs="(KS)"
Translating your code trivially to Prolog, using the built-in left-associating infix operator - for app, to improve readability,
term(s).
term(k).
term(i).
term( X-Y ) :- term(X) , term(Y).
/* proc(s, s). %%% not really needed.
proc(k, k).
proc(i, i). */
proc( i-Y, Y1) :- proc( Y,Y1).
proc( k-Y-Z, Y1) :- proc( Y,Y1).
proc( s-X-Y-Z, Y1) :- proc( X-Z-(Y-Z), Y1).
proc( X-Y, X1-Y1 ) :- proc( X, X1) , proc( Y, Y1).
proc( X, X).
executing in SWI Prolog,
26 ?- time( (term(X), proc( k-X-s, s-k)) ).
% 20 inferences, 0.000 CPU in 0.001 seconds (0% CPU, Infinite Lips)
X = s-k ;
% 1 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = s-k ;
Action (h for help) ? abort
% 952,783 inferences, 88.359 CPU in 90.112 seconds (98% CPU, 10783 Lips)
% Execution Aborted
27 ?-
the first result is produced in 20 inferences.
Furthermore, indeed
32 ?- time( proc( s-(k-(s-i))-k-s-k, X) ).
% 10 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = s-i- (k-s)-k ;
% 2 inferences, 0.000 CPU in 0.001 seconds (0% CPU, Infinite Lips)
X = s-i- (k-s)-k ;
% 5 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = s-i- (k-s)-k ;
% 2 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = s-i- (k-s)-k ;
% 11 inferences, 0.000 CPU in 0.001 seconds (0% CPU, Infinite Lips)
X = k- (s-i)-s- (k-s)-k ;
% 2 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = k- (s-i)-s- (k-s)-k . % stopped manually
and then
33 ?- time( proc( s-i- (k-s)-k, X) ).
% 5 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = k-s ;
% 5 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = k- (k-s-k) ;
% 2 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = k- (k-s-k) ;
% 1 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = k- (k-s-k) ;
% 5 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = i-k-s ;
% 5 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = i-k- (k-s-k) ;
% 2 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = i-k- (k-s-k) ;
% 1 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = i-k- (k-s-k) ;
% 3 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = i-k-s ;
% 5 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
X = i-k- (k-s-k) . % stopped manually
but probably the result you wanted will still get generated directly, just after some more time.
Based on Will Ness answer here is my solution:
term(s).
term(k).
term(i).
term(app(X,Y)) :- term(X), term(Y).
eq(s,s).
eq(k,k).
eq(i,i).
eq(app(X,Y),app(X,Y)).
proc(s, s).
proc(k, k).
proc(i, i).
proc(app(i,Y), Y1) :- proc(Y,Y1).
proc(app(app(k,Y),Z), Y1) :- proc(Y,Y1).
proc(app(app(app(s,P1),P2),P3), Y1) :- proc(app( app(P1,P3), app(P2, P3) ), Y1).
proc(app(X, Y), Z) :- proc(X, X1), proc(Y, Y1), eq(X, X1), eq(X, X1), eq(app(X, Y), Z).
proc(app(X, Y), Z) :- proc(X, X1), proc(Y, Y1), not(eq(X, X1)), proc(app(X1, Y1), Z).
proc(app(X, Y), Z) :- proc(X, X1), proc(Y, Y1), not(eq(Y, Y1)), proc(app(X1, Y1), Z).
Move code to swish prolog. It works much faster
time((term(X), proc(app(app(k, X), s), app(s,k)))).
% 356 inferences, 0.000 CPU in 0.000 seconds (94% CPU, 3768472 Lips)
X = app(s,k)
Implemented complete reduction procedure:
proc(app(app(app(app(s,app(k,app(s,i))),k),s),k), X)
answer contains: X = app(k,s)
There are still issues that I can not resolve
time((term(X), proc(app(app(X, k), s), app(s,k)))). runs forever
Answers are not ordered by reductions.
I would like to replace a sequence of tokens in a DCG grammar in Prolog. In other words replace the sequence or sublist A: [a,a,a,a] by the sublist B: [b].
chain --> chain_where_sublist_A_is_replaced_by_sublist_B but entirely using the DCG formalism.
For example: [c,a,a,a,a,d] gives [c,b,d]
First solution:
eos_([], []).
transform --> call(eos_).
transform, [b] --> [a,a,a], transform.
transform, [c] --> [c], transform.
transform, [d] --> [d], transform.
Then the query:
?- phrase(transform, "caaad", Cs).
Cs = "cbd"
Second solution:
step(b) --> [a,a,a].
step(C) --> [C].
transform([]) --> [].
transform([C|Cs]) --> step(C), transform(Cs).
Then the query:
?- phrase(transform(Cs), "caaad").
Cs = "cbd"
As at Prolog - substitute substring of string by letter not used in string itself
replace(Find, Replace), Replace --> Find, !, replace(Find, Replace).
% Otherwise accept char-by-char
replace(Find, Replace), [C] --> [C], !, replace(Find, Replace).
% Accept success when reached end
replace(_Find, _Replace) --> [].
substitute(Find, Replace, Request, Result):-
phrase(replace(Find, Replace), Request, Result).
In swi-prolog:
?- substitute([a,a,a,a], [b], [c,a,a,a,a,d], S).
S = [c,b,d].
Using difference lists rather than DCG, to be faster (due in part to tail-end recursion) and also more widely compatible with Prolog systems:
find_replace_list(Find, Replace, Lst, Result) :-
find_replace_list_(Lst, Find, Replace, Result).
find_replace_list_([], _Find, _Replace, []).
find_replace_list_([H|T], Find, Replace, Result) :-
list_begins_dl(Find, [H|T], Tail),
!,
append(Replace, Result0, Result),
find_replace_list_(Tail, Find, Replace, Result0).
find_replace_list_([H|T], Find, Replace, [H|Result]) :-
find_replace_list_(T, Find, Replace, Result).
list_begins_dl([], T, T).
list_begins_dl([H|TShort], [H|TLong], Tail) :-
list_begins_dl(TShort, TLong, Tail).
Performance comparison in swi-prolog:
?- numlist(1, 1_000_000, L), time(find_replace_list([a,a,a,a], [b], L, S)).
% 2,000,002 inferences, 0.231 CPU in 0.231 seconds (100% CPU, 8649354 Lips)
?- numlist(1, 1_000_000, L), time(substitute([a,a,a,a], [b], L, S)).
% 16,000,024 inferences, 2.081 CPU in 2.081 seconds (100% CPU, 7689631 Lips)
?- length(L, 1_000_000), maplist(=(1), L), time(find_replace_list([1], [2], L, S)).
% 5,000,002 inferences, 0.421 CPU in 0.421 seconds (100% CPU, 11865099 Lips)
?- length(L, 1_000_000), maplist(=(1), L), time(substitute([1], [2], L, S)).
% 25,000,021 inferences, 2.962 CPU in 2.962 seconds (100% CPU, 8439159 Lips)
Result:
?- find_replace_list([a,a,a,a], [b], [c,a,a,a,a,d], S).
S = [c,b,d].
We want to count the correspondences between two (possibly long) strings which happen to represent DNA sequences. The sequences are lists-of-chars where the char is taken from a,c,t,g,'_', with the '_' a "don't know" placeholder which never corresponds to anything, even itself. In this case, we employ library(aggregate) (thanks to CapelliC for the idea):
match(Seq1,Seq2,Count) :-
aggregate_all(count,
(
nth1(Pos,Seq1,X),
nth1(Pos,Seq2,X),
memberchk(X,[a,c,g,t])
),
N).
This approach can be compared to a "straightforward" approach where one would set up a (tail-recursive) recursion that just walks down both sequences in tandem and compares elements pairwise, counting as it goes.
As the sequences can be very large, algorithmic complexity becomes of some interest.
One would expect, with n = length(sequence) and both sequences the same length:
Straightforward approach: complexity is O(n)
aggregation approach: complexity is O(n²)
What is the (time and maybe space) complexity of the above algorithm and why?
Test code
To complement the above, an SWI-Prolog based plunit test code block:
:- begin_tests(atcg).
wrap_match(String1,String2,Count) :-
atom_chars(String1,Seq1),
atom_chars(String2,Seq2),
fit(Seq1,Seq1,0,Count).
test("string 1 empty",nondet) :-
wrap_match("atcg","",Count),
assertion(Count == 0).
test("string 2 empty") :-
wrap_match("","atcg",Count),
assertion(Count == 0).
test("both strings empty") :-
wrap_match("","",Count),
assertion(Count == 0).
test("both strings match, 1 char only") :-
wrap_match("a","a",Count),
assertion(Count == 1).
test("both strings match") :-
wrap_match("atcgatcgatcg","atcgatcgatcg",Count),
assertion(MatchCount == 12).
test("both strings match with underscores") :-
wrap_match("_TC_ATCG_TCG","_TC_ATCG_TCG",Count),
assertion(MatchCount == 9).
test("various mismatches 1") :-
wrap_match("atcgatcgatcg","atcgatcgatcg",Count),
assertion(MatchCount == 8).
test("various mismatches with underscores") :-
wrap_match("at_ga_cg__cg","atcgatcgatcg",Count),
assertion(Count == 8).
:- end_tests(atcg).
And so:
?- run_tests.
% PL-Unit: atcg ........ done
% All 8 tests passed
true.
Empirical info
After some manual data collection (something that cries out for automatization) using the code below, which outputs time elapsed and number of inferences made to the console:
gimme_random_sequence(Length,Seq) :-
length(Seq,Length),
maplist(
[E]>>(random_between(0,3,Ix),nth0(Ix,[a,t,c,g],E)),
Seq).
how_fast(Length) :-
gimme_random_sequence(Length,Seq1),
gimme_random_sequence(Length,Seq2),
time(match(Seq1,Seq2,_)).
... and a bit of graph fumbling in LibreOffice Calc (my ggplot skills are rusty), we have empirical data that this algorithm's cost is
O((length(sequence))²).
Count,Inferences,Seconds,milliseconds,megainferences
1000,171179,0.039,39,0.171179
2000,675661,0.097,97,0.675661
3000,1513436,0.186,186,1.513436
4000,2684639,0.327,327,2.684639
5000,4189172,0.502,502,4.189172
6000,6027056,0.722,722,6.027056
7000,8198103,1.002,1002,8.198103
8000,10702603,1.304,1304,10.702603
9000,13540531,1.677,1677,13.540531
10000,16711607,2.062,2062,16.711607
11000,20216119,2.449,2449,20.216119
20000,66756619,8.091,8091,66.756619
30000,150134731,17.907,17907,150.134731
40000,266846773,32.012,32012,266.846773
50000,416891749,52.942,52942,416.891749
60000,600269907,74.103,74103,600.269907
Never ever use functional programming idioms in Prolog that avoid backtracking, like maplist/4. This here, pair_member/4 and match3/3, should be a tick faster.
match2(Seq1, Seq2, Count) :-
( maplist([X,Y,X-Y]>>true, Seq1, Seq2, Seq3)
-> aggregate_all(count, (member(X-X, Seq3), X\='_'), Count)
; Count = 0 ).
pair_member(X, Y, [X|_], [Y|_]).
pair_member(X, Y, [_|L], [_|R]) :-
pair_member(X, Y, L, R).
match3(Seq1, Seq2, Count) :-
aggregate_all(count,
(pair_member(X, X, Seq1, Seq2), X \= '_'), Count).
gimme_random_sequence(Length, Seq) :-
length(Seq, Length),
maplist([E]>>(random_between(0,3,Ix), nth0(Ix, [a,t,c,g], E)), Seq).
test(N) :-
gimme_random_sequence(N, S1),
gimme_random_sequence(N, S2),
time(match2(S1, S2, Count)),
time(match3(S1, S2, Count)).
Woa! Its 10x times faster! Thanks to genius of SWI-Prolog how it
compiles the tail recursion in pair_member/4:
/* SWI-Prolog 8.3.21, MacBook Air 2019 */
?- set_prolog_flag(double_quotes, chars).
true.
?- X = "abc".
X = [a, b, c].
?- match2("_TC_ATCG_TCG","_TC_ATCG_TCG",Count).
Count = 9.
?- match3("_TC_ATCG_TCG","_TC_ATCG_TCG",Count).
Count = 9.
?- test(100000).
% 1,575,520 inferences, 0.186 CPU in 0.190 seconds (98% CPU, 8465031 Lips)
% 175,519 inferences, 0.018 CPU in 0.019 seconds (98% CPU, 9577595 Lips)
true.
Edit 29.04.2021:
Oh the irony, bifurcation backtracking is nevertheless challenging.
After fixing a misuse of library(apply_macros), I get:
?- test(100000).
% 374,146 inferences, 0.019 CPU in 0.019 seconds (99% CPU, 19379778 Lips)
% 174,145 inferences, 0.014 CPU in 0.014 seconds (99% CPU, 12400840 Lips)
true.
Does native member/2 contribute to the good maplist solution performance?
But I should do a better measure, with larger times durations.
Open Source:
Sequence Match Problem
https://gist.github.com/jburse/9fd22e8c3e8de6148fbd341817538ef6#file-sequence-pl
I think that it is interresting to observe that complexity O(n²) is not due to the aggregation approach itself, but to the fact that subgoal nth1(Pos,Seq1,X), nth1(Pos,Seq2,X) behaves as a "nested loop" (in the size n of the sequences).
Thus, it should be possible to create another algorithm that, even using aggregation, can have complexity O(n), as long as the "nested loop" is eliminated.
Algorithms to compare
% Original algorithm: Complexity O(n²)
match1(Seq1, Seq2, Count) :-
aggregate_all(count,
( nth1(Pos, Seq1, X),
nth1(Pos, Seq2, X),
memberchk(X, [a,c,g,t]) ),
Count).
% Proposed algorithm: Complexity O(n)
match2(Seq1, Seq2, Count) :-
( maplist([X,Y,X-Y]>>true, Seq1, Seq2, Seq3)
-> aggregate_all(count, (member(X-X, Seq3), X\='_'), Count)
; Count = 0 ).
gimme_random_sequence(Length, Seq) :-
length(Seq, Length),
maplist([E]>>(random_between(0,3,Ix), nth0(Ix, [a,t,c,g], E)), Seq).
test(N) :-
gimme_random_sequence(N, S1),
gimme_random_sequence(N, S2),
time(match1(S1, S2, Count)),
time(match2(S1, S2, Count)).
Simple empirical results
?- test(10000).
% 16,714,057 inferences, 1.156 CPU in 1.156 seconds (100% CPU, 14455401 Lips)
% 39,858 inferences, 0.000 CPU in 0.000 seconds (?% CPU, Infinite Lips)
true.
?- test(20000).
% 66,761,535 inferences, 4.594 CPU in 4.593 seconds (100% CPU, 14533123 Lips)
% 79,826 inferences, 0.016 CPU in 0.016 seconds (100% CPU, 5108864 Lips)
true.
?- test(40000).
% 266,856,213 inferences, 19.734 CPU in 19.841 seconds (99% CPU, 13522405 Lips)
% 159,398 inferences, 0.016 CPU in 0.015 seconds (104% CPU, 10201472 Lips)
true.
?- test(80000).
% 1,067,046,835 inferences, 77.203 CPU in 77.493 seconds (100% CPU, 13821291 Lips)
% 320,226 inferences, 0.047 CPU in 0.047 seconds (100% CPU, 6831488 Lips)
true.
Edit 30/04/2021:
Does nth1(I,S,X), nth1(I,S,X) really work as nested loop?
To see that the answer to this question is yes, consider the following simple implementation of nth/3, that counts the number of rounds needed to find each solution, using a global flag:
nth(Index, List, Item) :-
( var(Index)
-> nth_nondet(1, Index, List, Item)
; integer(Index)
-> nth_det(Index, List, Item)
).
nth_det(1, [Item|_], Item) :- !.
nth_det(Index, [_|Rest], Item) :-
flag(rounds, Rounds, Rounds+1),
Index1 is Index - 1,
nth_det(Index1, Rest, Item).
nth_nondet(Index, Index, [Item|_], Item).
nth_nondet(Acc, Index, [_|Rest], Item) :-
flag(rounds, Rounds, Rounds+1),
Acc1 is Acc + 1,
nth_nondet(Acc1, Index, Rest, Item).
To get the number of rounds, you can ask:
?- flag(rounds,_,0), nth(5,[a,b,c,d,e],X), flag(rounds,Rounds,Rounds).
X = e,
Rounds = 4.
Now, using this predicate, we can create a predicate to count the number of rounds of the goal nth(I,L,X), nth(I,L,X), for lists of different lengths:
count_rounds :-
forall(between(1, 10, N),
( Length is 10*N,
count_rounds(Length, Rounds),
writeln(rounds(Length) = Rounds)
)).
count_rounds(Length, _) :-
numlist(1, Length, List),
flag(rounds, _, 0),
nth(Index, List, Item),
nth(Index, List, Item),
fail.
count_rounds(_, Rounds) :-
flag(rounds, Rounds, Rounds).
Empirical results:
?- count_rounds.
rounds(10) = 55
rounds(20) = 210
rounds(30) = 465
rounds(40) = 820
rounds(50) = 1275
rounds(60) = 1830
rounds(70) = 2485
rounds(80) = 3240
rounds(90) = 4095
rounds(100) = 5050
As we can see, the goal nth(I,L,X), nth(I,L,X) computes half of a square matrix of order n (including its diagonal). Thus, the number of rounds for a list of length n is rounds(n) = (n² + n)/2. Hence, the time complexity of this goal is O(n²).
Remark The implementation of the library predicate nth1/3 is a little more efficient than that of predicate nth/3considered for this experiment. Nevertheless, the time complexity of goal nth1(I,S,X), nth1(I,S,X)still is O(n²).
This is a followup of #MostowskiCollapse answer, where I have applied the same optimization that Gertjan van Noord provided for member/2 to pair_member/4, but I have renamed it to member/4.
member(X, Y, [XH|XT], [YH|YT]) :-
member_(XT, YT, X, Y, XH, YH).
member_(_, _, X,Y, X,Y).
member_([XH|XT],[YH|YT], X,Y, _,_) :-
member_(XT,YT, X,Y, XH,YH).
match4(Seq1, Seq2, Count) :-
aggregate_all(count,
(member(X, X, Seq1, Seq2), X \= '_'), Count).
test(N) :-
gimme_random_sequence(N, S1),
gimme_random_sequence(N, S2),
%time(match2(S1, S2, Count)),
time(match3(S1, S2, Count)),
time(match4(S1, S2, Count)).
...
with lists of length 1.000.000 I get
% 1,751,758 inferences, 0.835 CPU in 0.835 seconds (100% CPU, 2098841 Lips)
% 1,751,757 inferences, 0.637 CPU in 0.637 seconds (100% CPU, 2751198 Lips)
that is, a gain of about 25%...
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.