yap-6.3/CLPQR/clpqr/ordering.yap

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%  clp(q,r)                                         version 1.3.3 %
%                                                                 %
%  (c) Copyright 1992,1993,1994,1995                              %
%  Austrian Research Institute for Artificial Intelligence (OFAI) %
%  Schottengasse 3                                                %
%  A-1010 Vienna, Austria                                         %
%                                                                 %
%  File:   ordering.pl                                            %
%  Author: Christian Holzbaur           christian@ai.univie.ac.at %
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


%
% Collect ordering constraints
% Produce an arrangement via toplogical sorting
%
%

:- use_module( library(lists), [append/3]).

:- use_module( library(ugraphs), 
	[
	    top_sort/2,
	    add_edges/3,
	    add_vertices/3
	]).

ordering( X) :- var(X), !, fail.
ordering( A>B) :- !, ordering( B<A).
ordering( A<B) :-
  join_class( [A,B], Class),
  class_get_prio( Class, Ga),
  !,
  add_edges( [], [A-B], Gb),			% [] = empty graph
  combine( Ga, Gb, Gc),
  class_put_prio( Class, Gc).
ordering( Pb) :- Pb = [_|Xs],
  join_class( Pb, Class),
  class_get_prio( Class, Ga),
  !,
  ( Xs=[],
     add_vertices( [], Pb, Gb)
  ; Xs=[_|_],
     gen_edges( Pb, Es, []),
     add_edges( [], Es, Gb)
  ),
  combine( Ga, Gb, Gc),
  class_put_prio( Class, Gc).
ordering( _).

arrangement( Class, Arr) :-
  class_get_prio( Class, G),
  normalize( G, Gn),
  top_sort( Gn, Arr),
  !.
arrangement( _, _) :-
  raise_exception( unsatisfiable_ordering).

join_class( [],     _).
join_class( [X|Xs], Class) :-
  ( var(X), get_or_add_class( X, Class)
  ; nonvar(X)
  ),
  join_class( Xs, Class).

combine( Ga, Gb, Gc) :-
  normalize( Ga, Gan),
  normalize( Gb, Gbn),
  ugraphs:graph_union( Gan, Gbn, Gc).

%
% both Ga and Gb might have their internal ordering invalidated
% because of bindings and aliasings
%
normalize( [], []).
normalize( [GH|GT],  Gsgn) :-  %vsc: added list in argument (01/06/06)
  keysort( [GH|GT], Gs),
  group( Gs, Gsg),
  normalize_vertices( Gsg, Gsgn).

normalize_vertices( [], 	[]).
normalize_vertices( [X-Xnb|Xs], Res) :-
  ( normalize_vertex( X, Xnb, Xnorm) ->
      Res = [Xnorm|Xsn],
      normalize_vertices( Xs, Xsn)
  ;
      normalize_vertices( Xs, Res)
  ).

%
% get rid of nonvar vertices/edges, and turn V-[V] into V-[]
%
normalize_vertex( X, Nbs, X-Nbsss) :-
  var(X),
  sort( Nbs, Nbss),
  strip_nonvar( Nbss, X, Nbsss).

strip_nonvar( [],     _, []).
strip_nonvar( [X|Xs], Y, Res) :-
  ( X==Y -> strip_nonvar( Xs, Y, Res)
  ; var(X) ->
      Res=[X|Stripped],
      strip_nonvar( Xs, Y, Stripped)
  ; nonvar(X),
      Res=[]					% because Vars<anything
  ).

gen_edges( []) --> [].
gen_edges( [X|Xs]) -->
  gen_edges( Xs, X),
  gen_edges( Xs).

gen_edges( [],	   _) --> [].
gen_edges( [Y|Ys], X) -->
  [ X-Y ],
  gen_edges( Ys, X).

%
% map k-La,k-Lb.... into k-LaLb
%
group( [],	  []).
group( [K-Kl|Ks], Res) :-
  group( Ks, K, Kl, Res).

group( [],	  K, Kl, [K-Kl]).
group( [L-Ll|Ls], K, Kl, Res) :-
  ( K==L ->
      append( Kl, Ll, KLl),
      group( Ls, K, KLl, Res)
  ;
      Res = [K-Kl|Tail],
      group( Ls, L, Ll, Tail)
  ).