1/*  Part of SWI-Prolog
    2    Author:        Douglas R. Miles, Jan Wielemaker
    3    E-mail:        logicmoo@gmail.com, jan@swi-prolog.org
    4    WWW:           http://www.swi-prolog.org http://www.logicmoo.org
    5    Copyright (C): 2015, University of Amsterdam
    6                                    VU University Amsterdam
    7    This program is free software; you can redistribute it and/or
    8    modify it under the terms of the GNU General Public License
    9    as published by the Free Software Foundation; either version 2
   10    of the License, or (at your option) any later version.
   11    This program is distributed in the hope that it will be useful,
   12    but WITHOUT ANY WARRANTY; without even the implied warranty of
   13    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   14    GNU General Public License for more details.
   15    You should have received a copy of the GNU General Public
   16    License along with this library; if not, write to the Free Software
   17    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
   18    As a special exception, if you link this library with other files,
   19    compiled with a Free Software compiler, to produce an executable, this
   20    library does not by itself cause the resulting executable to be covered
   21    by the GNU General Public License. This exception does not however
   22    invalidate any other reasons why the executable file might be covered by
   23    the GNU General Public License.
   24*/
   25
   26:- module(multivar,
   27 [
   28   test_case_1/0,
   29   test_case_2/0,
   30   test_case_3/0,
   31   test_case_4/0
   32  /* mdwq/1, 
   33		  plvar/1,
   34          nb_var/1, nb_var/2,
   35          vdict/1, vdict/2,
   36		  un_mv/1, un_mv1/1,
   37		  mv_peek_value/2,mv_peek_value1/2,
   38		  mv_set/2,mv_set1/2,
   39		  mv_add1/2,mv_allow/2,
   40		  ic_text/1,
   41
   42   is_mv/1, multivar/1 % create special varaible that cannot be bound
   43   */
   44   ]).   45
   46:- use_module(logicmoo_common).   47:- meta_predicate user:attvar_variant(0,0).   48:- use_module(library(option),[dict_options/2,option/2]).   49
   50%:- set_prolog_flag(access_level,system).
   51%:- set_prolog_flag(gc,false).
   52
   53% use_module(library(multivar)),call(multivar(X)),trace,X=2.
   54
   55mdwq(Q):- format(user_error,'~NMWQ: ~q~n',[Q]).
   56
   57:- meta_predicate mdwq_call(*).   58mdwq_call(Q):- !, call(Q).
   59mdwq_call(Q):- call(Q) *-> mdwq(success:Q); (mdwq(failed:Q),!,fail).
   60:- export(mdwq_call/1).   61
   62:- if(current_prolog_flag(attr_pre_unify_hook,true)).   63
   64:- module_transparent(user:attr_pre_unify_hook/3).   65:- user:export(user:attr_pre_unify_hook/3).   66
   67:- '$set_source_module'('$attvar').   68
   69:- module_transparent(system : = /2).   70:- module_transparent(wakeup/2).   71:- module_transparent('$wakeup'/1).   72wakeup(wakeup(Attribute, Value, Rest),M) :- !,
   73    begin_call_all_attr_uhooks(Attribute, Value, M),
   74    '$wakeup'(Rest).
   75wakeup(_,_).
   76
   77:- import(user:attr_pre_unify_hook/3).   78:- module_transparent(user:attr_pre_unify_hook/3).   79% replaces call_all_attr_uhooks
   80begin_call_all_attr_uhooks(att('$VAR$', IDVar, Attrs),Value, M) :- !,
   81    M:attr_pre_unify_hook(IDVar, Value, Attrs).
   82begin_call_all_attr_uhooks(Attribute, Value, M) :-
   83    call_all_attr_uhooks(Attribute, Value, M).
   84
   85orig_call_all_attr_uhooks([], _).
   86orig_call_all_attr_uhooks(att(Module, AttVal, Rest), Value) :-
   87    uhook(Module, AttVal, Value),
   88    orig_call_all_attr_uhooks(Rest, Value).
   89
   90
   91:- module_transparent(call_all_attr_uhooks/3).   92call_all_attr_uhooks(att(Module, AttVal, Rest), Value, M) :- !,
   93    uhook(Module, AttVal, Value, M),
   94    call_all_attr_uhooks(Rest, Value, M).
   95call_all_attr_uhooks(_, _, _).
   96
   97:- module_transparent(uhook/4).   98uhook(freeze, Goal, Y, M) :-
   99 M:(
  100    !,
  101    (   attvar(Y)
  102    ->  (   get_attr(Y, freeze, G2)
  103        ->  put_attr(Y, freeze, '$and'(G2, Goal))
  104        ;   put_attr(Y, freeze, Goal)
  105        )
  106    ;   '$attvar':unfreeze(Goal)
  107    )).
  108
  109uhook(Module, AttVal, Value, M) :-
  110  M:(
  111    true,
  112    Module:attr_unify_hook(AttVal, Value)).
  113
  114
  115:- ((abolish('$wakeup'/1),'$attvar':asserta('$wakeup'(M:G):-wakeup(G,M)))).  116:- meta_predicate('$wakeup'(:)).  117
  118:- all_source_file_predicates_are_transparent.  119
  120:- '$set_source_module'('multivar').  121
  122:- module_transparent(attr_pre_unify_hook_m/4).  123attr_pre_unify_hook_m(IDVar, Value, _, M):- \+ attvar(IDVar),!, M:(IDVar=Value).
  124attr_pre_unify_hook_m(Var,Value,Rest, M):- 
  125  mdwq_call('$attvar':call_all_attr_uhooks(Rest, Value, M)),
  126  nop(M:mv_add1(Var,Value)).
  127
  128user:attr_pre_unify_hook(Var,Value,Rest):- strip_module(Rest,M,_), attr_pre_unify_hook_m(Var,Value,Rest,M).
  129
  130:- else.  131
  132:- module_transparent(user:meta_unify/3).  133user:meta_unify(Var,Rest,Value):- user:attr_pre_unify_hook(Var,Value,Rest).
  134
  135%-----------------------------------------------------------------
  136% Blugened in version of verify_attributes/3
  137
  138
  139user:attr_pre_unify_hook(IDVar, Value, _):- \+ attvar(IDVar),!, IDVar=Value.
  140/*
  141user:attr_pre_unify_hook(IDVar, Value, Attrs):-
  142  call_verify_attributes(Attrs, Value, IDVar, [], Goals),
  143  nop(attv_bind(IDVar, Value)),
  144  maplist(call,Goals).
  145*/
  146%user:attr_pre_unify_hook(IDVar, Value, Attrs):-  '$attvar':call_all_attr_uhooks(att('$VAR$',IDVar,Attrs),Value).
  147user:attr_pre_unify_hook(Var,Value,Rest):- 
  148  mdwq_call('$attvar':call_all_attr_uhooks(Rest, Value)),
  149  nop(mv_add1(Var,Value)).
  150
  151:- endif.  152
  153
  154
  155call_verify_attributes([], _, _) --> [].
  156call_verify_attributes(att(Module, _, Rest), Value, IDVar) -->
  157    { Module:verify_attributes(IDVar, Value, Goals) }, 
  158    Goals,
  159    call_verify_attributes(Rest, Value, IDVar).
  160
  161% make code us verify_attributes/3 instead of attr_unify_hook/2
  162use_va(Var):-
  163  put_attr(Var,'$VAR$',Var).
  164
  165%-----------------------------------------------------------------
  166
  167verify_attributes(Var, _, Goals) :-
  168   get_attr(Var, '$VAR$', Info), !,
  169   \+ contains_var(Var,Info),
  170  Goals=[].
  171
  172verify_attributes(_, _, []).
  173
  174
  175% Swi-pre-unify Case#1  not able to emulate in SWI  due to "Identity"
  176
  177swiu_case_1 :-
  178 use_va(Y), put_attr(Y,'$VAR$',Y),
  179 Y = 4201.
  180
  181% must fail
  182test_case_1 :-  \+  swiu_case_1.
  183
  184
  185%-----------------------------------------------------------------
  186
  187% Swi-pre-unify Case#2   "Identity"
  188
  189swiu_case_2 :-
  190   use_va(Y), put_attr(Y, '$VAR$', al(Y,a(X))),
  191   X = 420,
  192   Y = 420.
  193
  194% must fail
  195test_case_2 :-  \+  swiu_case_2.
  196
  197
  198% -----------------------------------------------------------------
  199% Swi-pre-unify Case #3   "Identity" (fixed from last email)
  200
  201swiu_case_3 :-
  202  use_va(Y), put_attr(Y,'$VAR$', a(420)),
  203  Y = 420.
  204
  205% must Succeed
  206test_case_3 :-  swiu_case_3.
  207
  208
  209
  210%-----------------------------------------------------------------
  211% Swi-pre-unify Case #4  more "Identity"
  212
  213swiu_case_4 :-
  214 use_va(Y), put_attr(Y,'$VAR$', X),
  215 X = 420,
  216 Y = 420.
  217
  218% must succeed
  219test_case_4 :-  swiu_case_4.
  220
  221
  222% ==========================================
  223%  Unify hook
  224% ==========================================
  225
  226% 'unify':attr_unify_hook(_,_).  % OR tracing with 'unify':attr_unify_hook(N,Var):- mdwq(meta_unify_hook(N,Var)).
  227
  228
  229% multivar(Var):- put_attr(Var,unify,Var).
  230% multivar(Var):- put_attr(Var,'$VAR$',Var).
  231
  232xvarx(Var):- 
  233   get_attr(Var,'$VAR$',MV)-> var(MV) ; 
  234   (get_attrs(Var,Attrs) -> put_attrs(Var,att('$VAR$',Var,Attrs)) ;
  235   (true -> put_attrs(Var,att('$VAR$',Var,[])))).
  236
  237 
  238
  239% is_mv(Var):- attvar(Var),get_attr(Var,unify,Waz),var(Waz).
  240is_mv(Var):- attvar(Var),get_attr(Var,'$VAR$',_Waz).
  241
  242% ==========================================
  243% ATOM_dvard override TODO
  244% ==========================================
  245
  246'$VAR$':attr_unify_hook(_,_).
  247'$VAR$':attribute_goals(Var) --> {is_implied_xvarx(Var)}->[] ; [xvarx(Var)].
  248
  249is_implied_xvarx(MV):- get_attrs(MV,ATTS),is_implied_xvarx(MV,ATTS).
  250is_implied_xvarx(MV,att(M,Val,ATTS)):- ((Val==MV, \+ atom_concat('$',_,M)) -> true ; is_implied_xvarx(MV,ATTS)).
  251% ==========================================
  252% Variant override TODO
  253% ==========================================
  254
  255'variant':attr_unify_hook(_,_).
  256user:attvar_variant(N,Var):- (N==Var -> true ;  mdwq_call( \+ \+ =(N,Var) )).
  257
  258% ==========================================
  259% reference override TODO
  260% ==========================================
  261
  262'references':attr_unify_hook(_,_).
  263user:attvar_references(N,Var):- (N==Var -> true ;  mdwq_call( \+ \+ =(N,Var) )).
  264
  265
  266% ==========================================
  267% Sets values
  268% ==========================================
  269multivar(Var):- var(Var)->multivar1(Var);(term_variables(Var,Vars),maplist(multivar1,Vars)).
  270multivar1(Var):- xvarx(Var),(get_attr(Var,'$value',lst(Var,_))->true; put_attr(Var,'$value',lst(Var,[]))).
  271'$value':attr_unify_hook(lst(Was,Values),Becoming):- var(Was),attvar(Becoming),!,mv_add_values(Becoming,Values).
  272'$value':attr_unify_hook(lst(Var,_Values),Value):- mv_add1(Var,Value).
  273
  274%'$value':attribute_goals(_)-->!.
  275'$value':attribute_goals(Var)--> {get_attr(Var,'$value',lst(Var,Values))},[mv_set_values(Var,Values)].
  276mv_set_values(Var,Values):- put_attr(Var,'$value',lst(Var,Values)).
  277mv_set1(Var,Value):- put_attr(Var,'$value',lst(Var,[Value])).
  278mv_add1(Var,NewValue):- Var==NewValue,!.
  279mv_add1(Var,NewValue):- mv_prepend1(Var,'$value',NewValue).
  280mv_add_values(Becoming,Values):- maplist(mv_add1(Becoming),Values).
  281
  282
  283mv_prepend1(Var,Mod,Value):- get_attr(Var,Mod,lst(Var,Was))->(prepend_val(Value,Was,New)->put_attr(Var,Mod,lst(Var,New)));put_attr(Var,Mod,lst(Var,[Value])).
  284mv_prepend_values(Becoming,Mod,Values):- maplist(mv_prepend1(Becoming,Mod),Values).
  285
  286prepend_val(Value,[],[Value]).
  287prepend_val(Value,Was,[Value|NewList]):-delete_identical(Was,Value,NewList).
  288
  289delete_identical([],_,[]).
  290delete_identical([Elem0|NewList],Elem1,NewList):-Elem1==Elem0,!.
  291delete_identical([ElemKeep|List],Elem1,[ElemKeep|NewList]):-delete_identical(List,Elem1,NewList).
  292
  293% faster than mv_prepend1 - might use?
  294mv_prepend(Var,Mod,Value):- get_attr(Var,Mod,lst(Var,Was))->
  295   put_attr(Var,Mod,lst(Var,[Value|Was]));
  296   put_attr(Var,Mod,lst(Var,[Value])).
  297
  298% ==========================================
  299% Peeks values
  300% ==========================================
  301
  302mv_peek_value(Var,Value):- mv_members(Var,'$value',Value).
  303mv_peek_value1(Var,Value):- mv_peek_value(Var,Value),!.
  304
  305
  306
  307% ==========================================
  308% Peeks any
  309% ==========================================
  310
  311mv_members(Var,Mod,Value):- get_attr(Var,Mod,lst(_,Values)),!,member(Value,Values).
  312% mv_get_attr1(Var,Mod,Value):- mv_members(Var,Mod,Value),!.
  313           
  314
  315guard_from_var(V):- nonvar(V),!.
  316guard_from_var(V):- attvar(V),!.
  317guard_from_var(V):- xvarx(V),!.
  318
  319% ==========================================
  320% Allow-only values
  321% ==========================================
  322
  323check_allow(Var,Value):- get_attr(Var,'$allow',lst(Var,Disallow)), memberchk_variant_mv(Value,Disallow).
  324mv_allow(Var,Allow):- guard_from_var(Allow),mv_prepend(Var,'$allow',Allow).
  325'$allow':attr_unify_hook(lst(Var,Allow),Value):- \+ ((memberchk_variant_mv(Value,Allow)->true;get_attr(Var,ic_text,_))),!,fail.
  326'$allow':attr_unify_hook(lst(Was,Values),Becoming):- 
  327  ignore((var(Was),attvar(Becoming),!,mv_prepend_values(Becoming,'$allow',Values))).
  328'$allow':attribute_goals(Var)--> {get_attr(Var,'$allow',Allow)},[mv_allow(Var,Allow)].
  329
  330% ==========================================
  331% Disallow-only values
  332% ==========================================
  333
  334check_disallow(Var,Value):- (get_attr(Var,'$disallow',lst(Var,Disallow)) -> \+ memberchk_variant_mv(Value,Disallow) ; true).
  335mv_disallow(Var,Disallow):- guard_from_var(Disallow),mv_prepend(Var,'$disallow',Disallow).
  336'$disallow':attr_unify_hook(lst(_Var,Disallow),Value):-  memberchk_variant_mv(Value,Disallow),!,fail.
  337'$disallow':attr_unify_hook(lst(Was,Values),Becoming):- 
  338   ignore((var(Was),attvar(Becoming),!,mv_prepend_values(Becoming,'$disallow',Values))).
  339'$disallow':attribute_goals(Var)--> {get_attr(Var,'$disallow',Disallow)},[mv_disallow(Var,Disallow)].

 memberchk_variant_mv(?X, :TermY0) is semidet

