% TEMPORAL REASONING
% thom fruehwirth ECRC 920721
% follows work by Itay Meiri AAAI 1991
% uses path concistency handler pc.chr
% 930908 updated and modified for new CHR version
% Christian Holzbaur mods for SICStus (e.g. delay -> block/when)

:- use_module( library(chr)).
:- use_module( library(lists), [member/2,memberchk/2]).

:- multifile user:goal_expansion/3.
%
user:goal_expansion( once(G), _, (G->true)).

:- ensure_loaded('time-pc').	% get compiled path consistency handler

%% domain specific predicates ------------------------------------------------


	inf(   3.40282e38).
	minf( -3.40282e38).
	sup(   1.0e-45).
        msup( -1.0e-45).

        path1(1,X,Y,[R],p-p,I):- check_pp(X,Y,R).
        path1(1,X,Y,[R],p-i,I):- check_pi(X,Y,R).
        path1(1,X,Y,[R],i-p,I):- check_ip(Y,X,R).
        path1(1,X,Y,[R],i-i,I):- check_ii(X,Y,R).

:-block empty(-,-,?).
%
empty(0,[],T).

:- block universal(-,?,?), universal(?,-,?), universal(?,?,-).
%
universal(N,L,T):-
	(is_quantl(L) -> 
	        inf(Inf), minf(Minf),
		L=[A-B],(A=<Minf),(Inf=<B)
		; 
	T=p-p -> 		% 930212 to account for finite domains
		sort(L,[eq, ge, le])
		;
		size(T,N)
	),
	!.

	size(i-i,13).
	size(p-p,3).
	size(p-i,5).
	size(i-p,5).
	size(s-s,5).

:- block equality(?,-), equality(-,?).
%
equality(L,i-i):- !, member(equals,L).
equality(L,s-s):- !, member(eq,L).
equality(L,p-p):-
	(is_quall(L) ->			% succeeds also if var-case: dirty!!
		member(E,L),(E=eq;number(E),E=:=0)	% 930212
		;
		member(A-B,L),
		(A=0,B=0 ; (A=<0),(0=<B))
	),
	!.


unique( L) :- when( ground(L), unique_g(L)).

unique_g([A-B]):- !,(A=:=B).
unique_g([A]).

% 930212 for finite domains
bind_value(X,Y,[R]):- (R=V-_;R=V)->(Y=:=X+V).

shift_interval(X,[],[]).
shift_interval(X,[A-C|L1],[B-D|L2]):- !,
	B is A-X, D is C-X,
	shift_interval(X,L1,L2).
shift_interval(X,[A|L1],[B|L2]):-
	B is A-X,
	shift_interval(X,L1,L2).


:- block intersection(-,?,?,?), intersection(?,-,?,?).
%
intersection(L1,L2,L3,T):- qtype(L1,Q1),qtype(L2,Q2),
		((Q1==quall,Q2==quall) ->
			intersection(L1,L2,L3)
			;
			qualquant(L1,Q1,LQ1),qualquant(L2,Q2,LQ2),
			interint(LQ1,LQ2,L3)
		),
		!. 

  intersection([], _, []).
  intersection([Head|L1tail], L2, L3) :-
        memberchk(Head, L2),
        !,
        L3 = [Head|L3tail],
        intersection(L1tail, L2, L3tail).
  intersection([_|L1tail], L2, L3) :-
        intersection(L1tail, L2, L3).


  % interint([1-2,4-5,6-9],[2-3,3-11],L).
  interint([],L,[]).
  interint(L,[],[]):- L=[_|_].
  interint([A|L1],[B|L2],L3):-
	(
	 isless(A,B) -> interint(L1,[B|L2],L3);
	 isless(B,A) -> interint([A|L1],L2,L3);
	 overlaps1(A,B,C) -> L3=[C|L3N],interint([A|L1],L2,L3N);
	 overlaps2(A,B,C) -> L3=[C|L3N],interint(L1,[B|L2],L3N)
	).

    isless(A-B,C-D):- (B<C).

    overlaps1(A-B,C-D,E-F):- 
	(B>=D),(C=<B),(A=<D), 
	my_max(A,C,E),my_min(B,D,F).
