1/*  Part of CHR (Constraint Handling Rules)
    2
    3    Author:        Christian Holzbaur and Tom Schrijvers
    4    E-mail:        christian@ai.univie.ac.at
    5                   Tom.Schrijvers@cs.kuleuven.be
    6    WWW:           http://www.swi-prolog.org
    7    Copyright (c)  2004-2015, K.U. Leuven
    8    All rights reserved.
    9
   10    Redistribution and use in source and binary forms, with or without
   11    modification, are permitted provided that the following conditions
   12    are met:
   13
   14    1. Redistributions of source code must retain the above copyright
   15       notice, this list of conditions and the following disclaimer.
   16
   17    2. Redistributions in binary form must reproduce the above copyright
   18       notice, this list of conditions and the following disclaimer in
   19       the documentation and/or other materials provided with the
   20       distribution.
   21
   22    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
   23    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
   24    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
   25    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
   26    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
   27    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
   28    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
   29    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   30    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
   31    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
   32    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
   33    POSSIBILITY OF SUCH DAMAGE.
   34*/
   35
   36%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   37%%       _                             _   _
   38%%   ___| |__  _ __   _ __ _   _ _ __ | |_(_)_ __ ___   ___
   39%%  / __| '_ \| '__| | '__| | | | '_ \| __| | '_ ` _ \ / _ \
   40%% | (__| | | | |    | |  | |_| | | | | |_| | | | | | |  __/
   41%%  \___|_| |_|_|    |_|   \__,_|_| |_|\__|_|_| |_| |_|\___|
   42%%
   43%% hProlog CHR runtime:
   44%%
   45%%	* based on the SICStus CHR runtime by Christian Holzbaur
   46%%
   47%%          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   48%%          %  Constraint Handling Rules		      version 2.2 %
   49%%          %								  %
   50%%          %  (c) Copyright 1996-98					  %
   51%%          %  LMU, Muenchen						  %
   52%%	    %								  %
   53%%          %  File:   chr.pl						  %
   54%%          %  Author: Christian Holzbaur	christian@ai.univie.ac.at %
   55%%          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   56%%
   57%%
   58%%	* modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.be
   59%%		- ported to hProlog
   60%%		- modified for eager suspension removal
   61%%
   62%%      * First working version: 6 June 2003
   63%%
   64%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   65%% SWI-Prolog changes
   66%%
   67%%	* Added initialization directives for saved-states
   68%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
   69
   70:- module(chr_runtime,
   71	  [ 'chr sbag_del_element'/3,
   72	    'chr merge_attributes'/3,
   73
   74	    'chr run_suspensions'/1,
   75	    'chr run_suspensions_loop'/1,
   76
   77	    'chr run_suspensions_d'/1,
   78	    'chr run_suspensions_loop_d'/1,
   79
   80	    'chr insert_constraint_internal'/5,
   81	    'chr remove_constraint_internal'/2,
   82	    'chr allocate_constraint'/4,
   83	    'chr activate_constraint'/3,
   84
   85	    'chr default_store'/1,
   86
   87	    'chr via_1'/2,
   88	    'chr via_2'/3,
   89	    'chr via'/2,
   90	    'chr newvia_1'/2,
   91	    'chr newvia_2'/3,
   92	    'chr newvia'/2,
   93
   94	    'chr lock'/1,
   95	    'chr unlock'/1,
   96	    'chr not_locked'/1,
   97	    'chr none_locked'/1,
   98
   99	    'chr error_lock'/1,
  100	    'chr unerror_lock'/1,
  101	    'chr not_error_locked'/1,
  102	    'chr none_error_locked'/1,
  103
  104	    'chr update_mutable'/2,
  105	    'chr get_mutable'/2,
  106	    'chr create_mutable'/2,
  107
  108	    'chr novel_production'/2,
  109	    'chr extend_history'/2,
  110	    'chr empty_history'/1,
  111
  112	    'chr gen_id'/1,
  113
  114	    'chr debugging'/0,
  115	    'chr debug_event'/1,
  116	    'chr debug command'/2,	% Char, Command
  117
  118	    'chr chr_indexed_variables'/2,
  119
  120	    'chr all_suspensions'/3,
  121	    'chr new_merge_attributes'/3,
  122	    'chr normalize_attr'/2,
  123
  124	    'chr select'/3,
  125
  126	    'chr module'/1,		% ?Module
  127
  128	    chr_show_store/1,		% +Module
  129	    find_chr_constraint/1,	% -Constraint
  130	    current_chr_constraint/1,	% :Constraint
  131
  132	    chr_trace/0,
  133	    chr_notrace/0,
  134	    chr_leash/1
  135	  ]).

  138:- set_prolog_flag(generate_debug_info, false).  139:- use_module(library(modules), [current_temporary_module/1]).

  142:- meta_predicate
  143	current_chr_constraint(:).  144
  145%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  146
  147:- use_module(library(dialect/hprolog)).  148:- include(chr_op).

  156%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  157
  158%   I N I T I A L I S A T I O N

  161:- dynamic user:exception/3.  162:- multifile user:exception/3.  163
  164user:exception(undefined_global_variable, Name, retry) :-
  165	chr_runtime_global_variable(Name),
  166	chr_init.
  167
  168chr_runtime_global_variable(chr_id).
  169chr_runtime_global_variable(chr_global).
  170chr_runtime_global_variable(chr_debug).
  171chr_runtime_global_variable(chr_debug_history).
  172
  173chr_init :-
  174	nb_setval(chr_id,0),
  175	nb_setval(chr_global,_),
  176	nb_setval(chr_debug,mutable(off)),          % XXX
  177	nb_setval(chr_debug_history,mutable([],0)). % XXX
  178%% SWI end

  185:- initialization chr_init.  186
  187
  188%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  189% Contents of former chr_debug.pl
  190%
  191%	chr_show_store(+Module)
  192%
  193%	Prints all suspended constraints of module   Mod to the standard
  194%	output.
  195
  196chr_show_store(Mod) :-
  197	(
  198		Mod:'$enumerate_constraints'(Constraint),
  199		print(Constraint),nl, % allows use of portray to control printing
  200		fail
  201	;
  202		true
  203	).

 find_chr_constraint(-Constraint) is nondet

