% ----------------------------------------------------------------------
% BEGIN LICENSE BLOCK
% Version: CMPL 1.1
%
% The contents of this file are subject to the Cisco-style Mozilla Public
% License Version 1.1 (the "License"); you may not use this file except
% in compliance with the License.  You may obtain a copy of the License
% at www.eclipse-clp.org/license.
% 
% Software distributed under the License is distributed on an "AS IS"
% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied.  See
% the License for the specific language governing rights and limitations
% under the License. 
% 
% The Original Code is  The ECLiPSe Constraint Logic Programming System. 
% The Initial Developer of the Original Code is  Cisco Systems, Inc. 
% Portions created by the Initial Developer are
% Copyright (C) 1989-2006 Cisco Systems, Inc.  All Rights Reserved.
% 
% Contributor(s): ECRC GmbH
% Contributor(s): IC-Parc, Imperal College London
% 
% END LICENSE BLOCK
%
% System:	ECLiPSe Constraint Logic Programming System
% Version:	$Id: fd_domain.pl,v 1.4 2013/02/12 17:53:36 jschimpf Exp $
% ----------------------------------------------------------------------

/*
 * SEPIA PROLOG SOURCE MODULE
 */

/*
 * FINITE DOMAINS
 *
 * IDENTIFICATION:      fd_domain.pl 
 *
 * AUTHOR:		Micha Meier
 *
 * DESCRIPTION:         Finite domain data type and the handling of
			the 'fd' attribute.
 */


:- module(fd_domain).

:- export syntax_option(dense_output).

:- reexport
	% domain access
	dom_range/3,
	dom_check_in/2,

	% domain modification
	dvar_replace/2,
	dvar_remove_element/2,
	dvar_remove_greater/2,
	dvar_remove_smaller/2,

	% domain processing
	dom_compare/3,
	dom_intersection/4,
	dom_union/4,
	dom_difference/4,

	integer_list_to_dom/2
    from sepia_kernel.

    /*****************************************************************
     * A domain variable that apears in some constraints is represented
     * by a metaterm.
     * The metaterm is represented by
     */

:- export struct(fd(domain, min, max, any)).
    /*
     *
     *	where
     *
     *		min - goals to be woken if the domain minimum changes
     *		max - goals to be woken if the domain maximum changes
     *		any - the delayed goals woken if the domain is changed
     *
     *		domain - the representation of the domain itself dom(List, Size)
     *
     * A structure declaration is used so that e.g.
     *
     *		fd with domain:D
     *
     * represents
     *
     *		fd(_, _, _, D)
     * and
     *		min of fd
     * is 3. All operations on the fd/4 structure should be done
     * with these macros so that the access is independent of the
     * actual structure.
     */

%----------------------------------------------------------------
% Attribute definition
%----------------------------------------------------------------

:- meta_attribute(fd, [
	unify:			unify_domain/3,
	test_unify:		test_unify_domain/2,
	compare_instances:	compare_instances_domain/3,
	copy_term:		copy_term_domain/2,
	suspensions:		suspensions_domain/3,
	delayed_goals_number:	delayed_goals_number_domain/2,
	get_bounds:		get_fd_bounds/3,
	set_bounds:		set_fd_bounds/3,
	print:			tr_fd_domain_out/2,
	suspension_lists:	[min:(min of fd),
				 max:(max of fd),
				 any:(any of fd),
				 domain:(any of fd),
				 bounds:[min of fd,max of fd] ]
	]).

% Export transformation routines.
:- export
	fd_dom_simple/2,
	fd_dom_simple/3,
	tr_fd_domain_in/2,
	tr_fd_domain_out/2.

% Output Macros
% Hide the attribute structure on output
% print the metaterm alone as [Domain]

:- export macro(property(functor) of fd, tr_fd_domain_out/2, [write, protect_arg]).
:- export macro(dom/2, tr_fd_domain_out/2, [write, protect_arg]).
:- export macro(dom_ent/3, tr_fd_domain_out/2, [write, goal]).
:- export macro(fd_dom_simple/2, tr_fd_domain_out/2, [write, goal]).
:- export macro(fd_dom_simple/3, tr_fd_domain_out/2, [write, goal]).