Memberchk based on == for Vars else =@= .

  345memberchk_variant_mv(X, List) :- is_list(List),!, \+ atomic(List), C=..[v|List],(var(X)-> (arg(_,C,YY),X==YY) ; (arg(_,C,YY),X =@= YY)),!.
  346memberchk_variant_mv(X, Ys) :-  nonvar(Ys), var(X)->memberchk_variant0(X, Ys);memberchk_variant1(X,Ys).
  347memberchk_variant0(X, [Y|Ys]) :-  X==Y  ; (nonvar(Ys),memberchk_variant0(X, Ys)).
  348memberchk_variant1(X, [Y|Ys]) :-  X =@= Y ; (nonvar(Ys),memberchk_variant1(X, Ys)).
  349
  350
  351
  352% ==========================================
  353% Label values
  354% ==========================================
  355
  356un_mv(Var):-del_attr(Var,'$VAR$')->(mv_peek_value(Var,Value)*->Var=Value;true);true.
  357un_mv1(Var):-del_attr(Var,'$VAR$')->ignore(mv_peek_value1(Var,Var));true.
  358
  359
  360% ==========================================
  361% Examples
  362% ==========================================
  363/*
  364
  365% ?- multivar(X),X=1,X=2,un_mv(X),writeq(X).
  366% ?- multivar(X),X=x(X),mv_allow(X,hello),mv_allow(X,hi), X=hello,X=hi,mv_peek_value(X,V)
  367% ?- multivar(X),mv_allow(X,hello),mv_allow(X,hi), X=hello,X=hi,writeq(X).
  368% ?- multivar(X),mv_allow(X,hello),mv_allow(X,hi),X=hello,X=hi,X=hello,un_mv(X).
  369% ?- multivar(X),mv_allow(X,hello),mv_allow(X,hi),X=hello,X=hi,X=hello,!,un_mv(X)
  370% ?- multivar(X),mv_allow(X,One),X=good,!,un_mv(X).
  371% ?- \+ (multivar(X),mv_allow(X,One),X=good,X=bad,un_mv(X)).
  372
  373
  374% ?- \+ (ic_text(X),X="GOOD",X=good,X=one).
  375% ?- ic_text(X),X=good,X=gooD,un_mv(X).
  376% ?- ic_text(X),X="GOOD",X=good.
  377% ?- ic_text(X),mv_allow(X,"GOOD"),mv_allow(X,"BAD"),X=good,X=baD.
  378% ?- \+ (ic_text(X),mv_allow(X,"GOOD"),mv_allow(X,"BAD"),X=good,X=one).
  379
  380?- multivar(X),mv_disallow(X,1),mv_disallow(X,3).
  381multivar(X),
  382mv_disallow(X, lst(X, [3, 1])).
  383
  384*/
  385% ==========================================
  386% Prolog-Like vars
  387% ==========================================
  388plvar(Var):- multivar(Var), put_attr(Var,plvar,Var).
  389plvar:attr_unify_hook(Var,Value):- mv_peek_value1(Var,Was)->Value=Was;mv_set1(Var,Value).
  390'plvar':attribute_goals(Var)--> {get_attr(Var,'plvar',Var)},[plvar(Var)].
  391
  392
  393% Maybe Variables entering the clause database
  394:- meta_predicate multivar_call(1,0).  395multivar_call(Type,Goal):-term_variables(Goal,Vars),maplist(Type,Vars),call(Goal).
  396
  397
  398% ==========================================
  399% Symbol-Like Global vars
  400% ==========================================
  401nb_var(Var):- gensym(nb_var_,Symbol),nb_var(Symbol, Var).
  402nb_var(Symbol, Var):- multivar(Var), put_attr(Var,nb_var,lst(Var,Symbol)), nb_linkval(Symbol,Var).
  403
  404% This should pretend to be be value1 slot instead
  405% so that we extext mv_peek_value1/2 and mv_set1/2
  406% to stroe things in GVAR in the case of a nb_var
  407nb_var:attr_unify_hook(lst(_Var,Symbol),Value):-
  408       nb_getval(Symbol,Prev),
  409       ( % This is how we produce a binding for +multivar "iterator"
  410          (var(Value),nonvar(Prev)) ->  Value=Prev;
  411         % same binding (effectively)
  412             Value==Prev->true;
  413         % On unification we will update the internal '$value'
  414             Value=Prev->nb_setval(Symbol,Prev)).
  415
  416% ==========================================
  417% Hashmap-Like vars
  418% ==========================================
  419
  420
  421vdict(Var):- multivar(Var), put_attr(Var,vdict,Var).
  422vdict(Value,Var):- vdict(Var),Var=Value.
  423vdict:attr_unify_hook(Var,OValue):- to_dict(OValue,Value)-> mv_peek_value(Var,Prev), merge_dicts(Prev,Value,Result)-> mv_set1(Var,Result).
  424
  425
  426to_dict(Value,Value):- is_dict(Value),!.
  427to_dict(OValue,Value):- is_list(OValue),!,dict_options(Value,OValue).
  428to_dict(OValue,Value):- compound(OValue),!,option(OValue,[MValue]),!,dict_options(Value,[MValue]).
  429to_dict(OValue,Value):- option('$value'=OValue,[MValue]),!,dict_options(Value,[MValue]).
  430                                                              
  431
  432merge_dicts(Value,Value,Value).
  433merge_dicts(Prev,Value,Prev):- Value :< Prev.
  434merge_dicts(Value,Prev,Prev):- Value :< Prev.
  435merge_dicts(Dict1,Dict2,Combined):- dicts_to_same_keys([Dict1,Dict2],dict_fill(_),[Combined,Combined]).
  436
  437
  438
  439% ==========================================
  440% Insensitively cased text
  441% ==========================================
  442
  443ic_text(Var):- put_attr(Var,ic_text,Var),multivar(Var),!.
  444
  445ic_text:attr_unify_hook(Var,Value):- check_disallow(Var,Value),
  446 ((mv_members(Var,'$allow',One);mv_peek_value1(Var,One))*-> ic_unify(One,Value)).
  447
  448'ic_text':attribute_goals(Var)--> {get_attr(Var,'ic_text',Var)},[ic_text(Var)].
  449/*
  450*/
  451
  452ic_unify(One,Value):- (One=Value -> true ; (term_upcase(One,UC1),term_upcase(Value,UC2),UC1==UC2)).
  453
  454term_upcase(Value,UC2):-catch(string_upper(Value,UC2),_,(format(string(UC1),'~w',Value),string_upper(UC1,UC2))).
  455/*
  456:-
  457 source_location(S,_), prolog_load_context(module,LC),
  458 forall(source_file(M:H,S),
  459 (functor(H,F,A),
  460  ignore(((\+ predicate_property(M:H,transparent), module_transparent(M:F/A), 
  461  \+ atom_concat('__aux',_,F),debug(modules,'~N:- module_transparent((~q)/~q).~n',[F,A])))),
  462    ignore(((\+ atom_concat('$',_,F),\+ atom_concat('__aux',_,F),LC:export(M:F/A), 
  463  (current_predicate('system':F/A)->true; 'system':import(M:F/A))))))).
  464*/
  465
  466:- fixup_exports.