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).

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

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

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

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

 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.

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

 current_chr_constraint(:Constraint) is nondet

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

  220current_chr_constraint(Mod:Constraint) :-
  221	'chr module'(Mod),
  222	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.

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

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

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

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

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

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

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