I was wondering if anyone could help me with this problem: I have to order a list using Prolog with Constraing Logic Programming and I must do it with the more efficient way I can.

So the main predicate I have defined is the next one:

order(Xs,Ys) :-
    same_length(Xs,Ys),      /* To determine the list Ys with the Xs' length */
    perm(Xs,Ys),             /* Permutation */
    ordered(Ys),             /* Is Ys ordered? */
    ! .

The implementation of each of the previous auxiliary predicates is as follows:

same_length(Xs,Ys) :-
    length(Xs,L),
    length(Ys,L).

perm([],[]).
perm([X|Xs],Ys) :- elem(X,Ys,Ws), perm(Xs,Ws).

ordered([]).
ordered([_]).
ordered([X,Y|Xs])开发者_StackOverflow中文版 :- X =< Y, ordered([Y|Xs]).

elem(X,[X|Ys],Ys).
elem(X,[Y|Ws],[Y|Zs]) :- elem(X,Ws,Zs).

I have proved the program I made and it works! But I don't know if it is possible to improve the efficiency, and if it is, how can I do it (I was reading this old thread here). Should I add or modify any of the constraints?

Thanks!

---

Your definition of same_length/2 will not terminate very often. Instead, consider

same_length([],[]).
same_length([_|Xs], [_|Ys]) :-
   same_length(Xs, Ys).

equally, using library(lambda) use

... maplist(\_^_^true,Xs, Ys), ...

in place of

... same_length(Xs, Ys), ...

It seems you want to reformulate sorting by stating first, that the list is ordered, and only then searching for a permutation. Below works in SICStus, SWI, YAP.

ordered2([]).
ordered2([_]).
ordered2([X,Y|Xs]) :-
   when((nonvar(X),nonvar(Y)),
        ( X =< Y, ordered2([Y|Xs]) )).

list_sorted2(Xs,Ys) :-
    maplist(\_^_^true,Xs,Ys),
    ordered2(Ys),
    perm(Ys,Xs).

Please note that the arguments in perm/2 are now exchanged! Using SWI:

?- time(order([10,9,8,7,6,5,4,3,2,1],Xs)).
% 38,434,099 inferences, 10.655 CPU in 11.474 seconds (93% CPU, 3607101 Lips)

?- time(list_sorted2([10,9,8,7,6,5,4,3,2,1],Xs)).
% 50,139 inferences, 0.023 CPU in 0.032 seconds (72% CPU, 2205620 Lips)

---

As an encore I have run a sorting network generator for the length 10 and ported the code (that was generated with option "best") to Prolog/clpfd.

Here comes list_sorted__SN10/2 (SN10 stands for "sorting network size 10"):

:- use_module(library(clpfd)).

list_sorted__SN10(Xs,Zs) :-
    Xs = [A0,A1,A2,A3,A4,A5,A6,A7,A8,A9],
    Zs = [E0,G1,H2,I3,J4,J5,I6,H7,G8,E9],
    B4 #= min(A4,A9),  B9 #= max(A4,A9),
    B3 #= min(A3,A8),  B8 #= max(A3,A8),
    B2 #= min(A2,A7),  B7 #= max(A2,A7),
    B1 #= min(A1,A6),  B6 #= max(A1,A6),
    B0 #= min(A0,A5),  B5 #= max(A0,A5),
    C1 #= min(B1,B4),  C4 #= max(B1,B4),
    C6 #= min(B6,B9),  C9 #= max(B6,B9),
    C0 #= min(B0,B3),  C3 #= max(B0,B3),
    C5 #= min(B5,B8),  C8 #= max(B5,B8),
    D0 #= min(C0,B2),  D2 #= max(C0,B2),
    D3 #= min(C3,C6),  D6 #= max(C3,C6),
    D7 #= min(B7,C9),  D9 #= max(B7,C9),
    E0 #= min(D0,C1),  E1 #= max(D0,C1),
    E2 #= min(D2,C4),  E4 #= max(D2,C4),
    E5 #= min(C5,D7),  E7 #= max(C5,D7),
    E8 #= min(C8,D9),  E9 #= max(C8,D9),
    F1 #= min(E1,E2),  F2 #= max(E1,E2),
    F4 #= min(E4,D6),  F6 #= max(E4,D6),
    F7 #= min(E7,E8),  F8 #= max(E7,E8),
    F3 #= min(D3,E5),  F5 #= max(D3,E5),
    G2 #= min(F2,F5),  G5 #= max(F2,F5),
    G6 #= min(F6,F8),  G8 #= max(F6,F8),
    G1 #= min(F1,F3),  G3 #= max(F1,F3),
    G4 #= min(F4,F7),  G7 #= max(F4,F7),
    H2 #= min(G2,G3),  H3 #= max(G2,G3),
    H6 #= min(G6,G7),  H7 #= max(G6,G7),
    I3 #= min(H3,G4),  I4 #= max(H3,G4),
    I5 #= min(G5,H6),  I6 #= max(G5,H6),
    J4 #= min(I4,I5),  J5 #= max(I4,I5).

