kibi-swipl-linux-x64-gnu 1.0.0

package/lib/swipl/library/ext/chr/chr/chr_runtime.pl

@@ -0,0 +1,1016 @@
+/*  Part of CHR (Constraint Handling Rules)
+
+    Author:        Christian Holzbaur and Tom Schrijvers
+    E-mail:        christian@ai.univie.ac.at
+                   Tom.Schrijvers@cs.kuleuven.be
+    WWW:           http://www.swi-prolog.org
+    Copyright (c)  2004-2015, K.U. Leuven
+    All rights reserved.
+
+    Redistribution and use in source and binary forms, with or without
+    modification, are permitted provided that the following conditions
+    are met:
+
+    1. Redistributions of source code must retain the above copyright
+       notice, this list of conditions and the following disclaimer.
+
+    2. Redistributions in binary form must reproduce the above copyright
+       notice, this list of conditions and the following disclaimer in
+       the documentation and/or other materials provided with the
+       distribution.
+
+    THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+    "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+    LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+    FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+    COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+    INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+    BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
+    LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+    CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+    LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
+    ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+    POSSIBILITY OF SUCH DAMAGE.
+*/
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%       _                             _   _
+%%   ___| |__  _ __   _ __ _   _ _ __ | |_(_)_ __ ___   ___
+%%  / __| '_ \| '__| | '__| | | | '_ \| __| | '_ ` _ \ / _ \
+%% | (__| | | | |    | |  | |_| | | | | |_| | | | | | |  __/
+%%  \___|_| |_|_|    |_|   \__,_|_| |_|\__|_|_| |_| |_|\___|
+%%
+%% hProlog CHR runtime:
+%%
+%%	* based on the SICStus CHR runtime by Christian Holzbaur
+%%
+%%          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%          %  Constraint Handling Rules		      version 2.2 %
+%%          %								  %
+%%          %  (c) Copyright 1996-98					  %
+%%          %  LMU, Muenchen						  %
+%%	    %								  %
+%%          %  File:   chr.pl						  %
+%%          %  Author: Christian Holzbaur	christian@ai.univie.ac.at %
+%%          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%
+%%
+%%	* modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.be
+%%		- ported to hProlog
+%%		- modified for eager suspension removal
+%%
+%%      * First working version: 6 June 2003
+%%
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% SWI-Prolog changes
+%%
+%%	* Added initialization directives for saved-states
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+:- module(chr_runtime,
+	  [ 'chr sbag_del_element'/3,
+	    'chr merge_attributes'/3,
+
+	    'chr run_suspensions'/1,
+	    'chr run_suspensions_loop'/1,
+
+	    'chr run_suspensions_d'/1,
+	    'chr run_suspensions_loop_d'/1,
+
+	    'chr insert_constraint_internal'/5,
+	    'chr remove_constraint_internal'/2,
+	    'chr allocate_constraint'/4,
+	    'chr activate_constraint'/3,
+
+	    'chr default_store'/1,
+
+	    'chr via_1'/2,
+	    'chr via_2'/3,
+	    'chr via'/2,
+	    'chr newvia_1'/2,
+	    'chr newvia_2'/3,
+	    'chr newvia'/2,
+
+	    'chr lock'/1,
+	    'chr unlock'/1,
+	    'chr not_locked'/1,
+	    'chr none_locked'/1,
+
+	    'chr error_lock'/1,
+	    'chr unerror_lock'/1,
+	    'chr not_error_locked'/1,
+	    'chr none_error_locked'/1,
+
+	    'chr update_mutable'/2,
+	    'chr get_mutable'/2,
+	    'chr create_mutable'/2,
+
+	    'chr novel_production'/2,
+	    'chr extend_history'/2,
+	    'chr empty_history'/1,
+
+	    'chr gen_id'/1,
+
+	    'chr debugging'/0,
+	    'chr debug_event'/1,
+	    'chr debug command'/2,	% Char, Command
+
+	    'chr chr_indexed_variables'/2,
+
+	    'chr all_suspensions'/3,
+	    'chr new_merge_attributes'/3,
+	    'chr normalize_attr'/2,
+
+	    'chr select'/3,
+
+	    'chr module'/1,		% ?Module
+
+	    chr_show_store/1,		% +Module
+	    find_chr_constraint/1,	% -Constraint
+	    current_chr_constraint/1,	% :Constraint
+
+	    chr_trace/0,
+	    chr_notrace/0,
+	    chr_leash/1
+	  ]).
+
+%% SWI begin
+:- set_prolog_flag(generate_debug_info, false).
+:- use_module(library(modules), [current_temporary_module/1]).
+%% SWI end
+
+:- meta_predicate
+	current_chr_constraint(:).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+:- use_module(library(dialect/hprolog)).
+:- include(chr_op).
+
+%% SICStus begin
+%% :- use_module(hpattvars).
+%% :- use_module(b_globval).
+%% SICStus end
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%   I N I T I A L I S A T I O N
+
+%% SWI begin
+:- dynamic user:exception/3.
+:- multifile user:exception/3.
+
+user:exception(undefined_global_variable, Name, retry) :-
+	chr_runtime_global_variable(Name),
+	chr_init.
+
+chr_runtime_global_variable(chr_id).
+chr_runtime_global_variable(chr_global).
+chr_runtime_global_variable(chr_debug).
+chr_runtime_global_variable(chr_debug_history).
+
+chr_init :-
+	nb_setval(chr_id,0),
+	nb_setval(chr_global,_),
+	nb_setval(chr_debug,mutable(off)),          % XXX
+	nb_setval(chr_debug_history,mutable([],0)). % XXX
+%% SWI end
+
+%% SICStus begin
+%% chr_init :-
+%%	        nb_setval(chr_id,0).
+%% SICStus end
+
+:- initialization chr_init.
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Contents of former chr_debug.pl
+%
+%	chr_show_store(+Module)
+%
+%	Prints all suspended constraints of module   Mod to the standard
+%	output.
+
+chr_show_store(Mod) :-
+	(
+		Mod:'$enumerate_constraints'(Constraint),
+		print(Constraint),nl, % allows use of portray to control printing
+		fail
+	;
+		true
+	).
+
+%%	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.
+
+find_chr_constraint(Constraint) :-
+	'chr module'(Mod),
+	Mod:'$enumerate_constraints'(Constraint).
+
+%%	current_chr_constraint(:Constraint) is nondet.
+%
+%	True if Constraint is a constraint associated with the qualified
+%	module.
+
+current_chr_constraint(Mod:Constraint) :-
+	'chr module'(Mod),
+	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.
+
+'chr module'(Module) :-
+	chr:'$chr_module'(Module).
+:- if(current_prolog_flag(dialect, swi)).
+'chr module'(Module) :-
+	current_temporary_module(Module),
+	current_predicate(Module:'$chr_initialization'/0),
+	\+ predicate_property(Module:'$chr_initialization', imported_from(_)).
+:- endif.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% Inlining of some goals is good for performance
+% That's the reason for the next section
+% There must be correspondence with the predicates as implemented in chr_mutable.pl
+% so that       user:goal_expansion(G,G). also works (but do not add such a rule)
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%% SWI begin
+:- multifile user:goal_expansion/2.
+:- dynamic   user:goal_expansion/2.
+
+user:goal_expansion('chr get_mutable'(Val,Var),    Var=mutable(Val)).
+user:goal_expansion('chr update_mutable'(Val,Var), setarg(1,Var,Val)).
+user:goal_expansion('chr create_mutable'(Val,Var), Var=mutable(Val)).
+user:goal_expansion('chr default_store'(X),        nb_getval(chr_global,X)).
+%% SWI end
+
+% goal_expansion seems too different in SICStus 4 for me to cater for in a
+% decent way at this moment - so I stick with the old way to do this
+% so that it doesn't get lost, the code from Mats for SICStus 4 is included in comments
+
+
+%% Mats begin
+%% goal_expansion('chr get_mutable'(Val,Var),    Lay, _M, get_mutable(Val,Var), Lay).
+%% goal_expansion('chr update_mutable'(Val,Var), Lay, _M, update_mutable(Val,Var), Lay).
+%% goal_expansion('chr create_mutable'(Val,Var), Lay, _M, create_mutable(Val,Var), Lay).
+%% goal_expansion('chr default_store'(A),        Lay, _M, global_term_ref_1(A), Lay).
+%% Mats begin
+
+
+%% SICStus begin
+%% :- multifile user:goal_expansion/2.
+%% :- dynamic   user:goal_expansion/2.
+%%
+%% user:goal_expansion('chr get_mutable'(Val,Var),    get_mutable(Val,Var)).
+%% user:goal_expansion('chr update_mutable'(Val,Var), update_mutable(Val,Var)).
+%% user:goal_expansion('chr create_mutable'(Val,Var), create_mutable(Val,Var)).
+%% user:goal_expansion('chr default_store'(A),        global_term_ref_1(A)).
+%% SICStus end
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr run_suspensions'( Slots) :-
+	    run_suspensions( Slots).
+
+'chr run_suspensions_loop'([]).
+'chr run_suspensions_loop'([L|Ls]) :-
+	run_suspensions(L),
+	'chr run_suspensions_loop'(Ls).
+
+run_suspensions([]).
+run_suspensions([S|Next] ) :-
+	arg( 2, S, Mref), % ARGXXX
+	'chr get_mutable'( Status, Mref),
+	( Status==active ->
+	    'chr update_mutable'( triggered, Mref),
+	    arg( 4, S, Gref), % ARGXXX
+	    'chr get_mutable'( Gen, Gref),
+	    Generation is Gen+1,
+	    'chr update_mutable'( Generation, Gref),
+	    arg( 3, S, Goal), % ARGXXX
+	    call( Goal),
+	    'chr get_mutable'( Post, Mref),
+	    ( Post==triggered ->
+		'chr update_mutable'( active, Mref)	% catching constraints that did not do anything
+	    ;
+		true
+	    )
+	;
+	    true
+	),
+	run_suspensions( Next).
+
+'chr run_suspensions_d'( Slots) :-
+	    run_suspensions_d( Slots).
+
+'chr run_suspensions_loop_d'([]).
+'chr run_suspensions_loop_d'([L|Ls]) :-
+	run_suspensions_d(L),
+	'chr run_suspensions_loop_d'(Ls).
+
+run_suspensions_d([]).
+run_suspensions_d([S|Next] ) :-
+	arg( 2, S, Mref), % ARGXXX
+	'chr get_mutable'( Status, Mref),
+	( Status==active ->
+	    'chr update_mutable'( triggered, Mref),
+	    arg( 4, S, Gref), % ARGXXX
+	    'chr get_mutable'( Gen, Gref),
+	    Generation is Gen+1,
+	    'chr update_mutable'( Generation, Gref),
+	    arg( 3, S, Goal), % ARGXXX
+	    (
+		'chr debug_event'(wake(S)),
+	        call( Goal)
+	    ;
+		'chr debug_event'(fail(S)), !,
+		fail
+	    ),
+	    (
+		'chr debug_event'(exit(S))
+	    ;
+		'chr debug_event'(redo(S)),
+		fail
+	    ),
+	    'chr get_mutable'( Post, Mref),
+	    ( Post==triggered ->
+		'chr update_mutable'( active, Mref)   % catching constraints that did not do anything
+	    ;
+		true
+	    )
+	;
+	    true
+	),
+	run_suspensions_d( Next).
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+% L O C K I N G
+%
+%	locking of variables in guards
+
+%= IMPLEMENTATION 1: SILENT FAILURE ============================================
+
+%- attribute handler -----------------------------------------------------------
+%	intercepts unification of locked variable unification
+
+:- public locked:attr_unify_hook/2.
+locked:attr_unify_hook(_,_) :- fail.
+
+%- locking & unlocking ---------------------------------------------------------
+'chr lock'(T) :-
+	( var(T)
+	-> put_attr(T, locked, x)
+        ;  term_variables(T,L),
+           lockv(L)
+	).
+
+lockv([]).
+lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
+
+'chr unlock'(T) :-
+	( var(T)
+	-> del_attr(T, locked)
+	;  term_variables(T,L),
+           unlockv(L)
+	).
+
+unlockv([]).
+unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
+
+%- checking for locks ----------------------------------------------------------
+
+'chr none_locked'( []).
+'chr none_locked'( [V|Vs]) :-
+	( get_attr(V, locked, _) ->
+		fail
+	;
+		'chr none_locked'(Vs)
+	).
+
+'chr not_locked'(V) :-
+	( var( V) ->
+		( get_attr( V, locked, _) ->
+			fail
+		;
+			true
+		)
+	;
+		true
+	).
+
+%= IMPLEMENTATION 2: EXPLICT EXCEPTION =========================================
+
+%- LOCK ERROR MESSAGE ----------------------------------------------------------
+lock_error(Term) :-
+	throw(error(instantation_error(Term),context(_,'CHR Runtime Error: unification in guard not allowed!'))).
+
+%- attribute handler -----------------------------------------------------------
+%	intercepts unification of locked variable unification
+
+error_locked:attr_unify_hook(_,Term) :- lock_error(Term).
+
+%- locking & unlocking ---------------------------------------------------------
+'chr error_lock'(T) :-
+	( var(T)
+	-> put_attr(T, error_locked, x)
+        ;  term_variables(T,L),
+           error_lockv(L)
+	).
+
+error_lockv([]).
+error_lockv([T|R]) :- put_attr( T, error_locked, x), error_lockv(R).
+
+'chr unerror_lock'(T) :-
+	( var(T)
+	-> del_attr(T, error_locked)
+	;  term_variables(T,L),
+           unerror_lockv(L)
+	).
+
+unerror_lockv([]).
+unerror_lockv([T|R]) :- del_attr( T, error_locked), unerror_lockv(R).
+
+%- checking for locks ----------------------------------------------------------
+
+'chr none_error_locked'( []).
+'chr none_error_locked'( [V|Vs]) :-
+	( get_attr(V, error_locked, _) ->
+		fail
+	;
+		'chr none_error_locked'(Vs)
+	).
+
+'chr not_error_locked'(V) :-
+	( var( V) ->
+		( get_attr( V, error_locked, _) ->
+			fail
+		;
+			true
+		)
+	;
+		true
+	).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%
+% Eager removal from all chains.
+%
+'chr remove_constraint_internal'( Susp, Agenda) :-
+	arg( 2, Susp, Mref), % ARGXXX
+	'chr get_mutable'( State, Mref),
+	'chr update_mutable'( removed, Mref),		% mark in any case
+	( compound(State) ->			% passive/1
+	    Agenda = []
+	; State==removed ->
+	    Agenda = []
+	%; State==triggered ->
+	%     Agenda = []
+	;
+            Susp =.. [_,_,_,_,_,_,_|Args],
+	    term_variables( Args, Vars),
+	    'chr default_store'( Global),
+	    Agenda = [Global|Vars]
+	).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr newvia_1'(X,V) :-
+	( var(X) ->
+		X = V
+	;
+		nonground(X,V)
+	).
+
+'chr newvia_2'(X,Y,V) :-
+	( var(X) ->
+		X = V
+	; var(Y) ->
+		Y = V
+	; compound(X), nonground(X,V) ->
+		true
+	;
+		compound(Y), nonground(Y,V)
+	).
+
+%
+% The second arg is a witness.
+% The formulation with term_variables/2 is
+% cycle safe, but it finds a list of all vars.
+% We need only one, and no list in particular.
+%
+'chr newvia'(L,V) :- nonground(L,V).
+%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
+
+'chr via_1'(X,V) :-
+	( var(X) ->
+		X = V
+	; atomic(X) ->
+		'chr default_store'(V)
+	; nonground(X,V) ->
+		true
+	;
+		'chr default_store'(V)
+	).
+
+'chr via_2'(X,Y,V) :-
+	( var(X) ->
+		X = V
+	; var(Y) ->
+		Y = V
+	; compound(X), nonground(X,V) ->
+		true
+	; compound(Y), nonground(Y,V) ->
+		true
+	;
+		'chr default_store'(V)
+	).
+
+%
+% The second arg is a witness.
+% The formulation with term_variables/2 is
+% cycle safe, but it finds a list of all vars.
+% We need only one, and no list in particular.
+%
+'chr via'(L,V) :-
+	( nonground(L,V) ->
+		true
+	;
+		'chr default_store'(V)
+	).
+
+:- if(\+current_predicate(nonground/2)).
+nonground( Term, V) :-
+	term_variables( Term, Vs),
+	Vs = [V|_].
+:- endif.
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr novel_production'( Self, Tuple) :-
+	arg( 5, Self, Ref), % ARGXXX
+	'chr get_mutable'( History, Ref),
+	( get_ds( Tuple, History, _) ->
+	    fail
+	;
+	    true
+	).
+
+%
+% Not folded with novel_production/2 because guard checking
+% goes in between the two calls.
+%
+'chr extend_history'( Self, Tuple) :-
+	arg( 5, Self, Ref), % ARGXXX
+	'chr get_mutable'( History, Ref),
+	put_ds( Tuple, History, x, NewHistory),
+	'chr update_mutable'( NewHistory, Ref).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr allocate_constraint'( Closure, Self, F, Args) :-
+	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
+	'chr create_mutable'(0, Gref),
+	'chr empty_history'(History),
+	'chr create_mutable'(History, Href),
+	'chr create_mutable'(passive(Args), Mref),
+	'chr gen_id'( Id).
+
+%
+% 'chr activate_constraint'( -, +, -).
+%
+% The transition gc->active should be rare
+%
+'chr activate_constraint'( Vars, Susp, Generation) :-
+	arg( 2, Susp, Mref), % ARGXXX
+	'chr get_mutable'( State, Mref),
+	'chr update_mutable'( active, Mref),
+	( nonvar(Generation) ->			% aih
+	    true
+	;
+	    arg( 4, Susp, Gref), % ARGXXX
+	    'chr get_mutable'( Gen, Gref),
+	    Generation is Gen+1,
+	    'chr update_mutable'( Generation, Gref)
+	),
+	( compound(State) ->			% passive/1
+	    term_variables( State, Vs),
+	    'chr none_locked'( Vs),
+	    Vars = [Global|Vs],
+	    'chr default_store'(Global)
+	; State == removed ->			% the price for eager removal ...
+	    Susp =.. [_,_,_,_,_,_,_|Args],
+	    term_variables( Args, Vs),
+	    Vars = [Global|Vs],
+	    'chr default_store'(Global)
+	;
+	    Vars = []
+	).
+
+'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :-
+	'chr default_store'(Global),
+	term_variables(Args,Vars),
+	'chr none_locked'(Vars),
+	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
+	'chr create_mutable'(active, Mref),
+	'chr create_mutable'(0, Gref),
+	'chr empty_history'(History),
+	'chr create_mutable'(History, Href),
+	'chr gen_id'(Id).
+
+insert_constraint_internal([Global|Vars], Self, Term, Closure, F, Args) :-
+	'chr default_store'(Global),
+	term_variables( Term, Vars),
+	'chr none_locked'( Vars),
+	'chr empty_history'( History),
+	'chr create_mutable'( active, Mref),
+	'chr create_mutable'( 0, Gref),
+	'chr create_mutable'( History, Href),
+	'chr gen_id'( Id),
+	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args]. % SUSPXXX
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr empty_history'( E) :- empty_ds( E).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr gen_id'( Id) :-
+	nb_getval(chr_id,Id),
+	NextId is Id + 1,
+	nb_setval(chr_id,NextId).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+%% SWI begin
+'chr create_mutable'(V,mutable(V)).
+'chr get_mutable'(V,mutable(V)).
+'chr update_mutable'(V,M) :- setarg(1,M,V).
+%% SWI end
+
+%% SICStus begin
+%% 'chr create_mutable'(Val, Mut) :- create_mutable(Val, Mut).
+%% 'chr get_mutable'(Val, Mut) :- get_mutable(Val, Mut).
+%% 'chr update_mutable'(Val, Mut) :- update_mutable(Val, Mut).
+%% SICStus end
+
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%% SWI begin
+'chr default_store'(X) :- nb_getval(chr_global,X).
+%% SWI end
+
+%% SICStus begin
+%% 'chr default_store'(A) :- global_term_ref_1(A).
+%% SICStus end
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+'chr sbag_del_element'( [],	  _,	[]).
+'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
+	( X==Elem ->
+	    Set2 = Xs
+	;
+	    Set2 = [X|Xss],
+	    'chr sbag_del_element'( Xs, Elem, Xss)
+	).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+'chr merge_attributes'([],Ys,Ys).
+'chr merge_attributes'([X | Xs],YL,R) :-
+  ( YL = [Y | Ys] ->
+      arg(1,X,XId), % ARGXXX
+      arg(1,Y,YId),	 % ARGXXX
+       ( XId < YId ->
+           R = [X | T],
+           'chr merge_attributes'(Xs,YL,T)
+       ; XId > YId ->
+           R = [Y | T],
+           'chr merge_attributes'([X|Xs],Ys,T)
+       ;
+           R = [X | T],
+           'chr merge_attributes'(Xs,Ys,T)
+       )
+  ;
+       R = [X | Xs]
+  ).
+
+'chr new_merge_attributes'([],A2,A) :-
+	A = A2.
+'chr new_merge_attributes'([E1|AT1],A2,A) :-
+	( A2 = [E2|AT2] ->
+		'chr new_merge_attributes'(E1,E2,AT1,AT2,A)
+	;
+		A = [E1|AT1]
+	).
+
+'chr new_merge_attributes'(Pos1-L1,Pos2-L2,AT1,AT2,A) :-
+	( Pos1 < Pos2 ->
+		A = [Pos1-L1|AT],
+		'chr new_merge_attributes'(AT1,[Pos2-L2|AT2],AT)
+	; Pos1 > Pos2 ->
+		A = [Pos2-L2|AT],
+		'chr new_merge_attributes'([Pos1-L1|AT1],AT2,AT)
+	;
+		'chr merge_attributes'(L1,L2,L),
+		A = [Pos1-L|AT],
+		'chr new_merge_attributes'(AT1,AT2,AT)
+	).
+
+'chr all_suspensions'([],_,_).
+'chr all_suspensions'([Susps|SuspsList],Pos,Attr) :-
+	all_suspensions(Attr,Susps,SuspsList,Pos).
+
+all_suspensions([],[],SuspsList,Pos) :-
+	all_suspensions([],[],SuspsList,Pos). % all empty lists
+all_suspensions([APos-ASusps|RAttr],Susps,SuspsList,Pos) :-
+	NPos is Pos + 1,
+	( Pos == APos ->
+		Susps = ASusps,
+		'chr all_suspensions'(SuspsList,NPos,RAttr)
+	;
+		Susps = [],
+		'chr all_suspensions'(SuspsList,NPos,[APos-ASusps|RAttr])
+	).
+
+'chr normalize_attr'([],[]).
+'chr normalize_attr'([Pos-L|R],[Pos-NL|NR]) :-
+	sort(L,NL),
+	'chr normalize_attr'(R,NR).
+
+'chr select'([E|T],F,R) :-
+	( E = F ->
+		R = T
+	;
+		R = [E|NR],
+		'chr select'(T,F,NR)
+	).
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+
+:- multifile
+	chr:debug_event/2,		% +State, +Event
+	chr:debug_interact/3.		% +Event, +Depth, -Command
+
+'chr debugging' :-
+	nb_getval(chr_debug,mutable(trace)).
+
+'chr debug_event'(Event) :-
+	(   nb_getval(chr_debug,mutable(State)),
+	    State \== off
+	->  (   chr:debug_event(State, Event)
+	    ->  true
+	    ;	debug_event(State,Event)
+	    )
+	;   true
+	).
+
+chr_trace :-
+	nb_setval(chr_debug,mutable(trace)).
+chr_notrace :-
+	nb_setval(chr_debug,mutable(off)).
+
+%	chr_leash(+Spec)
+%
+%	Define the set of ports at which we prompt for user interaction
+
+chr_leash(Spec) :-
+	leashed_ports(Spec, Ports),
+	nb_setval(chr_leash,mutable(Ports)).
+
+leashed_ports(none, []).
+leashed_ports(off,  []).
+leashed_ports(all,  [call, exit, redo, fail, wake, try, apply, insert, remove]).
+leashed_ports(default, [call,exit,fail,wake,apply]).
+leashed_ports(One, Ports) :-
+	atom(One), One \== [], !,
+	leashed_ports([One], Ports).
+leashed_ports(Set, Ports) :-
+	sort(Set, Ports),		% make unique
+	leashed_ports(all, All),
+	valid_ports(Ports, All).
+
+valid_ports([], _).
+valid_ports([H|T], Valid) :-
+	(   memberchk(H, Valid)
+	->  true
+	;   throw(error(domain_error(chr_port, H), _))
+	),
+	valid_ports(T, Valid).
+
+user:exception(undefined_global_variable, Name, retry) :-
+	chr_runtime_debug_global_variable(Name),
+	chr_debug_init.
+
+chr_runtime_debug_global_variable(chr_leash).
+
+chr_debug_init :-
+   leashed_ports(default, Ports),
+   nb_setval(chr_leash, mutable(Ports)).
+
+:- initialization chr_debug_init.
+
+%	debug_event(+State, +Event)
+
+
+%debug_event(trace, Event) :-
+%	functor(Event, Name, Arity),
+%	writeln(Name/Arity), fail.
+debug_event(trace,Event) :-
+	Event = call(_), !,
+	get_debug_history(History,Depth),
+	NDepth is Depth + 1,
+	chr_debug_interact(Event,NDepth),
+	set_debug_history([Event|History],NDepth).
+debug_event(trace,Event) :-
+	Event = wake(_), !,
+	get_debug_history(History,Depth),
+	NDepth is Depth + 1,
+	chr_debug_interact(Event,NDepth),
+	set_debug_history([Event|History],NDepth).
+debug_event(trace,Event) :-
+	Event = redo(_), !,
+	get_debug_history(_History, Depth),
+	chr_debug_interact(Event, Depth).
+debug_event(trace,Event) :-
+	Event = exit(_),!,
+	get_debug_history([_|History],Depth),
+	chr_debug_interact(Event,Depth),
+	NDepth is Depth - 1,
+	set_debug_history(History,NDepth).
+debug_event(trace,Event) :-
+	Event = fail(_),!,
+	get_debug_history(_,Depth),
+	chr_debug_interact(Event,Depth).
+debug_event(trace, Event) :-
+	Event = remove(_), !,
+	get_debug_history(_,Depth),
+	chr_debug_interact(Event, Depth).
+debug_event(trace, Event) :-
+	Event = insert(_), !,
+	get_debug_history(_,Depth),
+	chr_debug_interact(Event, Depth).
+debug_event(trace, Event) :-
+	Event = try(_,_,_,_), !,
+	get_debug_history(_,Depth),
+	chr_debug_interact(Event, Depth).
+debug_event(trace, Event) :-
+	Event = apply(_,_,_,_), !,
+	get_debug_history(_,Depth),
+	chr_debug_interact(Event,Depth).
+
+debug_event(skip(_,_),Event) :-
+	Event = call(_), !,
+	get_debug_history(History,Depth),
+	NDepth is Depth + 1,
+	set_debug_history([Event|History],NDepth).
+debug_event(skip(_,_),Event) :-
+	Event = wake(_), !,
+	get_debug_history(History,Depth),
+	NDepth is Depth + 1,
+	set_debug_history([Event|History],NDepth).
+debug_event(skip(SkipSusp,SkipDepth),Event) :-
+	Event = exit(Susp),!,
+	get_debug_history([_|History],Depth),
+	( SkipDepth == Depth,
+	  SkipSusp == Susp ->
+		set_chr_debug(trace),
+		chr_debug_interact(Event,Depth)
+	;
+		true
+	),
+	NDepth is Depth - 1,
+	set_debug_history(History,NDepth).
+debug_event(skip(_,_),_) :- !,
+	true.
+
+%	chr_debug_interact(+Event, +Depth)
+%
+%	Interact with the user on Event that took place at Depth.  First
+%	calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
+%	fails the event is printed and the system prompts for a command.
+
+chr_debug_interact(Event, Depth) :-
+	chr:debug_interact(Event, Depth, Command), !,
+	handle_debug_command(Command,Event,Depth).
+chr_debug_interact(Event, Depth) :-
+	print_event(Event, Depth),
+	(   leashed(Event)
+	->  ask_continue(Command)
+	;   Command = creep
+	),
+	handle_debug_command(Command,Event,Depth).
+
+leashed(Event) :-
+	functor(Event, Port, _),
+	nb_getval(chr_leash, mutable(Ports)),
+	memberchk(Port, Ports).
+
+:- multifile
+	chr:debug_ask_continue/1.
+
+ask_continue(Command) :-
+	chr:debug_ask_continue(Command), !.
+ask_continue(Command) :-
+	print_message(trace, chr(prompt)),
+	get_single_char(CharCode),
+	(   CharCode == -1
+	->  Char = end_of_file
+	;   char_code(Char, CharCode)
+	),
+	(   debug_command(Char, Command)
+	->  print_message(trace, chr(command(Command)))
+	;   print_message(help, chr(invalid_command)),
+	    ask_continue(Command)
+	).
+
+
+'chr debug command'(Char, Command) :-
+	debug_command(Char, Command).
+
+debug_command(c, creep).
+debug_command(' ', creep).
+debug_command('\r', creep).
+debug_command(s, skip).
+debug_command(g, ancestors).
+debug_command(n, nodebug).
+debug_command(a, abort).
+debug_command(f, fail).
+debug_command(b, break).
+debug_command(?, help).
+debug_command(h, help).
+debug_command(end_of_file, exit).
+
+
+handle_debug_command(creep,_,_) :- !.
+handle_debug_command(skip, Event, Depth) :- !,
+	Event =.. [Type|Rest],
+	( Type \== call,
+	  Type \== wake ->
+		handle_debug_command(creep,Event,Depth)
+	;
+		Rest = [Susp],
+		set_chr_debug(skip(Susp,Depth))
+	).
+handle_debug_command(ancestors,Event,Depth) :- !,
+	print_chr_debug_history,
+	chr_debug_interact(Event,Depth).
+handle_debug_command(nodebug,_,_) :- !,
+	chr_notrace.
+handle_debug_command(abort,_,_) :- !,
+	abort.
+handle_debug_command(exit,_,_) :- !,
+	(   thread_self(main)		% Only allow terminating from the
+	->  halt			% main thread
+	;   permission_error(access, chr_debug, halt)
+	).
+handle_debug_command(fail,_,_) :- !,
+	fail.
+handle_debug_command(break,Event,Depth) :- !,
+	break,
+	chr_debug_interact(Event,Depth).
+handle_debug_command(help,Event,Depth) :- !,
+	print_message(help, chr(debug_options)),
+	chr_debug_interact(Event,Depth).
+handle_debug_command(Cmd, _, _) :-
+	throw(error(domain_error(chr_debug_command, Cmd), _)).
+
+print_chr_debug_history :-
+	get_debug_history(History,Depth),
+	print_message(trace, chr(ancestors(History, Depth))).
+
+print_event(Event, Depth) :-
+	print_message(trace, chr(event(Event, Depth))).
+
+%	{set,get}_debug_history(Ancestors, Depth)
+%
+%	Set/get the list of ancestors and the depth of the current goal.
+
+get_debug_history(History,Depth) :-
+	nb_getval(chr_debug_history,mutable(History,Depth)).
+
+set_debug_history(History,Depth) :-
+	nb_getval(chr_debug_history,Mutable),
+	setarg(1,Mutable,History),
+	setarg(2,Mutable,Depth).
+
+set_chr_debug(State) :-
+	nb_getval(chr_debug,Mutable),
+	setarg(1,Mutable,State).
+
+'chr chr_indexed_variables'(Susp,Vars) :-
+        Susp =.. [_,_,_,_,_,_,_|Args],
+	term_variables(Args,Vars).
+
+
+		 /*******************************
+		 *	      SANDBOX		*
+		 *******************************/
+:- multifile
+	sandbox:safe_primitive/1.
+
+sandbox:safe_primitive(chr_runtime:handle_debug_command(_,_,_)).
+sandbox:safe_primitive(chr_runtime:ask_continue(_)).