%	E is max(float(A),float(C)), F is min(float(B),float(D)).
    overlaps2(A-B,C-D,E-F):- 
	(D>=B),(C=<B),(A=<D), 
	my_max(A,C,E),my_min(B,D,F).
%	E is max(float(A),float(C)), F is min(float(B),float(D)).

	my_max(X,Y,Z):- (X>=Y),!,X=Z.
	my_max(X,Y,Y).

	my_min(X,Y,Z):- (X=<Y),!,X=Z.
	my_min(X,Y,Y).

:- block transl(-,-,?,?), transl(-,?,-,?), transl(?,-,-,?).
%
transl(A,B,C,T):- 
	qtype(A,QA),qtype(B,QB),qtype(C,QC),	
	(
	(T=p-p-p,(QA==quantl;QB==quantl;QC==quantl) ) ->  % at least one quantl
		qualquant(A,QA,A1),qualquant(B,QB,B1),qualquant(C,QC,C1),
		transl(A1,B1,C1,T,quantl)
		;
		quantqual(A,QA,A1),quantqual(B,QB,B1),quantqual(C,QC,C1),
		transl(A1,B1,C1,T,quall)
	),
	!.	

  transl(L1,L2,L3,T,Q):- var(L3),!,
	setof(C,A^B^(member(A,L1),member(B,L2),trans(A,B,C,T,Q)),L3N),
	mergerel(L3N,L3,T,Q).
  transl(L1,L2,L3,T,Q):- var(L2),!,
	setof(B,A^C^(member(A,L1),member(C,L3),trans(A,B,C,T,Q)),L2N),
	mergerel(L2N,L2,T,Q).
  transl(L1,L2,L3,T,Q):- var(L1),!,
	setof(A,B^C^(member(B,L2),member(C,L3),trans(A,B,C,T,Q)),L1N),
	mergerel(L1N,L1,T,Q).

	mergerel(L1,L2,T,Q):- 
		(Q==quantl -> mergerel(L1,L2) ; L1=L2),
		!.
	  mergerel([],[]).
	  mergerel([A-B,C-D|L1],L2):-
	        sup(Sup),
		(B+Sup>=C),		% +sup added 921029
		!,
		my_min(A,C,Min),		% min, max added 920129
		my_max(B,D,Max),
		mergerel([Min-Max|L1],L2).
	  mergerel([X|L1],[X|L2]):-
		mergerel(L1,L2).

     trans(A,B,C,s-s-s,quall):- !, 
		strans(A,B,C).
     trans(A,B,C,p-p-p,quall):- !, 
		prans(A,B,C).
     trans(A,B,C,p-p-p,quantl):- !, 
		qtrans(A,B,C).
     trans(A,B,C,U-V-W,quall):- !,
		itrans(U-V-W,A,B,C). 


%% qualitative and quantitative constraints interaction


qtype(L,T) :- when( ground(L), qtype_g(L,T)).

qtype_g(L,quantl):- is_quantl(L).
qtype_g(L,quall):- is_quall(L).

 is_quantl([X|_]):- is_quant(X).
 is_quall([X|_]):- is_qual(X).

  :- block is_quant(-).
  %
  is_quant(A-B). % :- A1 is A,B1 is B,number(A1),number(B1).

  :- block is_qual(-).
  %
  is_qual(A):- atomic(A).	% single numbers are treated like atoms 930212

   :- block qualquant(-,?,-).	% necessary?
   qualquant(A,QA,A1):- 	% hacked for var-case (== versus = below!)
		(QA==quall -> qualquant(A,A0),mergerel(A0,A1) ; QA=quantl -> A=A1).	% mergrel added 921029

   :- block quantqual(-,?,-).	% necessary?
   quantqual(A,QA,A1):- 	% hacked for var-case (== versus = below!)
		(QA==quantl -> quantqual(A,A1) ; QA=quall -> A=A1).

%path(N,X,Y,L,p-p) +=> qualquant(L,LIN), sort(LIN,LI), path(N,X,Y,LI,p-p).

	qualquant([],[]).
	qualquant([A|L1],[B|L2]):-
		qualquant1(A,B),
		qualquant(L1,L2).

		qualquant1(le,A-B):- !, sup(A), inf(B).
		qualquant1(eq,0-0):- !.
		qualquant1(ge,A-B):- !, minf(A), msup(B).
		% 930212 to treat single numbers 
		qualquant1(N,A-A):- A is N.	% 'is' used to catch type error