Let's see if it works:

?- numlist(1,10,Xs),permutation(Xs,Ys),\+ list_sorted__SN10(Ys,Xs).
false.              % all permutations are sorted correctly

What about going in the other direction?

?- list_sorted__SN10(Xs,[1,2,3,4,5,6,7,8,9,10]),
   labeling([],Xs),
   write('Xs'=Xs),nl,
   false.
Xs=[1,2,3,4,5,6,7,8,9,10]
Xs=[1,2,3,4,5,6,7,8,10,9]
Xs=[1,2,3,4,5,6,7,9,8,10]
Xs=[1,2,3,4,5,6,7,9,10,8]
Xs=[1,2,3,4,5,6,7,10,8,9]
Xs=[1,2,3,4,5,6,7,10,9,8]
Xs=[1,2,3,4,5,6,8,7,9,10]
...

Got speed?

?- time(list_sorted__SN10([10,9,8,7,6,5,4,3,2,1],Xs)).
% 198 inferences, 0.000 CPU in 0.000 seconds (97% CPU, 4841431 Lips)
Xs = [1, 2, 3, 4, 5, 6, 7, 8, 9|...].

Got speed!

---

Handling the general case

Sorting lists Xs with length(Xs,10) is nice, but what if I have longer or shorter ones?

Once again, sorting networks to the rescue!

Here's a Prolog/clpfd port of the code shown in Bitonic sorting network for n not a power of 2; the Prolog code uses attributed variables for random read/write access of the items to be sorted. We use an attribute value which stores the item at that particular position at that time.

:- use_module(library(clpfd)).

init_att_var(X,Z) :-
    put_attr(Z,value,X).

get_att_value(Var,Value) :-
    get_attr(Var,value,Value).

direction_flipped(ascending,descending).
direction_flipped(descending,ascending).

fdBitonicSort(Xs0,Zs) :-
    same_length(Xs0,Zs),
    maplist(init_att_var,Xs0,Xs1),
    Xs2 =.. [data|Xs1],
    functor(Xs2,_,N),    
    fdBitonicSort_(Xs2,0,N,ascending),
    maplist(get_att_value,Xs1,Zs).

The recursive breakdown required for bitonic sorting is accomplished by the following code:

fdBitonicSort_(Data,Lo,N,Dir) :-
    (  N > 1
    -> M is N // 2,
       direction_flipped(Dir,Dir1),
       fdBitonicSort_(Data,Lo,M,Dir1),
       Lo1 is Lo + M,
       N1  is N  - M,
       fdBitonicSort_(Data,Lo1,N1,Dir),
       fdBitonicMerge_(Data,Lo,N,Dir)
    ;  true
    ).

greatestPowerOfTwoLessThan(N,K) :- 
    T is 1 << msb(N),
    (  N /\ (N-1) =:= 0 
    -> K is T >> 1
    ;  K = T
    ).

fdBitonicMerge_(Data,Lo,N,Dir) :-
    (  N > 1
    -> greatestPowerOfTwoLessThan(N,M),
       Ub is Lo + N - M,
       fdBitonicCompareMany_(Data,Lo,Ub,M,Dir),
       fdBitonicMerge_(Data,Lo,M,Dir),
       Lo1 is Lo + M,
       N1  is N  - M,
       fdBitonicMerge_(Data,Lo1,N1,Dir)
    ;  true
    ).

The inner loop of comparisons looks like this:

fdBitonicCompareMany_(Data,I,Ub,M,Dir) :-
    (  I < Ub
    -> I_plus_M is I+M,
       fdBitonicCompareTwo_(Data,I,I_plus_M,Dir),
       I1 is I + 1,
       fdBitonicCompareMany_(Data,I1,Ub,M,Dir)
    ;  true
    ).

Almost done! One thing's missing... fdBitonicCompareTwo_/4 reads the i-th and the j-th item and puts the minimum and maximum in the i-th and j-th place if the direction is ascending. If the direction is descending the minimum and maximum are put in the j-th and i-th place:

fdBitonicCompareTwo_(Data,I,J,Dir) :-
    I1 is I+1,
    J1 is J+1,
    arg(I1,Data,V1),
    arg(J1,Data,V2),
    get_attr(V1,value,W1),
    get_attr(V2,value,W2),
    Z1 #= min(W1,W2),
    Z2 #= max(W1,W2),
    (  Dir == ascending
    -> E1 = Z1, E2 = Z2
    ;  E1 = Z2, E2 = Z1
    ),
    put_attr(V1,value,E1),
    put_attr(V2,value,E2).