True when Constraint is a currently known constraint in any known CHR module.

deprecated

- current_chr_constraint/1 handles modules.

  212find_chr_constraint(Constraint) :-
  213	'chr module'(Mod),
  214	Mod:'$enumerate_constraints'(Constraint).

 current_chr_constraint(:Constraint) is nondet

True if Constraint is a constraint associated with the qualified module.

  221current_chr_constraint(Mod:Constraint) :-
  222	'chr module'(Mod),
  223	Mod:'$enumerate_constraints'(Constraint).

 chr module(?Module)

True when Module is a CHR module. The first clause deals with normal modules. The second with temporary modules, which are not allowed to generate clauses for chr:'$chr_module'/1.

  231'chr module'(Module) :-
  232	chr:'$chr_module'(Module).
  233:- if(current_prolog_flag(dialect, swi)).  234'chr module'(Module) :-
  235	current_temporary_module(Module),
  236	current_predicate(Module:'$chr_initialization'/0),
  237	\+ predicate_property(Module:'$chr_initialization', imported_from(_)).
  238:- endif.  239
  240%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  241% Inlining of some goals is good for performance
  242% That's the reason for the next section
  243% There must be correspondence with the predicates as implemented in chr_mutable.pl
  244% so that       user:goal_expansion(G,G). also works (but do not add such a rule)
  245%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  248:- multifile user:goal_expansion/2.  249:- dynamic   user:goal_expansion/2.  250
  251user:goal_expansion('chr get_mutable'(Val,Var),    Var=mutable(Val)).
  252user:goal_expansion('chr update_mutable'(Val,Var), setarg(1,Var,Val)).
  253user:goal_expansion('chr create_mutable'(Val,Var), Var=mutable(Val)).
  254user:goal_expansion('chr default_store'(X),        nb_getval(chr_global,X)).

  257% goal_expansion seems too different in SICStus 4 for me to cater for in a
  258% decent way at this moment - so I stick with the old way to do this
  259% so that it doesn't get lost, the code from Mats for SICStus 4 is included in comments

  281%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  282'chr run_suspensions'( Slots) :-
  283	    run_suspensions( Slots).
  284
  285'chr run_suspensions_loop'([]).
  286'chr run_suspensions_loop'([L|Ls]) :-
  287	run_suspensions(L),
  288	'chr run_suspensions_loop'(Ls).
  289
  290run_suspensions([]).
  291run_suspensions([S|Next] ) :-
  292	arg( 2, S, Mref), % ARGXXX
  293	'chr get_mutable'( Status, Mref),
  294	( Status==active ->
  295	    'chr update_mutable'( triggered, Mref),
  296	    arg( 4, S, Gref), % ARGXXX
  297	    'chr get_mutable'( Gen, Gref),
  298	    Generation is Gen+1,
  299	    'chr update_mutable'( Generation, Gref),
  300	    arg( 3, S, Goal), % ARGXXX
  301	    call( Goal),
  302	    'chr get_mutable'( Post, Mref),
  303	    ( Post==triggered ->
  304		'chr update_mutable'( active, Mref)	% catching constraints that did not do anything
  305	    ;
  306		true
  307	    )
  308	;
  309	    true
  310	),
  311	run_suspensions( Next).
  312
  313'chr run_suspensions_d'( Slots) :-
  314	    run_suspensions_d( Slots).
  315
  316'chr run_suspensions_loop_d'([]).
  317'chr run_suspensions_loop_d'([L|Ls]) :-
  318	run_suspensions_d(L),
  319	'chr run_suspensions_loop_d'(Ls).
  320
  321run_suspensions_d([]).
  322run_suspensions_d([S|Next] ) :-
  323	arg( 2, S, Mref), % ARGXXX
  324	'chr get_mutable'( Status, Mref),
  325	( Status==active ->
  326	    'chr update_mutable'( triggered, Mref),
  327	    arg( 4, S, Gref), % ARGXXX
  328	    'chr get_mutable'( Gen, Gref),
  329	    Generation is Gen+1,
  330	    'chr update_mutable'( Generation, Gref),
  331	    arg( 3, S, Goal), % ARGXXX
  332	    (
  333		'chr debug_event'(wake(S)),
  334	        call( Goal)
  335	    ;
  336		'chr debug_event'(fail(S)), !,
  337		fail
  338	    ),
  339	    (
  340		'chr debug_event'(exit(S))
  341	    ;
  342		'chr debug_event'(redo(S)),
  343		fail
  344	    ),
  345	    'chr get_mutable'( Post, Mref),
  346	    ( Post==triggered ->
  347		'chr update_mutable'( active, Mref)   % catching constraints that did not do anything
  348	    ;
  349		true
  350	    )
  351	;
  352	    true
  353	),
  354	run_suspensions_d( Next).
  355%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  356% L O C K I N G
  357%
  358%	locking of variables in guards
  359
  360%= IMPLEMENTATION 1: SILENT FAILURE ============================================
  361
  362%- attribute handler -----------------------------------------------------------
  363%	intercepts unification of locked variable unification
  364
  365:- public locked:attr_unify_hook/2.  366locked:attr_unify_hook(_,_) :- fail.
  367
  368%- locking & unlocking ---------------------------------------------------------
  369'chr lock'(T) :-
  370	( var(T)
  371	-> put_attr(T, locked, x)
  372        ;  term_variables(T,L),
  373           lockv(L)
  374	).
  375
  376lockv([]).
  377lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
  378
  379'chr unlock'(T) :-
  380	( var(T)
  381	-> del_attr(T, locked)
  382	;  term_variables(T,L),
  383           unlockv(L)
  384	).
  385
  386unlockv([]).
  387unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
  388
  389%- checking for locks ----------------------------------------------------------
  390
  391'chr none_locked'( []).
  392'chr none_locked'( [V|Vs]) :-
  393	( get_attr(V, locked, _) ->
  394		fail
  395	;
  396		'chr none_locked'(Vs)
  397	).
  398
  399'chr not_locked'(V) :-
  400	( var( V) ->
  401		( get_attr( V, locked, _) ->
  402			fail
  403		;
  404			true
  405		)
  406	;
  407		true
  408	).
  409
  410%= IMPLEMENTATION 2: EXPLICT EXCEPTION =========================================
  411
  412%- LOCK ERROR MESSAGE ----------------------------------------------------------
  413lock_error(Term) :-
  414	throw(error(instantation_error(Term),context(_,'CHR Runtime Error: unification in guard not allowed!'))).
  415
  416%- attribute handler -----------------------------------------------------------
  417%	intercepts unification of locked variable unification
  418
  419error_locked:attr_unify_hook(_,Term) :- lock_error(Term).
  420
  421%- locking & unlocking ---------------------------------------------------------
  422'chr error_lock'(T) :-
  423	( var(T)
  424	-> put_attr(T, error_locked, x)
  425        ;  term_variables(T,L),
  426           error_lockv(L)
  427	).
  428
  429error_lockv([]).
  430error_lockv([T|R]) :- put_attr( T, error_locked, x), error_lockv(R).
  431
  432'chr unerror_lock'(T) :-
  433	( var(T)
  434	-> del_attr(T, error_locked)
  435	;  term_variables(T,L),
  436           unerror_lockv(L)
  437	).
  438
  439unerror_lockv([]).
  440unerror_lockv([T|R]) :- del_attr( T, error_locked), unerror_lockv(R).
  441
  442%- checking for locks ----------------------------------------------------------
  443
  444'chr none_error_locked'( []).
  445'chr none_error_locked'( [V|Vs]) :-
  446	( get_attr(V, error_locked, _) ->
  447		fail
  448	;
  449		'chr none_error_locked'(Vs)
  450	).
  451
  452'chr not_error_locked'(V) :-
  453	( var( V) ->
  454		( get_attr( V, error_locked, _) ->
  455			fail
  456		;
  457			true
  458		)
  459	;
  460		true
  461	).
  462
  463%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  464%
  465% Eager removal from all chains.
  466%
  467'chr remove_constraint_internal'( Susp, Agenda) :-
  468	arg( 2, Susp, Mref), % ARGXXX
  469	'chr get_mutable'( State, Mref),
  470	'chr update_mutable'( removed, Mref),		% mark in any case
  471	( compound(State) ->			% passive/1
  472	    Agenda = []
  473	; State==removed ->
  474	    Agenda = []
  475	%; State==triggered ->
  476	%     Agenda = []
  477	;
  478            Susp =.. [_,_,_,_,_,_,_|Args],
  479	    term_variables( Args, Vars),
  480	    'chr default_store'( Global),
  481	    Agenda = [Global|Vars]
  482	).
  483
  484%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  485'chr newvia_1'(X,V) :-
  486	( var(X) ->
  487		X = V
  488	;
  489		nonground(X,V)
  490	).
  491
  492'chr newvia_2'(X,Y,V) :-
  493	( var(X) ->
  494		X = V
  495	; var(Y) ->
  496		Y = V
  497	; compound(X), nonground(X,V) ->
  498		true
  499	;
  500		compound(Y), nonground(Y,V)
  501	).
  502
  503%
  504% The second arg is a witness.
  505% The formulation with term_variables/2 is
  506% cycle safe, but it finds a list of all vars.
  507% We need only one, and no list in particular.
  508%
  509'chr newvia'(L,V) :- nonground(L,V).
  510%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
  511
  512'chr via_1'(X,V) :-
  513	( var(X) ->
  514		X = V
  515	; atomic(X) ->
  516		'chr default_store'(V)
  517	; nonground(X,V) ->
  518		true
  519	;
  520		'chr default_store'(V)
  521	).
  522
  523'chr via_2'(X,Y,V) :-
  524	( var(X) ->
  525		X = V
  526	; var(Y) ->
  527		Y = V
  528	; compound(X), nonground(X,V) ->
  529		true
  530	; compound(Y), nonground(Y,V) ->
  531		true
  532	;
  533		'chr default_store'(V)
  534	).
  535
  536%
  537% The second arg is a witness.
  538% The formulation with term_variables/2 is
  539% cycle safe, but it finds a list of all vars.
  540% We need only one, and no list in particular.
  541%
  542'chr via'(L,V) :-
  543	( nonground(L,V) ->
  544		true
  545	;
  546		'chr default_store'(V)
  547	).
  548
  549:- if(\+current_predicate(nonground/2)).  550nonground( Term, V) :-
  551	term_variables( Term, Vs),
  552	Vs = [V|_].
  553:- endif.  554
  555%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  556'chr novel_production'( Self, Tuple) :-
  557	arg( 5, Self, Ref), % ARGXXX
  558	'chr get_mutable'( History, Ref),
  559	( get_ds( Tuple, History, _) ->
  560	    fail
  561	;
  562	    true
  563	).
  564
  565%
  566% Not folded with novel_production/2 because guard checking
  567% goes in between the two calls.
  568%
  569'chr extend_history'( Self, Tuple) :-
  570	arg( 5, Self, Ref), % ARGXXX
  571	'chr get_mutable'( History, Ref),
  572	put_ds( Tuple, History, x, NewHistory),
  573	'chr update_mutable'( NewHistory, Ref).
  574
  575%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  576'chr allocate_constraint'( Closure, Self, F, Args) :-
  577	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
  578	'chr create_mutable'(0, Gref),
  579	'chr empty_history'(History),
  580	'chr create_mutable'(History, Href),
  581	'chr create_mutable'(passive(Args), Mref),
  582	'chr gen_id'( Id).
  583
  584%
  585% 'chr activate_constraint'( -, +, -).
  586%
  587% The transition gc->active should be rare
  588%
  589'chr activate_constraint'( Vars, Susp, Generation) :-
  590	arg( 2, Susp, Mref), % ARGXXX
  591	'chr get_mutable'( State, Mref),
  592	'chr update_mutable'( active, Mref),
  593	( nonvar(Generation) ->			% aih
  594	    true
  595	;
  596	    arg( 4, Susp, Gref), % ARGXXX
  597	    'chr get_mutable'( Gen, Gref),
  598	    Generation is Gen+1,
  599	    'chr update_mutable'( Generation, Gref)
  600	),
  601	( compound(State) ->			% passive/1
  602	    term_variables( State, Vs),
  603	    'chr none_locked'( Vs),
  604	    Vars = [Global|Vs],
  605	    'chr default_store'(Global)
  606	; State == removed ->			% the price for eager removal ...
  607	    Susp =.. [_,_,_,_,_,_,_|Args],
  608	    term_variables( Args, Vs),
  609	    Vars = [Global|Vs],
  610	    'chr default_store'(Global)
  611	;
  612	    Vars = []
  613	).
  614
  615'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :-
  616	'chr default_store'(Global),
  617	term_variables(Args,Vars),
  618	'chr none_locked'(Vars),
  619	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
  620	'chr create_mutable'(active, Mref),
  621	'chr create_mutable'(0, Gref),
  622	'chr empty_history'(History),
  623	'chr create_mutable'(History, Href),
  624	'chr gen_id'(Id).
  625
  626insert_constraint_internal([Global|Vars], Self, Term, Closure, F, Args) :-
  627	'chr default_store'(Global),
  628	term_variables( Term, Vars),
  629	'chr none_locked'( Vars),
  630	'chr empty_history'( History),
  631	'chr create_mutable'( active, Mref),
  632	'chr create_mutable'( 0, Gref),
  633	'chr create_mutable'( History, Href),
  634	'chr gen_id'( Id),
  635	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args]. % SUSPXXX
  636
  637%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  638'chr empty_history'( E) :- empty_ds( E).
  639
  640%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  641'chr gen_id'( Id) :-
  642	nb_getval(chr_id,Id),
  643	NextId is Id + 1,
  644	nb_setval(chr_id,NextId).
  645
  646%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

  649'chr create_mutable'(V,mutable(V)).
  650'chr get_mutable'(V,mutable(V)).
  651'chr update_mutable'(V,M) :- setarg(1,M,V).

  661%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  662%% SWI begin
  663'chr default_store'(X) :- nb_getval(chr_global,X).

  670%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  671
  672'chr sbag_del_element'( [],	  _,	[]).
  673'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
  674	( X==Elem ->
  675	    Set2 = Xs
  676	;
  677	    Set2 = [X|Xss],
  678	    'chr sbag_del_element'( Xs, Elem, Xss)
  679	).
  680
  681%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  682'chr merge_attributes'([],Ys,Ys).
  683'chr merge_attributes'([X | Xs],YL,R) :-
  684  ( YL = [Y | Ys] ->
  685      arg(1,X,XId), % ARGXXX
  686      arg(1,Y,YId),	 % ARGXXX
  687       ( XId < YId ->
  688           R = [X | T],
  689           'chr merge_attributes'(Xs,YL,T)
  690       ; XId > YId ->
  691           R = [Y | T],
  692           'chr merge_attributes'([X|Xs],Ys,T)
  693       ;
  694           R = [X | T],
  695           'chr merge_attributes'(Xs,Ys,T)
  696       )
  697  ;
  698       R = [X | Xs]
  699  ).
  700
  701'chr new_merge_attributes'([],A2,A) :-
  702	A = A2.
  703'chr new_merge_attributes'([E1|AT1],A2,A) :-
  704	( A2 = [E2|AT2] ->
  705		'chr new_merge_attributes'(E1,E2,AT1,AT2,A)
  706	;
  707		A = [E1|AT1]
  708	).
  709
  710'chr new_merge_attributes'(Pos1-L1,Pos2-L2,AT1,AT2,A) :-
  711	( Pos1 < Pos2 ->
  712		A = [Pos1-L1|AT],
  713		'chr new_merge_attributes'(AT1,[Pos2-L2|AT2],AT)
  714	; Pos1 > Pos2 ->
  715		A = [Pos2-L2|AT],
  716		'chr new_merge_attributes'([Pos1-L1|AT1],AT2,AT)
  717	;
  718		'chr merge_attributes'(L1,L2,L),
  719		A = [Pos1-L|AT],
  720		'chr new_merge_attributes'(AT1,AT2,AT)
  721	).
  722
  723'chr all_suspensions'([],_,_).
  724'chr all_suspensions'([Susps|SuspsList],Pos,Attr) :-
  725	all_suspensions(Attr,Susps,SuspsList,Pos).
  726
  727all_suspensions([],[],SuspsList,Pos) :-
  728	all_suspensions([],[],SuspsList,Pos). % all empty lists
  729all_suspensions([APos-ASusps|RAttr],Susps,SuspsList,Pos) :-
  730	NPos is Pos + 1,
  731	( Pos == APos ->
  732		Susps = ASusps,
  733		'chr all_suspensions'(SuspsList,NPos,RAttr)
  734	;
  735		Susps = [],
  736		'chr all_suspensions'(SuspsList,NPos,[APos-ASusps|RAttr])
  737	).
  738
  739'chr normalize_attr'([],[]).
  740'chr normalize_attr'([Pos-L|R],[Pos-NL|NR]) :-
  741	sort(L,NL),
  742	'chr normalize_attr'(R,NR).
  743
  744'chr select'([E|T],F,R) :-
  745	( E = F ->
  746		R = T
  747	;
  748		R = [E|NR],
  749		'chr select'(T,F,NR)
  750	).
  751
  752%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  753
  754:- multifile
  755	chr:debug_event/2,		% +State, +Event
  756	chr:debug_interact/3.		% +Event, +Depth, -Command
  757
  758'chr debugging' :-
  759	nb_getval(chr_debug,mutable(trace)).
  760
  761'chr debug_event'(Event) :-
  762	(   nb_getval(chr_debug,mutable(State)),
  763	    State \== off
  764	->  (   chr:debug_event(State, Event)
  765	    ->  true
  766	    ;	debug_event(State,Event)
  767	    )
  768	;   true
  769	).
  770
  771chr_trace :-
  772	nb_setval(chr_debug,mutable(trace)).
  773chr_notrace :-
  774	nb_setval(chr_debug,mutable(off)).
  775
  776%	chr_leash(+Spec)
  777%
  778%	Define the set of ports at which we prompt for user interaction
  779
  780chr_leash(Spec) :-
  781	leashed_ports(Spec, Ports),
  782	nb_setval(chr_leash,mutable(Ports)).
  783
  784leashed_ports(none, []).
  785leashed_ports(off,  []).
  786leashed_ports(all,  [call, exit, redo, fail, wake, try, apply, insert, remove]).
  787leashed_ports(default, [call,exit,fail,wake,apply]).
  788leashed_ports(One, Ports) :-
  789	atom(One), One \== [], !,
  790	leashed_ports([One], Ports).
  791leashed_ports(Set, Ports) :-
  792	sort(Set, Ports),		% make unique
  793	leashed_ports(all, All),
  794	valid_ports(Ports, All).
  795
  796valid_ports([], _).
  797valid_ports([H|T], Valid) :-
  798	(   memberchk(H, Valid)
  799	->  true
  800	;   throw(error(domain_error(chr_port, H), _))
  801	),
  802	valid_ports(T, Valid).
  803
  804user:exception(undefined_global_variable, Name, retry) :-
  805	chr_runtime_debug_global_variable(Name),
  806	chr_debug_init.
  807
  808chr_runtime_debug_global_variable(chr_leash).
  809
  810chr_debug_init :-
  811   leashed_ports(default, Ports),
  812   nb_setval(chr_leash, mutable(Ports)).
  813
  814:- initialization chr_debug_init.  815
  816%	debug_event(+State, +Event)
  817
  818
  819%debug_event(trace, Event) :-
  820%	functor(Event, Name, Arity),
  821%	writeln(Name/Arity), fail.
  822debug_event(trace,Event) :-
  823	Event = call(_), !,
  824	get_debug_history(History,Depth),
  825	NDepth is Depth + 1,
  826	chr_debug_interact(Event,NDepth),
  827	set_debug_history([Event|History],NDepth).
  828debug_event(trace,Event) :-
  829	Event = wake(_), !,
  830	get_debug_history(History,Depth),
  831	NDepth is Depth + 1,
  832	chr_debug_interact(Event,NDepth),
  833	set_debug_history([Event|History],NDepth).
  834debug_event(trace,Event) :-
  835	Event = redo(_), !,
  836	get_debug_history(_History, Depth),
  837	chr_debug_interact(Event, Depth).
  838debug_event(trace,Event) :-
  839	Event = exit(_),!,
  840	get_debug_history([_|History],Depth),
  841	chr_debug_interact(Event,Depth),
  842	NDepth is Depth - 1,
  843	set_debug_history(History,NDepth).
  844debug_event(trace,Event) :-
  845	Event = fail(_),!,
  846	get_debug_history(_,Depth),
  847	chr_debug_interact(Event,Depth).
  848debug_event(trace, Event) :-
  849	Event = remove(_), !,
  850	get_debug_history(_,Depth),
  851	chr_debug_interact(Event, Depth).
  852debug_event(trace, Event) :-
  853	Event = insert(_), !,
  854	get_debug_history(_,Depth),
  855	chr_debug_interact(Event, Depth).
  856debug_event(trace, Event) :-
  857	Event = try(_,_,_,_), !,
  858	get_debug_history(_,Depth),
  859	chr_debug_interact(Event, Depth).
  860debug_event(trace, Event) :-
  861	Event = apply(_,_,_,_), !,
  862	get_debug_history(_,Depth),
  863	chr_debug_interact(Event,Depth).
  864
  865debug_event(skip(_,_),Event) :-
  866	Event = call(_), !,
  867	get_debug_history(History,Depth),
  868	NDepth is Depth + 1,
  869	set_debug_history([Event|History],NDepth).
  870debug_event(skip(_,_),Event) :-
  871	Event = wake(_), !,
  872	get_debug_history(History,Depth),
  873	NDepth is Depth + 1,
  874	set_debug_history([Event|History],NDepth).
  875debug_event(skip(SkipSusp,SkipDepth),Event) :-
  876	Event = exit(Susp),!,
  877	get_debug_history([_|History],Depth),
  878	( SkipDepth == Depth,
  879	  SkipSusp == Susp ->
  880		set_chr_debug(trace),
  881		chr_debug_interact(Event,Depth)
  882	;
  883		true
  884	),
  885	NDepth is Depth - 1,
  886	set_debug_history(History,NDepth).
  887debug_event(skip(_,_),_) :- !,
  888	true.
  889
  890%	chr_debug_interact(+Event, +Depth)
  891%
  892%	Interact with the user on Event that took place at Depth.  First
  893%	calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
  894%	fails the event is printed and the system prompts for a command.
  895
  896chr_debug_interact(Event, Depth) :-
  897	chr:debug_interact(Event, Depth, Command), !,
  898	handle_debug_command(Command,Event,Depth).
  899chr_debug_interact(Event, Depth) :-
  900	print_event(Event, Depth),
  901	(   leashed(Event)
  902	->  ask_continue(Command)
  903	;   Command = creep
  904	),
  905	handle_debug_command(Command,Event,Depth).
  906
  907leashed(Event) :-
  908	functor(Event, Port, _),
  909	nb_getval(chr_leash, mutable(Ports)),
  910	memberchk(Port, Ports).
  911
  912:- multifile
  913	chr:debug_ask_continue/1.  914
  915ask_continue(Command) :-
  916	chr:debug_ask_continue(Command), !.
  917ask_continue(Command) :-
  918	print_message(trace, chr(prompt)),
  919	get_single_char(CharCode),
  920	(   CharCode == -1
  921	->  Char = end_of_file
  922	;   char_code(Char, CharCode)
  923	),
  924	(   debug_command(Char, Command)
  925	->  print_message(trace, chr(command(Command)))
  926	;   print_message(help, chr(invalid_command)),
  927	    ask_continue(Command)
  928	).
  929
  930
  931'chr debug command'(Char, Command) :-
  932	debug_command(Char, Command).
  933
  934debug_command(c, creep).
  935debug_command(' ', creep).
  936debug_command('\r', creep).
  937debug_command(s, skip).
  938debug_command(g, ancestors).
  939debug_command(n, nodebug).
  940debug_command(a, abort).
  941debug_command(f, fail).
  942debug_command(b, break).
  943debug_command(?, help).
  944debug_command(h, help).
  945debug_command(end_of_file, exit).
  946
  947
  948handle_debug_command(creep,_,_) :- !.
  949handle_debug_command(skip, Event, Depth) :- !,
  950	Event =.. [Type|Rest],
  951	( Type \== call,
  952	  Type \== wake ->
  953		handle_debug_command(creep,Event,Depth)
  954	;
  955		Rest = [Susp],
  956		set_chr_debug(skip(Susp,Depth))
  957	).
  958handle_debug_command(ancestors,Event,Depth) :- !,
  959	print_chr_debug_history,
  960	chr_debug_interact(Event,Depth).
  961handle_debug_command(nodebug,_,_) :- !,
  962	chr_notrace.
  963handle_debug_command(abort,_,_) :- !,
  964	abort.
  965handle_debug_command(exit,_,_) :- !,
  966	(   thread_self(main)		% Only allow terminating from the
  967	->  halt			% main thread
  968	;   permission_error(access, chr_debug, halt)
  969	).
  970handle_debug_command(fail,_,_) :- !,
  971	fail.
  972handle_debug_command(break,Event,Depth) :- !,
  973	break,
  974	chr_debug_interact(Event,Depth).
  975handle_debug_command(help,Event,Depth) :- !,
  976	print_message(help, chr(debug_options)),
  977	chr_debug_interact(Event,Depth).
  978handle_debug_command(Cmd, _, _) :-
  979	throw(error(domain_error(chr_debug_command, Cmd), _)).
  980
  981print_chr_debug_history :-
  982	get_debug_history(History,Depth),
  983	print_message(trace, chr(ancestors(History, Depth))).
  984
  985print_event(Event, Depth) :-
  986	print_message(trace, chr(event(Event, Depth))).
  987
  988%	{set,get}_debug_history(Ancestors, Depth)
  989%
  990%	Set/get the list of ancestors and the depth of the current goal.
  991
  992get_debug_history(History,Depth) :-
  993	nb_getval(chr_debug_history,mutable(History,Depth)).
  994
  995set_debug_history(History,Depth) :-
  996	nb_getval(chr_debug_history,Mutable),
  997	setarg(1,Mutable,History),
  998	setarg(2,Mutable,Depth).
  999
 1000set_chr_debug(State) :-
 1001	nb_getval(chr_debug,Mutable),
 1002	setarg(1,Mutable,State).
 1003
 1004'chr chr_indexed_variables'(Susp,Vars) :-
 1005        Susp =.. [_,_,_,_,_,_,_|Args],
 1006	term_variables(Args,Vars).
 1007
 1008
 1009		 /*******************************
 1010		 *	      SANDBOX		*
 1011		 *******************************/
 1012:- multifile
 1013	sandbox:safe_primitive/1. 1014
 1015sandbox:safe_primitive(chr_runtime:handle_debug_command(_,_,_)).
 1016sandbox:safe_primitive(chr_runtime:ask_continue(_))