:- export op(700, xfx, #::). 

% Goal Macros
:- inline((::)/2, tr_fd_domain_in/2).
:- inline((::)/3, tr_fd_domain_in/2).
:- inline((#::)/2, tr_fd_domain_in/2).
:- inline((#::)/3, tr_fd_domain_in/2).

:- export
    :: /2,
    :: /3,
    #:: /2,
    #:: /3,
    indomain/1,
    is_domain/1,
    is_integer_domain/1,
    par_indomain/1,

    % domain access
    dom_member/2,
    dom_size/2,
    new_domain_var/1,

    % domain processing
    dom_copy/2,
    dom_to_list/2,
    list_to_dom/2,
    sorted_list_to_dom/2,

    % various
    var_fd/2,
    dvar_attribute/2,
    dvar_domain/2,
    constraints_number/2,

    % var modification
    dvar_update/2,
    dvar_update_nocheck/3,

    dvar_msg/3.

:-  local get_attribute/2.

:- import
	check_dom/1	% should really be defined here...
    from fd_arith.

:- import
	% general-purpose predicates
	add_attribute/3,
	fd_init/0,
	get_bip_error/1,
	remove_element/3,
	setarg/3,
	set_bip_error/1,
	suspensions_to_goals/3,
	trprotect/2,

	% FD-specific predicates
	attr_instantiate/2
    from sepia_kernel.


% Initialize the C variables
:- fd_init.

:- pragma(nodebug).
:- pragma(system).

fderror(N, G) :-
	error(N, G, _).

%
% Transformation routines
%

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Input goal transformation
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Goal Source Transformation
tr_fd_domain_in(V #:: D, G) :-
    tr_fd_domain_in(V :: D, G).
tr_fd_domain_in(#::(V, D, B), G) :-
    tr_fd_domain_in(::(V, D, B), G).
tr_fd_domain_in(V :: D, G) :-
    -?->
    !,
    varset(V),
    ground(D),
    make_domain(D, Dom, _),
    G = fd_domain:fd_dom_simple(V, Dom).
tr_fd_domain_in(::(V, D, B), G) :-
    -?->
    !,
    var(V),
    ground(D),
    make_domain(D, Dom, _),
    G = fd_domain:fd_dom_simple(V, Dom, B).
    
    varset(V) :- var(V), !.
    varset([_|_]).
    varset(subscript(_,_)).

% Domain Output Transformation
tr_fd_domain_out(_{fd:(fd with domain:dom(D, _))}, T) :-
	-?->
	T = D.
tr_fd_domain_out(fd with domain:dom(D, _), T) :-
	-?->
	T = D.
tr_fd_domain_out(dom(D, S), T) :-
	-?->
	(is_finite(D) ->
	    T = dom(D, S)
	;
	D = [T] ->
	    true
	;
	    T = D
	).
tr_fd_domain_out(dom_ent(X, Dom, B), T) :-
	-?->
	T = ::(X, Dom, B).
tr_fd_domain_out(fd_dom_simple(X, Dom), T) :-
	-?->
	T = ::(X, Dom).
tr_fd_domain_out(fd_dom_simple(X, Dom, B), T) :-
	-?->
	T = ::(X, Dom, B).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% 	THE FD EXTENSION
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%----------------------------------------------------------------
% unification
%----------------------------------------------------------------

% unify_domain(+Term, ?Attribute, ?XSuspAttr)
unify_domain(Term, Attr, XSuspAttr) :-
    /*** ANY + VAR ***/
    var(Attr),
    % Nothing to do unless there's a constrained list for X and Term is an
    % FD variable.
    ( nonvar(XSuspAttr), is_domain(Term) ->
	schedule_suspensions(constrained of suspend, XSuspAttr)
    ;
	true
    ).
unify_domain(Term, Attr, XSuspAttr) :-
    compound(Attr),
    unify_term_domain(Term, Attr, XSuspAttr).

% We wake every time a variable is touched.
:- mode unify_term_domain(?, +, ?).
unify_term_domain(Term, Attr, _XSuspAttr) :-
    nonvar(Term),		% The metaterm was instantiated, wake all
    /*** NONVAR + META ***/
    Attr = fd with [],
    attr_instantiate(Attr, Term).
unify_term_domain(Y{fd:AttrY}, AttrX, XSuspAttr) :-
    -?->
    unify_domain_domain(Y, AttrX, AttrY, XSuspAttr).

unify_domain_domain(Y, AttrX, AttrY, _XSuspAttr) :-
    var(AttrY),				% no attribute for this extension
    /*** VAR + META ***/
    AttrY = AttrX,			% share the attribute
    notify_constrained(Y).
unify_domain_domain(Y, AttrX, AttrY, XSuspAttr) :-
    nonvar(AttrY),
    /*** META + META ***/
    AttrY = fd with domain:DomY,
    AttrX = fd with domain:DomX,
    dom_intersection(DomX, DomY, NewDom, Size),
    (Size = 1 ->
	NewDom = dom([Y|_], _),		% bind Y, wake inst,bound,constrained
	attr_instantiate(AttrX, Y)	% wake the fd lists
    ;
	attr_bind(AttrX, NewDom, _, XSuspAttr),	% empties the woken lists
	attr_bind(AttrY, NewDom, Y, _),
	dvar_replace(Y, NewDom),
	merge_suspension_lists(min of fd, AttrX, min of fd, AttrY),
	merge_suspension_lists(max of fd, AttrX, max of fd, AttrY),
	merge_suspension_lists(any of fd, AttrX, any of fd, AttrY)
    ).


% Do the wakings that result from changing Attr's domain to NewDom
attr_bind(Attr, NewDom, Var, SuspAttr) :-
    Attr = fd with [domain:D],
    dom_size(D, S),
    dom_size(NewDom, NewS),
    (NewS < S ->
	( nonvar(SuspAttr) ->
	    schedule_suspensions(constrained of suspend, SuspAttr)
	;
	    notify_constrained(Var)
	),
	schedule_suspensions(any of fd, Attr),
	(dom_range(D, Min, Max),
	dom_range(NewDom, NewMin, NewMax) ->
	    (NewMin > Min ->
		schedule_suspensions(min of fd, Attr)
	    ;
		true
	    ),
	    (NewMax < Max ->
		schedule_suspensions(max of fd, Attr)
	    ;
		true
	    )
	;
	    true
	)
    ;
	true
    ).


%----------------------------------------------------------------
% unification test
%----------------------------------------------------------------

% test_unify_domain(+Term, Attribute)
test_unify_domain(_, Attr) :-
    /*** ANY + VAR ***/
    var(Attr).			% Ignore if no attribute for this extension
test_unify_domain(Term, Attr) :-
    nonvar(Attr),
    test_unify_term_domain(Term, Attr).

% We wake every time a variable is touched.
:- mode test_unify_term_domain(?, +).
test_unify_term_domain(Term, fd with domain:D) :-
    -?->
    /*** NONVAR + META ***/
    nonvar(Term),		% Check here if the instantiation is accepted.
    dom_check_in(Term, D).
test_unify_term_domain(Y{fd:AttrY}, AttrX) :-
    -?->
    test_unify_domain_domain(Y, AttrX, AttrY).

test_unify_domain_domain(_, _, AttrY) :-
    /*** VAR + META ***/
    var(AttrY).				% no attribute for this extension
test_unify_domain_domain(Y, fd with domain:DomX, fd with domain:DomY) :-
    -?->
    /*** META + META ***/
    dom_intersection(DomX, DomY, NewDom, _),
    dvar_replace(Y, NewDom).		% may create a singleton domain;
					% but there is no easy way to bind
					% and invoke other handlers

%----------------------------------------------------------------
% instances
%----------------------------------------------------------------

% compare_instances_domain(-Res, ?TermL, ?TermR)
% One or both Terms are attributed variables
compare_instances_domain(Res, _X{fd:AttrX}, Y) ?-
	compare_instances_attr_any(Res, AttrX, Y).
compare_instances_domain(Res, X, _Y{fd:AttrY}) ?- free(X),
	compare_instances_free_attr(Res, AttrY).	% Y must be meta!
compare_instances_domain(Res, X, _Y{fd:AttrY}) ?- nonvar(X),
	compare_instances_const_attr(Res, X, AttrY).	% Y must be meta!

    compare_instances_attr_any(Res, AttrX, _Y{fd:AttrY}) ?-
	compare_instances_attr_attr(Res, AttrX, AttrY).
    compare_instances_attr_any(Res, AttrX, Y) :- free(Y),
	compare_instances_attr_free(Res, AttrX).
    compare_instances_attr_any(Res, AttrX, Y) :- nonvar(Y),
	compare_instances_attr_const(Res, AttrX, Y).

    compare_instances_attr_free(Res, AttrX) :- var(AttrX),
	Res = (=).
    compare_instances_attr_free(Res, AttrX) :- nonvar(AttrX),
	Res = (<).

    compare_instances_free_attr(Res, AttrY) :- var(AttrY),
	Res = (=).
    compare_instances_free_attr(Res, AttrY) :- nonvar(AttrY),
	Res = (>).

    compare_instances_attr_attr(Res, AttrX, AttrY) :- var(AttrX),
	compare_instances_free_attr(Res, AttrY).
    compare_instances_attr_attr(Res, AttrX, AttrY) :- nonvar(AttrX),
	compare_instances_iattr_attr(Res, AttrX, AttrY).

    compare_instances_iattr_attr(Res, _AttrX, AttrY) :- var(AttrY), !,
	Res = (<).
    compare_instances_iattr_attr(Res, fd{domain:DX}, fd{domain:DY}) ?-
	dom_compare(Res, DX, DY).

    compare_instances_const_attr(Res, _X, AttrY) :- var(AttrY), !,
	Res = (<).
    compare_instances_const_attr(Res, X, fd{domain:DY}) ?-
	dom_check_in(X, DY),
	Res = (<).

    compare_instances_attr_const(Res, AttrX, _Y) :- var(AttrX), !,
	Res = (>).
    compare_instances_attr_const(Res, fd{domain:DX}, Y) ?-
	dom_check_in(Y, DX),
	Res = (>).


%----------------------------------------------------------------
% copy_term
%----------------------------------------------------------------

copy_term_domain(X{fd:AttrX}, Copy) :-
    -?->
    copy_term_domain(X, Copy, AttrX).


copy_term_domain(_, _, AttrX) :-
    /*** VAR ***/
    var(AttrX).
copy_term_domain(_, Copy, fd with domain:dom(D, S)) :-
    -?->
    /*** META ***/
    empty_domain(dom(D, S), ND),
    add_attribute(Copy, ND, fd).

empty_domain(D, fd with [domain:D, any:[], min:[], max:[]]).

%----------------------------------------------------------------
% suspensions
%----------------------------------------------------------------

suspensions_domain(_{fd:AttrX}, Susps, Susps0) :-
    -?->
    susp_domain(AttrX, Susps, Susps0).

susp_domain(AttrX, Susps, Susps) :- var(AttrX), !.
susp_domain(fd with [min:Mi, max:Ma, any:B], [Mi,Ma,B|Susps], Susps).


%----------------------------------------------------------------
% delayed goals number
%----------------------------------------------------------------

delayed_goals_number_domain(_{fd:AttrX}, N) :-
    -?->
    dgn_domain(AttrX, N).

dgn_domain(AttrX, 0) :-
    /*** VAR ***/
    var(AttrX).
dgn_domain(fd with [any:B, min:Mi, max:Ma], N) :-
    -?->
    /*** META ***/
    count_active_suspensions(B, 0, N0),
    count_active_suspensions(Mi, N0, N1),
    count_active_suspensions(Ma, N1, N).


count_active_suspensions([Susp|Susps], N0, N) :-
	-?->
	!,
	( is_suspension(Susp) ->
		N1 is N0 + 1
	;
		N1 = N0
	),
	count_active_suspensions(Susps, N1, N).
count_active_suspensions(_, N, N).

% Due to the implementation, it may happen that a metaterm
% occurs in a predicate even if it should not, namely in the case that
% the metaterm is instantiated and a simple goal follows; then
% the domain_unify/1 handler is called only *after* the simple goal.


%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Attaching and querying the domain
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% ?Vars :: ?Domain 
%	The variable(s) Vars have the domain Domain
Varset #:: Domain :-
    Varset :: Domain.
Varset :: Domain :-
    var(Domain),
    get_domain(Varset, Domain).
Varset :: Domain :-
    nonvar(Domain),
    make_domain(Domain, DomRep, Varset),
    fd_dom_simple(Varset, DomRep).

:- mode get_domain(?,-).
get_domain(X, Domain) :- var(X), !,
    (dvar_domain(X, dom(Domain, _)) -> true; fderror(4, X::Domain)).
get_domain(X, Domain) :-
    varset(X), !,
    fderror(5, X::Domain).
get_domain(X, [X]).

% fd_dom_simple(+varset, +domain)
fd_dom_simple(Var, Dom) :- var(Var), !,
    var_fd(Var, Dom).
fd_dom_simple([], _) :- !.
fd_dom_simple([X|Xs], Dom) :- !,
    fd_dom_simple(X, Dom),
    fd_dom_simple(Xs, Dom).
fd_dom_simple(subscript(Array,Index), Dom) :- !,
    subscript(Array, Index, Varset),
    fd_dom_simple(Varset, Dom).
fd_dom_simple(Val, Dom) :-
    dom_check_in(Val, Dom).

var_fd(Var, Domain) :-
    dom_size(Domain, Size),
    ( Size > 1 ->
      dom_copy(Domain, D),
      empty_domain(D, Dom),
      set_domain_var1(Var, Dom)
    ;
	singleton_dom(Var, Domain)
    ).

set_domain_var1(Var{fd:(fd with [])}, Dom) :-
    -?->
    !,
    add_attribute(Var, Dom, fd).	% will be notified in the handler
set_domain_var1(Var, Dom) :-
    add_attribute(Var, Dom, fd),
    new_domain_var(Var),
    notify_constrained(Var),
    wake.

new_domain_var(_).			% primitive hook for extensions

%
% entailment
%
#::(Var, Int, B) :-
    ::(Var, Int, B).
::(Var, Int, B) :-
    nonvar(Int),
    make_domain(Int, DomEnt, Var),
    fd_dom_simple(Var, DomEnt, B).
::(Var, Int, B) :-
    var(Int),
    fderror(4, ::(Var, Int, B)).

dom_ent(Var, DomEnt, B) :-
    dvar_domain(Var, Dom),
    dom_ent(Var, DomEnt, B, Dom).

dom_ent(Var, DomEnt, 0, Dom) :-
    -?->
    dom_difference(Dom, DomEnt, NewDom, _),
    dvar_update(Var, NewDom).
dom_ent(Var, DomEnt, 1, Dom) :-
    -?->
    dom_intersection(Dom, DomEnt, NewDom, _),
    dvar_update(Var, NewDom).
dom_ent(Var, DomEnt, B, Dom) :-
    var(B),
    dom_size(Dom, Size),
    (dom_intersection(Dom, DomEnt, _, SizeInt) ->
	(Size = SizeInt ->
	    B = 1
	;
	    make_suspension(dom_ent(Var, DomEnt, B), 3, Susp),
	    insert_suspension(Var, Susp, any of fd, fd),
	    insert_suspension(B, Susp, inst of suspend, suspend)
	)
    ;
	B = 0
    ).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Conversion to the internal representation
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Create a representation of the domain.
make_domain([H|T], Domain, Var) :-
    !,
    make_dom([H|T], Domain, Var).
% Only for Chip compatibility 
make_domain(Start:End, Domain, Var) :-
    !,
    make_dom([Start..End], Domain, Var).
make_domain([], Domain, _Var) :-
    !,
    empty_dom(Domain).
make_domain(Value, Domain, Var) :-
    make_dom([Value], Domain, Var).

make_dom(List, dom(Domain, Size), _) :-
    make_ground_dom(List, Domain, Size),
    !,
    Size > 0.
make_dom(List, _, Var) :-
    get_bip_error(Err),
    fderror(Err, Var :: List).

empty_dom(dom([], 0)).
singleton_dom(Value, dom([Value], 1)).

sorted_list_to_dom(List, dom(D, _)) :-
    -?->
    List = D.
sorted_list_to_dom(List, Dom) :-
    var(Dom),
    Dom = dom(List, Size),
    list_size(List, 0, Size).

list_size([], S, S).
list_size([H|T], S0, S) :-
    el_size(H, S1),
    S2 is S0 + S1,
    list_size(T, S2, S).

el_size(M..N, S) :-
    !,
    S is N - M + 1.
el_size(_, 1).

list_to_dom(List, dom(Domain, Size)) :-
    make_ground_dom(List, Domain, Size),
    !,
    Size > 0.
list_to_dom(List, Domain) :-
    get_bip_error(Err),
    fderror(Err, list_to_dom(List, Domain)).

make_ground_dom(List, Domain, Size) :-
    sort(List, SList),
    domain_types(SList, Domain, FL, Integers, Intervals, AfterInt, 0, S),
    make_integer_subdom(Integers, Intervals, DI, SU),
    append(DI, AfterInt, FL),
    Size is S + SU,
    (Size > 16'7fffffff ->
	set_bip_error(6)
    ;
	true
    ).

%
% domain_types(List, Floats, FC, Integers, Intervals, Atomic, Ac, ASize)
% Split the sorted input list into a list of different types:
%	Floats (they are smaller than any other atomic type)
%	Integers and intervals
%	Other atomic types (greater than integers and floats)
% FC is the tail of the Floats list, it is used for appending the integers
% and the rest.

:- mode domain_types(+,-,-,-,-,-,+,-).
domain_types([], F, F, [], [], [], N, N) :- !.
domain_types([H|T], F, F0, I, S, A, N0, N) :-
    domain_types1(H, F, F0, I, S, A, N0, N, T).

/*    domain_types1(-,-,-,-,-,-,+,-,+) */
  
    domain_types1(Var, _, _, _, _, _, _, _, _) :-
    	var(Var),
	!,
	set_bip_error(4).
    domain_types1(H, [H|F1], F0, I, S, A, N0, N, T) :-
    	float(H),
	!,
	N1 is N0 + 1,
	domain_types(T, F1, F0, I, S, A, N1, N).
    domain_types1(H, F, F0, [H|I], S, A, N0, N, T) :-
    	integer(H),
	!,
	domain_types(T, F, F0, I, S, A, N0, N).
    domain_types1(K..M, F, F0, I, S, A, N0, N, T) :-
	!,
	( integer(K) -> N1 = K
	; nonvar(K) -> N1 is K, ( integer(N1) -> true ; set_bip_error(5) )
	; set_bip_error(4) ),
	( integer(M) -> N2 = M
	; nonvar(M) -> N2 is M, ( integer(N2) -> true ; set_bip_error(5) )
	; set_bip_error(4) ),
	( N1 =< N2 ->
	    S = [N1..N2 | S1]
	;
	    S1 = S
	),
	domain_types(T, F, F0, I, S1, A, N0, N).
    domain_types1(Str, _, _, _, _, _, _, _, _) :-
	nonground(Str),
	!,
	set_bip_error(4).
    domain_types1(H, F, F0, I, S, [H|A], N0, N, T) :-
	N1 is N0 + 1,
	domain_types(T, F, F0, I, S, A, N1, N).


% Make an integer domain out of sorted integer and interval lists.
make_integer_subdom(Integers, Intervals, Dom, SU) :-
    integer_list_to_dom(Intervals, DS),
    integer_list_to_dom(Integers, DI),
    (dom_union(DS, DI, dom(Dom, SU), SU) ->
	true
    ;
	Dom = [],
	SU = 0
    ).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%	Domain querying and updates
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

is_domain(_{fd:(fd with [])}) :- -?-> true.

is_finite(_{fd:(fd with [])}) :- -?-> true.
is_finite(I) :-
    integer(I).

is_integer_domain(_{fd:(fd with domain:D)}) :-
    -?->
    dom_range(D, _, _).

% Var is guaranteed to have an fd attribute!
get_fd_bounds(_{fd:(fd with [domain:D])}, L, H) :- -?-> !,
	dom_range(D, L, H).

% Var is guaranteed to have an fd attribute!
set_fd_bounds(Var, Lwb, Upb) :-
	L is fix(ceiling(Lwb)),
	U is fix(floor(Upb)),
	dvar_remove_smaller(Var, L),
	dvar_remove_greater(Var, U),
	wake.


dvar_domain(_{fd:(fd with [domain:D])}, Domain) :-
    -?->
    !,
    Domain = D.
dvar_domain(Var, D) :-
    nonvar(Var),
    singleton_dom(Var, D).

get_attribute(_{fd:Attr}, Meta) :-
    -?->
    compound(Attr),
    Attr = Meta.

dvar_attribute(_{fd:Attr}, DS) :-
    -?->
    !,
    nonvar(Attr),
    Attr = DS.
dvar_attribute(Var, _) :- var(Var), !, fail.
dvar_attribute(Value, Dom) :-
    nonvar(Value),
    singleton_dom(Value, D),
    empty_domain(D, Dom).

% Replace the domain by another one, do all checks
:- mode dvar_update(?, ++).
dvar_update(A, Dom) :-
    nonvar(A),
    Dom = dom([A], 1).
dvar_update(Var{fd:DS}, NewDom) :-
    -?->
    NewDom = dom(_, Size),
    dvar_update(Var, NewDom, DS, Size).

:- mode dvar_update(?, ++, ++, ++).
dvar_update(Var, dom([Var|_], _), _, 1) :- !.
dvar_update(Var, NewDom, DS, Size) :-
%    integer(Size),
%    Size > 1,
    DS = fd with domain:dom(_, OldSize),
    (Size < OldSize ->
	attr_bind(DS, NewDom, Var, _),
	dvar_replace(Var, NewDom)
    ;
    Size = OldSize ->
	true
    ;
	error(6, dvar_update(Var, NewDom))
    ).

:- mode dvar_update_nocheck(?, ++, ++).
dvar_update_nocheck(Var, [Var|_], 1) :- !.
dvar_update_nocheck(Var{fd:DS}, ND, Size) :-
    -?->
%    integer(Size),
%    Size > 1,
    NewDom = dom(ND, Size),
    attr_bind(DS, NewDom, Var, _),
    dvar_replace(Var, NewDom).

constraints_number(Var, Number) :-
    delayed_goals_number(Var, Number).

:- mode dvar_msg(?, ?, -).
dvar_msg(_A{fd:fd{domain:DA}}, B, M) ?- !,
	msg_domain(DA, B, M).
dvar_msg(A, _B{fd:fd{domain:DB}}, M) ?- !,
	msg_domain(DB, A, M).
dvar_msg(A, B, M) :-
	ground(A), !,
	msg_atomic(A, B, M).
dvar_msg(_A, _B, _M).

% even if B is an atomic term, A is neither an atomic term nor a domain variable

% A is a domain variable
msg_domain(DA, _B{fd:fd{domain:DB}}, M) ?- !,
	dom_union(DA, DB, DM, _),
	empty_domain(DM, Dom),
	add_attribute(M, Dom, fd).
msg_domain(DA, B, M) :-
	ground(B), !,
	( dom_check_in(B, DA) ->
	    empty_domain(DA, Dom),
	    add_attribute(M, Dom, fd)
	; singleton_dom(B, DB),
	  dom_union(DA, DB, DM, _),
	  empty_domain(DM, Dom),
	  add_attribute(M, Dom, fd)
        ).
msg_domain(_DA, _B, _M).

% A is a nonvar term
% B is not a domain variable
msg_atomic(A, B, M) :-
	ground(B), !,
	( A = B ->
	    M = A
	; sort([A, B], D),
	  M :: D
        ).
msg_atomic(_A, _B, _M).

indomain(Var{fd:(fd with domain:D)}) :-
    -?->
    !,
    dom_member(Var, D).
indomain(Val) :-
    nonvar(Val).
indomain(Var) :-
    var(Var),
    error(4, indomain(Var)).

par_indomain(Var{fd:(fd with domain:D)}) :-
    -?->
    !,
    par_dom_member(Var, D).
par_indomain(Val) :-
    nonvar(Val).
par_indomain(Var) :-
    var(Var),
    error(4, par_indomain(Var)).

% Enumerate the elements of a domain.
:- mode dom_member(?, ++).
dom_member(Val, dom([H|T], _)) :-
	dom_member(Val, H, T).

:- mode dom_member(?, ++, ++).
dom_member(Val, Start..End, T) :- !,
	interv_member(Val, Start, End, T).
dom_member(Val, Elem, T) :-
	elem_member(Val, Elem, T).

:- mode elem_member(?, ++, ++).
elem_member(Val, Val, _).
elem_member(Var, Val, [H|T]) :-
	remove_element(Var, Val, _),
	dom_member(Var, H, T).

:- mode interv_member(?, ++, ++, ++).
interv_member(Val, Start, End, _) :-
	between(Start, End, 1, Val).
interv_member(Var, _, _, [H|T]) :-
	dom_member(Var, H, T).


% Enumerate the elements of a domain (in parallel).
:- mode par_dom_member(?, ++).
par_dom_member(Val, dom([H|T], _)) :-
	par_dom_member(Val, H, T).

:- mode par_dom_member(?, ++, ++).
par_dom_member(Val, Start..End, T) :- !,
	par_interv_member(Val, Start, End, T).
par_dom_member(Val, Elem, T) :-
	par_elem_member(Val, Elem, T).

:- parallel par_elem_member/3.
:- mode par_elem_member(?, ++, ++).
par_elem_member(Val, Val, _).
par_elem_member(Var, Val, [H|T]) :-
	remove_element(Var, Val, _),
	par_dom_member(Var, H, T).

:- parallel par_interv_member/4.
:- mode par_interv_member(?, ++, ++, ++).
par_interv_member(Val, Start, End, _) :-
	End1 is End+1,
	N is End1-Start,
	fork(N, I),
	Val is End1-I.
par_interv_member(Var, _, _, [H|T]) :-
	par_dom_member(Var, H, T).

% must be after the make_domain/3 definition which is needed to expand ::
fd_dom_simple(Var, Dom, B) :-
    check_dom(Var),
    B :: 0..1,
    dom_ent(Var, Dom, B).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
%     Operations on domains (others are written in C)
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

% Convert a domain to a list of its elements.
dom_to_list(dom(D, _), L) :-
	dom_to_list2(D, L).

dom_to_list2([], []).
dom_to_list2([Inter|Intervs], List) :-
        inter1_to_list(Inter, List, Last),
        dom_to_list2(Intervs, Last).
 
:- mode inter1_to_list(++, ?, ?).
inter1_to_list(Low..Up, List, Last) :-
	!,
        gen_list(Low, Up, List, Last). 
inter1_to_list(One, [One|Last], Last). 
 
% Make a partial list of integers from M to N
gen_list(Up, Up, [Up|Last], Last) :- !.  
gen_list(Low, Up, [Low|Next], Last) :- 
        NextLow is Low + 1,
        gen_list(NextLow, Up, Next, Last).



dom_size(dom(_, Size), Size).

dom_copy(dom(Dom, Size), dom(Dom, Size)).


:- untraceable
	unify_domain/3,
	unify_term_domain/3,
	test_unify_domain/2,
	compare_instances_domain/3,
	copy_term_domain/2,
	suspensions_domain/3,
	delayed_goals_number_domain/2,
	tr_fd_domain_in/2,
	tr_fd_domain_out/2.