Testing

First, 10 times for every list length between 1 and 200 take random numbers between 1 and 10000 and sort them. Scream out loud if the result differs from what msort/2 delivers.

?- (  setrand(rand(29989,9973,997)),
      between(1,200,N),
      length(Xs,N), 
      format('(~d)',[N]),
      ( N mod 10 =:= 0 -> nl ; true ),
      between(1,10,_),
      maplist(random_between(1,10000),Xs),
      (  fdBitonicSort(Xs,Zs), \+ msort(Xs,Zs) 
      -> write(error(Xs,Zs)), nl
      ;  true
      ),
      false
   ;  true
   ).
(1)(2)(3)(4)(5)(6)(7)(8)(9)(10)
(11)(12)(13)(14)(15)(16)(17)(18)(19)(20)
(21)(22)(23)(24)(25)(26)(27)(28)(29)(30)
(31)(32)(33)(34)(35)(36)(37)(38)(39)(40)
(41)(42)(43)(44)(45)(46)(47)(48)(49)(50)
(51)(52)(53)(54)(55)(56)(57)(58)(59)(60)
(61)(62)(63)(64)(65)(66)(67)(68)(69)(70)
(71)(72)(73)(74)(75)(76)(77)(78)(79)(80)
(81)(82)(83)(84)(85)(86)(87)(88)(89)(90)
(91)(92)(93)(94)(95)(96)(97)(98)(99)(100)
(101)(102)(103)(104)(105)(106)(107)(108)(109)(110)
(111)(112)(113)(114)(115)(116)(117)(118)(119)(120)
(121)(122)(123)(124)(125)(126)(127)(128)(129)(130)
(131)(132)(133)(134)(135)(136)(137)(138)(139)(140)
(141)(142)(143)(144)(145)(146)(147)(148)(149)(150)
(151)(152)(153)(154)(155)(156)(157)(158)(159)(160)
(161)(162)(163)(164)(165)(166)(167)(168)(169)(170)
(171)(172)(173)(174)(175)(176)(177)(178)(179)(180)
(181)(182)(183)(184)(185)(186)(187)(188)(189)(190)
(191)(192)(193)(194)(195)(196)(197)(198)(199)(200)
true.

Next, take lists from 1 to N (with N =< Ub), consider all permutations and see it any one of them shows a bug in bitonic sorting (a result that differs from what msort/2 gives us).

The test is done in two different ways: after and before. after builds up the constraint network and then binds the FD variables to concrete values. before does it the other way round, effectively using clpfd as integer arithmetic---all constraints are immediately resolved.

test_fdBitonicSort(Method,Ub) :-
    length(RefList,Ub),
    append(Xs,_,RefList),
    length(Xs,N),
    numlist(1,N,Xs),
    same_length(Xs,Ys),
    same_length(Xs,Zs),
    time((format('[~q] testing length ~d (all permutations of ~q) ... ',
                 [Method,N,Xs]),
          (  Method == before
          -> (  permutation(Xs,Ys),
                \+ fdBitonicSort(Ys,Xs)
             -> write(errorB(Ys))
             ;  true 
             )
          ;  permutation(Xs,Ys),
             \+ (fdBitonicSort(Zs,Xs), Zs = Ys)
          -> write(errorA(Ys))
          ;  true
          ),
          write('DONE\n'))),
    false.
test_fdBitonicSort(_,_).

Let's run test_fdBitonicSort/2:

?- test_fdBitonicSort(after,7).
[after] testing length 1 (all permutations of [1]) ... DONE
% 93 inferences, 0.000 CPU in 0.000 seconds (89% CPU, 1620943 Lips)
[after] testing length 2 (all permutations of [1,2]) ... DONE
% 4,775 inferences, 0.001 CPU in 0.001 seconds (100% CPU, 9136675 Lips)
[after] testing length 3 (all permutations of [1,2,3]) ... DONE
% 53,739 inferences, 0.006 CPU in 0.006 seconds (100% CPU, 9514148 Lips)
[after] testing length 4 (all permutations of [1,2,3,4]) ... DONE
% 462,798 inferences, 0.048 CPU in 0.048 seconds (100% CPU, 9652164 Lips)
[after] testing length 5 (all permutations of [1,2,3,4,5]) ... DONE
% 3,618,226 inferences, 0.374 CPU in 0.374 seconds (100% CPU, 9666074 Lips)
[after] testing length 6 (all permutations of [1,2,3,4,5,6]) ... DONE
% 32,890,387 inferences, 3.212 CPU in 3.211 seconds (100% CPU, 10241324 Lips)
[after] testing length 7 (all permutations of [1,2,3,4,5,6,7]) ... DONE
% 330,442,005 inferences, 32.499 CPU in 32.493 seconds (100% CPU, 10167747 Lips)
true.