%path(N,X,Y,LI,p-p) +=> N>2 | 		% quick hack condition for termination
%	quantqual(LI,L), length(L,N1), path(N1,X,Y,L,p-p). 

	quantqual(LI,L):-
		findall(X,quantqual1(LI,X),L).

		quantqual1(LI,eq):- 
			once((member(I-J,LI), (I=<0),(0=<J))).
		quantqual1(LI,le):-  
			once((member(I-J,LI), (0<J))).
		quantqual1(LI,ge):-  
			once((member(I-J,LI), (I<0))).

		% 930212 to treat single numbers 
		quantqual1(LI,N):-  
			once((member(N-M,LI), (N=:=M))).




% ALLENS INTERVALS ---------------------------------------------------------

:- ensure_loaded( allentable).	% get cons_tri/3 transitivity table for Allens intervals

%[after, before, contains, during, equals, finished_by, finishes, meets, met_by, overlapped_by, overlaps, started_by, starts].

%930212
check_ii(X,Y,R):- interval_point(X,R,Y).	
% taken from jonathan lever
interval_point([X,Y],before,[U,V]):- ((Y < U)).
interval_point([X,Y],after,[U,V]):- ((V < X)).
interval_point([X,Y],meets,[U,V]):- ((Y =:= U)).
interval_point([X,Y],met_by,[U,V]):- ((V =:= X)).
interval_point([X,Y],starts,[U,V]):- ((X =:= U, Y < V)).
interval_point([X,Y],started_by,[U,V]):- ((X =:= U, V < Y)).
interval_point([X,Y],finishes,[U,V]):- ((Y =:= V, U < X)).
interval_point([X,Y],finished_by,[U,V]):- ((Y =:= V, X < V)).
interval_point([X,Y],during,[U,V]):- ((U < X, Y < V)).
interval_point([X,Y],contains,[U,V]):- ((X < U, V < Y)).
interval_point([X,Y],overlaps,[U,V]):- ((X < U, U < Y, Y < V)).
interval_point([X,Y],overlapped_by,[U,V]):- ((U < X, X < V, V < Y)).
interval_point([X,Y],equals,[U,V]):- ((X =:= U,Y =:= V)).


itrans(U-V-W,A,B,C):-	
		encode(U-V,A,X),encode(V-W,B,Y),encode(U-W,C,Z), 
		cons_tri(X,Y,Z).

:- block encode(?,-,-).
%
encode(i-i,A,B):-!,encode(A,B).
encode(p-i,A,B):-!,pi_ii(A,Y),encode(Y,B).
encode(i-p,A,B):-!,ip_ii(A,Y),encode(Y,B).
encode(p-p,A,B):-!,pp_pi(A,X),pi_ii(X,Y),encode(Y,B).

:- block encode(-,-).
%
encode(before,1).
encode(after,2).
encode(during,3).
encode(contains,4).
encode(overlaps,5).
encode(overlapped_by,6).
encode(meets,7).
encode(met_by,8).
encode(starts,9).
encode(started_by,10).
encode(finishes,11).
encode(finished_by,12).
encode(equals,13).



% POINT ALGEBRA ---------------------------------------------------------------

%[le,eq,ge]

% 930212
check_pp(X,Y,A-B):- !, ((X+A<Y,Y<X+B)).
check_pp(X,Y,N):- number(N),!, (X+N=:=Y).
check_pp(X,Y,T):- \+ member(T,[le,eq,ge]),!, Y=T.
check_pp(X,Y,R):- ((number(X),number(Y))->check_ppn(X,Y,R);check_ppt(X,Y,R)).

check_ppn(X,Y,le):- (X<Y).
check_ppn(X,Y,eq):- (X=:=Y).
check_ppn(X,Y,ge):- (X>Y).

check_ppt(X,Y,le):- (X@<Y).
check_ppt(X,Y,eq):- (X=Y).
check_ppt(X,Y,ge):- (X@>Y).

