1:- module(eunify, [eunify/2, pairs_to_alg/3, pairs_to_clpfd_alg/2]).    2
    3term_functor_args(Term, N/A, Args) :-
    4    $(functor(Term, N, A)),
    5    $(Term =.. [N|Args]).
    6
    7apply_op(i_o_state(InVars, OutVar, State), Ins, Out) =>
    8    copy_term(i_o_state(InVars, OutVar, State),
    9              i_o_state(Ins,    Out,    State)).
   10
   11apply_alg(Alg, Term, Out) =>
   12    $(term_functor_args(Term, F, Args)),
   13    $(rb_lookup(F, Mop, Alg)),
   14    apply_op(Mop, Args, Out).
   15
   16cata(F, A, B) :-
   17    $(rb_empty(Seen)),
   18    cata_(F, Seen, A, B).
   19
   20cata_(_, _, Var, _), var(Var) =>
   21    throw(error(instantiation_error(Var),
   22          context(_Loc, "Variables must be wrapped with (?)/1"))).
   23cata_(_, _, ?(A), B) => B = A.
   24cata_(F, Seen, A, B) =>
   25    rb_insert_new(Seen, A, B, Seen1)
   26    -> $(same_functor(A, C)), % Apply constraint early.
   27       call(F, C, B),
   28       mapargs(cata_(F, Seen1), A, C)
   29    ;  $(rb_lookup(A, B, Seen)). % Tie the knot.
   30
   31eunify(Alg, X = Y) =>
   32    cata(apply_alg(Alg), X, Z),
   33    cata(apply_alg(Alg), Y, Z).
   34
   35
   36%%% Helpers for constructing an algebra %%%
   37
   38pairs_to_clpfd_alg --> pairs_to_alg(or_and_eq(#\/, #/\, #=)).
   39
   40pairs_to_alg(Type, Pairs, CAlg) :-
   41    $(pairs_functions_ops(Pairs, Functions, Ops)),
   42    $(pairs_keys_values(FToMopPairs, Functions, Ops)),
   43    $(group_pairs_by_key(FToMopPairs, CAlgList)),
   44    $(list_to_rbtree(CAlgList, CAlgRB)),
   45    $(rb_map(CAlgRB, compile_op(Type), CAlg)).
   46
   47compile_op(Type, Cases, i_o_state(IVars, OVar, State)) :-
   48    $(Cases = [Is-_|_]),
   49    $(length(Is, Arity)),
   50    $(length(IVars, Arity)),
   51    $(term_variables_excluding(Cases, State, [OVar|IVars])),
   52    $(post_op_constraint(Type, Cases, IVars, OVar)).
   53
   54post_op_constraint(or_and_eq(Or, And, Eq), Cases, IVars, OVar) =>
   55    $(maplist(case_constraint(or_and_eq(Or, And, Eq), IVars, OVar), Cases, [C|Cs])),
   56    $(foldl(cons(Or), Cs, C, Expr)),
   57    $(call(Expr)).
   58
   59term_variables_excluding(Term, Vars, Exclude) :-
   60    $(term_variables(Term, All)),
   61    $(list_to_ord_set(All, AllS)),
   62    $(list_to_ord_set(Exclude, ExcludeS)),
   63    $(ord_subtract(AllS, ExcludeS, Vars)).
   64
   65case_constraint(or_and_eq(_, And, Eq), Ins, Out, Args-Value, Expr) =>
   66    $(maplist(cons(Eq), Ins, Args, Conjs)),
   67    cons(Eq, Out, Value, Conj1),
   68    $(foldl(cons(And), Conjs, Conj1, Expr)).
   69
   70pairs_functions_ops(Alg, Functions, Ops) :-
   71    $(sort(Alg, SortedAlg)),
   72    $(pairs_keys_values(SortedAlg, PreImage, Outputs)),
   73    $(maplist(term_functor_args, PreImage, Functions, Inputs)),
   74    $(pairs_keys_values(Ops, Inputs, Outputs)).
   75
   76cons(Op, A, B, C) :-
   77    $(functor(C, Op, 2)),
   78    $(arg(1, C, A)),
   79    $(arg(2, C, B))