home *** CD-ROM | disk | FTP | other *** search
/ rtsi.com / 2014.01.www.rtsi.com.tar / www.rtsi.com / OS9 / OSK / EFFO / forum7.lzh / RICO / S_PROLOG / PROG / setof.pl < prev   
Text File  |  1988-09-26  |  6KB  |  240 lines
  1. /* setof : 'setof', 'bagof' and sorting. */
  2.  
  3. ?- op(200,xfy,^^).
  4.  
  5. setof(X,P,Set) :-
  6.    '$setof'(X,P,Set).
  7.  
  8. '$setof'(X,P,Set) :-
  9.    '$bagof'(X,P,Bag),
  10.    sort(Bag,Set0),
  11.    Set=Set0.
  12.  
  13. bagof(X,P,Bag) :-
  14.    '$bagof'(X,P,Bag).
  15.  
  16. '$bagof'(X,P,Bag) :-
  17.    '$excess_vars'(P,X,[],L), '$nonempty'(L), !,
  18.    Key =.. ['$'|L],
  19.    '$bagof'(X,P,Key,Bag).
  20. '$bagof'(X,P,Bag) :-
  21.    '$tag'('$bag','$bag'),
  22.    '$user_call'(P),
  23.    '$tag'('$bag',X),
  24.    fail.
  25. '$bagof'(X,P,Bag) :- '$reap'([],Bag), '$nonempty'(Bag).
  26.  
  27. '$bagof'(X,P,Key,Bag) :-
  28.    '$tag'('$bag','$bag'),
  29.    '$user_call'(P),
  30.    '$tag'('$bag',Key-X),
  31.    fail.
  32. '$bagof'(X,P,Key,Bag) :-
  33.    '$reap'([],Bags0),
  34.    keysort(Bags0,Bags),
  35.    '$pick'(Bags,Key,Bag).
  36.  
  37. '$user_call'(P):-
  38.     call(P).
  39.     
  40. '$nonempty'([_|_]).
  41.  
  42. '$reap'(L0,L) :-
  43.    '$untag'('$bag',X), !,
  44.    '$reap1'(X,L0,L).
  45.  
  46. '$reap1'(X,L0,L) :- X \== '$bag', !, '$reap'([X|L0],L).
  47. '$reap1'(_,L,L).
  48.  
  49. '$pick'(Bags,Key,Bag) :-
  50.    '$nonempty'(Bags),
  51.    '$parade'(Bags,Key1,Bag1,Bags1),
  52.    '$decide'(Key1,Bag1,Bags1,Key,Bag).
  53.  
  54. '$parade'([Item|L1],K,[X|B],L) :- '$item'(Item,K,X), !,
  55.    '$parade'(L1,K,B,L).
  56. '$parade'(L,K,[],L).
  57.  
  58. '$item'(K-X,K,X).
  59.  
  60. '$decide'(Key,Bag,Bags,Key,Bag) :- (Bags=[], ! ; true).
  61. '$decide'(_,_,Bags,Key,Bag) :- '$pick'(Bags,Key,Bag).
  62.  
  63. '$excess_vars'(T,X,L0,L) :- var(T), !,
  64.    ( '$no_occurrence'(T,X), !, '$introduce'(T,L0,L)
  65.    ; L = L0 ).
  66. '$excess_vars'(X^^P,Y,L0,L) :- !, '$excess_vars'(P,(X,Y),L0,L).
  67. '$excess_vars'(setof(X,P,S),Y,L0,L) :- !, '$excess_vars'((P,S),(X,Y),L0,L).
  68. '$excess_vars'(bagof(X,P,S),Y,L0,L) :- !, '$excess_vars'((P,S),(X,Y),L0,L).
  69. '$excess_vars'(T,X,L0,L) :- '$functor'(T,_,N),
  70.     '$rem_excess_vars'(N,T,X,L0,L).
  71.  
  72. '$rem_excess_vars'(0,_,_,L,L) :- !.
  73. '$rem_excess_vars'(N,T,X,L0,L) :-
  74.    arg(N,T,T1),
  75.    '$excess_vars'(T1,X,L0,L1),
  76.    N1 is N - 1,
  77.    '$rem_excess_vars'(N1,T,X,L1,L).
  78.  
  79. '$introduce'(X,L,L) :- '$included'(X,L), !.
  80. '$introduce'(X,L,[X|L]).
  81.  
  82. '$included'(X,L) :- '$doesnt_include'(L,X), !, fail.
  83. '$included'(X,L).
  84.  
  85. '$doesnt_include'([],X).
  86. '$doesnt_include'([Y|L],X) :- Y \== X, '$doesnt_include'(L,X).
  87.  
  88. '$no_occurrence'(X,Term) :- '$contains'(Term,X), !, fail.
  89. '$no_occurrence'(X,Term).
  90.  
  91. '$contains'(T,X) :- var(T), !, T == X.
  92. '$contains'(T,X) :- '$functor'(T,_,N),
  93.     '$upto'(N,I), arg(I,T,T1), '$contains'(T1,X).
  94.  
  95. '$upto'(N,N) :- N > 0.
  96. '$upto'(N,I) :- N > 0, N1 is N - 1, '$upto'(N1,I).
  97.  
  98. /*---------------------------------------------------------------------------- */
  99. /* Sorting by bisecting and merging. */
  100.  
  101. sort(L,R) :- length(L,N), '$sort'(N,L,_,R1), R=R1.
  102.  
  103. '$sort'(2,[X1|L1],L,R) :- !, '$comprises'(L1,X2,L),
  104.     compare(Delta,X1,X2),
  105.   (Delta = (<) , !, R = [X1,X2]
  106.    ; Delta = (>) , !, R = [X2,X1]
  107.    ; R = [X2]
  108.   ).
  109. '$sort'(1,[X|L],L,[X]) :- !.
  110. '$sort'(0,L,L,[]) :- !.
  111. '$sort'(N,L1,L3,R) :-
  112.    N1 is N div 2, N2 is N - N1,
  113.    '$sort'(N1,L1,L2,R1),
  114.    '$sort'(N2,L2,L3,R2),
  115.    '$merge'(R1,R2,R).
  116.  
  117. '$merge'([],R,R) :- !.
  118. '$merge'(R,[],R) :- !.
  119. '$merge'(R1,R2,[X|R]) :-
  120.    '$comprises'(R1,X1,R1a), '$comprises'(R2,X2,R2a),
  121.    compare(Delta,X1,X2),
  122.   (Delta = (<) , !, X = X1, '$merge'(R1a,R2,R)
  123.    ; Delta = (>) , !, X = X2, '$merge'(R1,R2a,R)
  124.    ; X = X1, '$merge'(R1a,R2a,R)
  125.   ).
  126.  
  127. '$comprises'([X|L],X,L).
  128.  
  129. /*------------------------------------------------------------------------ */
  130. /* Sorting on keys by bisecting and merging. */
  131.  
  132. keysort(L,R) :- length(L,N), '$keysort'(N,L,_,R1), R=R1.
  133.  
  134. '$keysort'(2,[X1|L1],L,R) :- !,
  135.    '$comprises'(L1,X2,L),
  136.    '$compare_keys'(Delta,X1,X2),
  137.   (Delta = (>) , !, R = [X2,X1] ; R = [X1,X2] ).
  138. '$keysort'(1,[X|L],L,[X]) :- !.
  139. '$keysort'(0,L,L,[]) :- !.
  140. '$keysort'(N,L1,L3,R) :-
  141.    N1 is N div 2, N2 is N - N1,
  142.    '$keysort'(N1,L1,L2,R1),
  143.    '$keysort'(N2,L2,L3,R2),
  144.    '$keymerge'(R1,R2,R).
  145.  
  146. '$keymerge'([],R,R) :- !.
  147. '$keymerge'(R,[],R) :- !.
  148. '$keymerge'(R1,R2,[X|R]) :-
  149.    '$comprises'(R1,X1,R1a), '$comprises'(R2,X2,R2a),
  150.    '$compare_keys'(Delta,X1,X2),
  151.   (Delta = (>) , !, X = X2, '$keymerge'(R1,R2a,R)
  152.    ; X = X1, '$keymerge'(R1a,R2,R)
  153.   ).
  154.  
  155. '$compare_keys'(Delta,K1-X1,K2-X2) :- compare(Delta,K1,K2).
  156.  
  157. /*======================================================================*/
  158.  
  159. X ^^ P :- call(P).
  160.  
  161. /*======================================================================*/
  162.  
  163. '$tag'(Key,Value) :-
  164.    asserta(record(Key,Value)).
  165.  
  166. '$untag'(Key,Value) :-
  167.    retract(record(Key,Value)).
  168.  
  169. /*    Simulates CProlog's compare/3, but doesn't
  170.     compare variables properly    */
  171.     
  172. compare(=,X,Y):-
  173.     X == Y,!.   
  174. compare(C,X,Y):-
  175.     (var(X), X \== Y, C = (<);
  176.      var(Y), X \== Y, C = (>)),!.
  177. compare(C,I1,I2):-
  178.     numeric(I1),
  179.     numeric(I2),
  180.     '$compare_numbers'(C,I1,I2),!.
  181. compare(C,I,A):-
  182.     (numeric(I), nonvar(A), C = (<);
  183.      nonvar(I), numeric(A), C = (>)),!.
  184. compare(C,A1,A2):-
  185.     atomic(A1),
  186.     atomic(A2),
  187.     '$compare_names'(C,A1,A2),!.
  188. compare(C,A,S):-
  189.     (atomic(A), structure(S), C = (<);
  190.      structure(A), atomic(S), C = (>)),!.
  191. compare(C,S1,S2):-
  192.     structure(S1),
  193.     structure(S2),
  194.     '$compare_structures'(C,S1,S2).
  195.     
  196. '$compare_numbers'(C,N1,N2):-
  197.     (N1 < N2, C = (<);
  198.      N1 > N2, C = (>);
  199.      N1 = N2, C = (=)).
  200.          
  201. '$compare_names'(C,A1,A2):-
  202.     name(A1,N1),
  203.     name(A2,N2),
  204.     '$compare_letters'(C,N1,N2).
  205.     
  206. '$compare_letters'(<,[],[_|_]).
  207. '$compare_letters'(>,[_|_],[]).
  208. '$compare_letters'(=,[],[]).
  209. '$compare_letters'(C,[H1|T1],[H2|T2]):-
  210.     '$compare_numbers'(=,H1,H2),
  211.     '$compare_letters'(C,T1,T2).
  212. '$compare_letters'(C,[H1|_],[H2|_]):-
  213.     '$compare_numbers'(C,H1,H2),
  214.     C \= (=).
  215.  
  216. '$compare_structures'(C,S1,S2):-
  217.     functor(S1,P1,N1),
  218.     functor(S2,P2,N2),
  219.     '$compare_numbers'(C2,N1,N2),
  220.     (C2 \= (=), C = C2;
  221.      C2 = (=), '$compare_names'(C1,P1,P2),
  222.      (C1 \= (=), C = C1;
  223.       C1 = (=), S1 =.. [P1|A1],
  224.                 S2 =.. [P2|A2],
  225.                 '$compare_list'(C,A1,A2))),!.
  226.                     
  227. '$compare_list'(=,[],[]).
  228. '$compare_list'(C,[H1|T1],[H2|T2]):-
  229.     compare(C1,H1,H2),
  230.     (C1 \= (=), C = C1;
  231.      C1 = (=), '$compare_list'(C,T1,T2)).
  232.      
  233. /*    Simulates CProlog's functor/3 because
  234.     s_prolog doesn't handle atoms and numbers correctly    */
  235.     
  236. '$functor'(A,A,0) :- atomic(A),!.
  237. '$functor'(T,F,N) :- functor(T,F,N).
  238.  
  239.      
  240.