prans(A,B,C):- (number(A);number(B);number(C)),!,qtrans(A-A,B-B,C-C).
prans(le,le,le).
prans(le,eq,le).
prans(le,ge,le).
prans(le,ge,eq).
prans(le,ge,ge).
prans(eq,le,le).
prans(eq,eq,eq).
prans(eq,ge,ge).
prans(ge,le,le).
prans(ge,le,eq).
prans(ge,le,ge).
prans(ge,eq,ge).
prans(ge,ge,ge).

	




% QUANTITATIVE  ---------------------------------------------------------

% [I1-I2,...In-1-In] ordered Ii=<Ii+1, comparison problem with reals (equality)

qtrans(A-B,C-D,E-F):- (	(var(A),var(B)) -> safe_is(A,E-D), safe_is(B,F-C) ;
			(var(C),var(D)) -> safe_is(C,E-B), safe_is(D,F-A) ;
			(var(E),var(F)) -> safe_is(E,A+C), safe_is(F,B+D)
			).
	safe_is(A,X-Y):-
	        inf(Inf),
		minf(Minf),
		sup(Sup),
		msup(Msup),
		(X=:=Minf,Y=:=Inf -> A is Minf
		;
		 X=:=Inf,Y=:=Minf -> A is Inf
		;
		 X=:=Msup,Y=:=Sup -> A is Msup
		;
		 X=:=Sup,Y=:=Msup -> A is Sup
		;
		 A is X-Y).
	safe_is(A,X+Y):-
	        inf(Inf),
		minf(Minf),
		sup(Sup),
		msup(Msup),
		(X=:=Inf,Y=:=Inf -> A is Inf
		;
		 X=:=Minf,Y=:=Minf -> A is Minf
		;
		 X=:=Sup,Y=:=Sup -> A is Sup
		;
		 X=:=Msup,Y=:=Msup -> A is Msup
		;
		 A is X+Y).





% POINT-INTERVAL ---------------------------------------------------------

% p-i [before,starts,during,finishes,after]
% i-p [after,started_by,contains,finished_by,before]

%930212
check_pi(X,[A,B],before):- ((X<A)).
check_pi(X,[A,B],starts):- ((X=:=A)).
check_pi(X,[A,B],during):- ((A<X,X<B)).
check_pi(X,[A,B],finishes):- ((X=:=B)).
check_pi(X,[A,B],after):- ((B<X)).

check_pi([A,_B],X,after):- ((X<A)).
check_pi([A,_B],X,started_by):- ((X=:=A)).
check_pi([A,B],X,contains):- ((A<X,X<B)).
check_pi([_A,B],X,finished_by):- ((X=:=B)).
check_pi([_A,B],X,before):- ((B<X)).

% trans see itrans for INTERVAL

% pi_ii
:- block pi_ii(-,-).
%
pi_ii(before, before).
pi_ii(before, meets).
pi_ii(before, finished_by).
pi_ii(before, contains).
pi_ii(before, overlaps).
pi_ii(starts, starts).
pi_ii(starts, equals).
pi_ii(starts, started_by).
pi_ii(during, during).
pi_ii(during, finishes).
pi_ii(during, overlaped_by).
pi_ii(finishes, met_by).
pi_ii(after, after).

% ip_ii (inversion of pi_ii)
:- block ip_ii(-,-).
%
ip_ii(before, before).
ip_ii(finished_by, meets).
ip_ii(contains, contains).
ip_ii(contains, overlaps).
ip_ii(contains, finished_by).
ip_ii(started_by, starts).
ip_ii(started_by, equals).
ip_ii(started_by, started_by).
ip_ii(after, during).
ip_ii(after, finishes).
ip_ii(after, overlaped_by).
ip_ii(after, met_by).
ip_ii(after, after).

% pp_pi
:- block pp_pi(-,-).
%
pp_pi(le, before).
pp_pi(eq, starts).
pp_pi(ge, during).
pp_pi(ge, finishes).
pp_pi(ge, after).

% pp_ii
:- block pp_ii(-,-).
%
pp_ii(A,B):- pp_pi(A,C),pi_ii(C,B).



% end of handler time.chr ----------------------------------------------------