Let's use the predicate again, this time with ground input:

?- test_fdBitonicSort(before,9).
[before] testing length 1 (all permutations of [1]) ... DONE
% 27 inferences, 0.000 CPU in 0.000 seconds (97% CPU, 334208 Lips)
[before] testing length 2 (all permutations of [1,2]) ... DONE
% 151 inferences, 0.000 CPU in 0.000 seconds (100% CPU, 1824884 Lips)
[before] testing length 3 (all permutations of [1,2,3]) ... DONE
% 930 inferences, 0.000 CPU in 0.000 seconds (100% CPU, 4308089 Lips)
[before] testing length 4 (all permutations of [1,2,3,4]) ... DONE
% 6,033 inferences, 0.001 CPU in 0.001 seconds (100% CPU, 5124516 Lips)
[before] testing length 5 (all permutations of [1,2,3,4,5]) ... DONE
% 43,584 inferences, 0.006 CPU in 0.006 seconds (100% CPU, 7722860 Lips)
[before] testing length 6 (all permutations of [1,2,3,4,5,6]) ... DONE
% 353,637 inferences, 0.033 CPU in 0.033 seconds (100% CPU, 10753040 Lips)
[before] testing length 7 (all permutations of [1,2,3,4,5,6,7]) ... DONE
% 3,201,186 inferences, 0.249 CPU in 0.249 seconds (100% CPU, 12844003 Lips)
[before] testing length 8 (all permutations of [1,2,3,4,5,6,7,8]) ... DONE
% 32,060,649 inferences, 2.595 CPU in 2.594 seconds (100% CPU, 12355290 Lips)
[before] testing length 9 (all permutations of [1,2,3,4,5,6,7,8,9]) ... DONE
% 340,437,636 inferences, 27.549 CPU in 27.541 seconds (100% CPU, 12357591 Lips)
true.

It works! Is there more to do? Yes, definitely!

First, specialized code like list_sorted__SN10/2 should be generated for other small sizes. Second, one might evaluate different equivalent network sorting methods.

---

Here are two implementations using clpfd. Both are similar to the "permutation sort" variants presented in earlier answers. However, both express "permutation" not by using permutation/2, but by a combination of element/3 and all_distinct/1.

element/3 states that the elements of the sorted list are all members of the original list. all_distinct/1 ensures that the element indices are all different from each other.

:- use_module(library(clpfd)).

elements_index_item(Vs,N,V) :-
    element(N,Vs,V).

list_sortedA(Xs,Zs) :-
    same_length(Xs,Zs),
    chain(Zs,#=<),
    maplist(elements_index_item(Xs),Ns,Zs),
    all_distinct(Ns),
    labeling([],Ns).

Sample query:

?- list_sorted1([9,7,8,5,6,3,4,1,2],Xs).
Xs = [1, 2, 3, 4, 5, 6, 7, 8, 9] ;
false.

What if the second argument is known and the first is unknown?

?- list_sorted1(Xs,[1,2,3]).
Xs = [1, 2, 3] ;
Xs = [1, 3, 2] ;
Xs = [2, 1, 3] ;
Xs = [3, 1, 2] ;
Xs = [2, 3, 1] ;
Xs = [3, 2, 1].

So far, so good. What if the list to be sorted contains duplicates?

?- list_sorted1([5,4,4,3,3,2,2,1],Xs).
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
Xs = [1, 2, 2, 3, 3, 4, 4, 5].

Now that's a lot of redundant answers! Can we do better?

---

Eliminating redundant answers

Yes! The redundant answers in the above query can be eliminated by adding a constraint relating neighboring items in the sorted list and their respective positions in the original list.

The constraint Z1 #= Z2 #==> N1 #< N2 states: "If two neighboring items in the sorted list are equal then their positions in the original list must be ordered."

originalPosition_sorted([],[]).
originalPosition_sorted([_],[_]).
originalPosition_sorted([N1,N2|Ns],[Z1,Z2|Zs]) :-
    Z1 #= Z2 #==> N1 #< N2,
    originalPosition_sorted([N2|Ns],[Z2|Zs]).

list_sorted2(Xs,Zs) :-
    same_length(Xs,Zs),
    chain(Zs,#=<),
    maplist(elements_index_item(Xs),Ns,Zs),
    originalPosition_sorted(Ns,Zs),
    all_distinct(Ns),
    labeling([],Ns).

But... does it work?

?- list_sorted2([5,4,4,3,3,2,2,1],Xs).
Xs = [1, 2, 2, 3, 3, 4, 4, 5] ;
false.