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	  ]).
 136
 137%% SWI begin
 138:- set_prolog_flag(generate_debug_info, false).
 139%% SWI end
 140
 141:- meta_predicate
 142	current_chr_constraint(:).
 143
 144%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 145
 146:- use_module(library(dialect/hprolog)).
 147:- include(chr_op).
 148
 149%% SICStus begin
 150%% :- use_module(hpattvars).
 151%% :- use_module(b_globval).
 152%% SICStus end
 153
 154
 155%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 156
 157%   I N I T I A L I S A T I O N
 158
 159%% SWI begin
 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
 178
 179%% SICStus begin
 180%% chr_init :-
 181%%	        nb_setval(chr_id,0).
 182%% SICStus end
 183
 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	).
 203
 204%%	find_chr_constraint(-Constraint) is nondet.
 205%
 206%	True when Constraint is a  currently   known  constraint  in any
 207%	known CHR module.
 208%
 209%	@deprecated	current_chr_constraint/1 handles modules.
 210
 211find_chr_constraint(Constraint) :-
 212	'chr module'(Mod),
 213	Mod:'$enumerate_constraints'(Constraint).
 214
 215%%	current_chr_constraint(:Constraint) is nondet.
 216%
 217%	True if Constraint is a constraint associated with the qualified
 218%	module.
 219
 220current_chr_constraint(Mod:Constraint) :-
 221	'chr module'(Mod),
 222	Mod:'$enumerate_constraints'(Constraint).
 223
 224%%	'chr module'(?Module)
 225%
 226%	True when Module is a CHR module.   The  first clause deals with
 227%	normal modules. The second with temporary modules, which are not
 228%	allowed to generate clauses for chr:'$chr_module'/1.
 229
 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%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 245
 246%% SWI begin
 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)).
 254%% SWI end
 255
 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
 259
 260
 261%% Mats begin
 262%% goal_expansion('chr get_mutable'(Val,Var),    Lay, _M, get_mutable(Val,Var), Lay).
 263%% goal_expansion('chr update_mutable'(Val,Var), Lay, _M, update_mutable(Val,Var), Lay).
 264%% goal_expansion('chr create_mutable'(Val,Var), Lay, _M, create_mutable(Val,Var), Lay).
 265%% goal_expansion('chr default_store'(A),        Lay, _M, global_term_ref_1(A), Lay).
 266%% Mats begin
 267
 268
 269%% SICStus begin
 270%% :- multifile user:goal_expansion/2.
 271%% :- dynamic   user:goal_expansion/2.
 272%%
 273%% user:goal_expansion('chr get_mutable'(Val,Var),    get_mutable(Val,Var)).
 274%% user:goal_expansion('chr update_mutable'(Val,Var), update_mutable(Val,Var)).
 275%% user:goal_expansion('chr create_mutable'(Val,Var), create_mutable(Val,Var)).
 276%% user:goal_expansion('chr default_store'(A),        global_term_ref_1(A)).
 277%% SICStus end
 278
 279
 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
 548nonground( Term, V) :-
 549	term_variables( Term, Vs),
 550	Vs = [V|_].
 551
 552%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 553'chr novel_production'( Self, Tuple) :-
 554	arg( 5, Self, Ref), % ARGXXX
 555	'chr get_mutable'( History, Ref),
 556	( get_ds( Tuple, History, _) ->
 557	    fail
 558	;
 559	    true
 560	).
 561
 562%
 563% Not folded with novel_production/2 because guard checking
 564% goes in between the two calls.
 565%
 566'chr extend_history'( Self, Tuple) :-
 567	arg( 5, Self, Ref), % ARGXXX
 568	'chr get_mutable'( History, Ref),
 569	put_ds( Tuple, History, x, NewHistory),
 570	'chr update_mutable'( NewHistory, Ref).
 571
 572%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 573'chr allocate_constraint'( Closure, Self, F, Args) :-
 574	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
 575	'chr create_mutable'(0, Gref),
 576	'chr empty_history'(History),
 577	'chr create_mutable'(History, Href),
 578	'chr create_mutable'(passive(Args), Mref),
 579	'chr gen_id'( Id).
 580
 581%
 582% 'chr activate_constraint'( -, +, -).
 583%
 584% The transition gc->active should be rare
 585%
 586'chr activate_constraint'( Vars, Susp, Generation) :-
 587	arg( 2, Susp, Mref), % ARGXXX
 588	'chr get_mutable'( State, Mref),
 589	'chr update_mutable'( active, Mref),
 590	( nonvar(Generation) ->			% aih
 591	    true
 592	;
 593	    arg( 4, Susp, Gref), % ARGXXX
 594	    'chr get_mutable'( Gen, Gref),
 595	    Generation is Gen+1,
 596	    'chr update_mutable'( Generation, Gref)
 597	),
 598	( compound(State) ->			% passive/1
 599	    term_variables( State, Vs),
 600	    'chr none_locked'( Vs),
 601	    Vars = [Global|Vs],
 602	    'chr default_store'(Global)
 603	; State == removed ->			% the price for eager removal ...
 604	    Susp =.. [_,_,_,_,_,_,_|Args],
 605	    term_variables( Args, Vs),
 606	    Vars = [Global|Vs],
 607	    'chr default_store'(Global)
 608	;
 609	    Vars = []
 610	).
 611
 612'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :-
 613	'chr default_store'(Global),
 614	term_variables(Args,Vars),
 615	'chr none_locked'(Vars),
 616	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
 617	'chr create_mutable'(active, Mref),
 618	'chr create_mutable'(0, Gref),
 619	'chr empty_history'(History),
 620	'chr create_mutable'(History, Href),
 621	'chr gen_id'(Id).
 622
 623insert_constraint_internal([Global|Vars], Self, Term, Closure, F, Args) :-
 624	'chr default_store'(Global),
 625	term_variables( Term, Vars),
 626	'chr none_locked'( Vars),
 627	'chr empty_history'( History),
 628	'chr create_mutable'( active, Mref),
 629	'chr create_mutable'( 0, Gref),
 630	'chr create_mutable'( History, Href),
 631	'chr gen_id'( Id),
 632	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args]. % SUSPXXX
 633
 634%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 635'chr empty_history'( E) :- empty_ds( E).
 636
 637%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 638'chr gen_id'( Id) :-
 639	nb_getval(chr_id,Id),
 640	NextId is Id + 1,
 641	nb_setval(chr_id,NextId).
 642
 643%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 644
 645%% SWI begin
 646'chr create_mutable'(V,mutable(V)).
 647'chr get_mutable'(V,mutable(V)).
 648'chr update_mutable'(V,M) :- setarg(1,M,V).
 649%% SWI end
 650
 651%% SICStus begin
 652%% 'chr create_mutable'(Val, Mut) :- create_mutable(Val, Mut).
 653%% 'chr get_mutable'(Val, Mut) :- get_mutable(Val, Mut).
 654%% 'chr update_mutable'(Val, Mut) :- update_mutable(Val, Mut).
 655%% SICStus end
 656
 657
 658%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 659%% SWI begin
 660'chr default_store'(X) :- nb_getval(chr_global,X).
 661%% SWI end
 662
 663%% SICStus begin
 664%% 'chr default_store'(A) :- global_term_ref_1(A).
 665%% SICStus end
 666
 667%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 668
 669'chr sbag_del_element'( [],	  _,	[]).
 670'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
 671	( X==Elem ->
 672	    Set2 = Xs
 673	;
 674	    Set2 = [X|Xss],
 675	    'chr sbag_del_element'( Xs, Elem, Xss)
 676	).
 677
 678%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 679'chr merge_attributes'([],Ys,Ys).
 680'chr merge_attributes'([X | Xs],YL,R) :-
 681  ( YL = [Y | Ys] ->
 682      arg(1,X,XId), % ARGXXX
 683      arg(1,Y,YId),	 % ARGXXX
 684       ( XId < YId ->
 685           R = [X | T],
 686           'chr merge_attributes'(Xs,YL,T)
 687       ; XId > YId ->
 688           R = [Y | T],
 689           'chr merge_attributes'([X|Xs],Ys,T)
 690       ;
 691           R = [X | T],
 692           'chr merge_attributes'(Xs,Ys,T)
 693       )
 694  ;
 695       R = [X | Xs]
 696  ).
 697
 698'chr new_merge_attributes'([],A2,A) :-
 699	A = A2.
 700'chr new_merge_attributes'([E1|AT1],A2,A) :-
 701	( A2 = [E2|AT2] ->
 702		'chr new_merge_attributes'(E1,E2,AT1,AT2,A)
 703	;
 704		A = [E1|AT1]
 705	).
 706
 707'chr new_merge_attributes'(Pos1-L1,Pos2-L2,AT1,AT2,A) :-
 708	( Pos1 < Pos2 ->
 709		A = [Pos1-L1|AT],
 710		'chr new_merge_attributes'(AT1,[Pos2-L2|AT2],AT)
 711	; Pos1 > Pos2 ->
 712		A = [Pos2-L2|AT],
 713		'chr new_merge_attributes'([Pos1-L1|AT1],AT2,AT)
 714	;
 715		'chr merge_attributes'(L1,L2,L),
 716		A = [Pos1-L|AT],
 717		'chr new_merge_attributes'(AT1,AT2,AT)
 718	).
 719
 720'chr all_suspensions'([],_,_).
 721'chr all_suspensions'([Susps|SuspsList],Pos,Attr) :-
 722	all_suspensions(Attr,Susps,SuspsList,Pos).
 723
 724all_suspensions([],[],SuspsList,Pos) :-
 725	all_suspensions([],[],SuspsList,Pos). % all empty lists
 726all_suspensions([APos-ASusps|RAttr],Susps,SuspsList,Pos) :-
 727	NPos is Pos + 1,
 728	( Pos == APos ->
 729		Susps = ASusps,
 730		'chr all_suspensions'(SuspsList,NPos,RAttr)
 731	;
 732		Susps = [],
 733		'chr all_suspensions'(SuspsList,NPos,[APos-ASusps|RAttr])
 734	).
 735
 736'chr normalize_attr'([],[]).
 737'chr normalize_attr'([Pos-L|R],[Pos-NL|NR]) :-
 738	sort(L,NL),
 739	'chr normalize_attr'(R,NR).
 740
 741'chr select'([E|T],F,R) :-
 742	( E = F ->
 743		R = T
 744	;
 745		R = [E|NR],
 746		'chr select'(T,F,NR)
 747	).
 748
 749%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 750
 751:- multifile
 752	chr:debug_event/2,		% +State, +Event
 753	chr:debug_interact/3.		% +Event, +Depth, -Command
 754
 755'chr debugging' :-
 756	nb_getval(chr_debug,mutable(trace)).
 757
 758'chr debug_event'(Event) :-
 759	(   nb_getval(chr_debug,mutable(State)),
 760	    State \== off
 761	->  (   chr:debug_event(State, Event)
 762	    ->  true
 763	    ;	debug_event(State,Event)
 764	    )
 765	;   true
 766	).
 767
 768chr_trace :-
 769	nb_setval(chr_debug,mutable(trace)).
 770chr_notrace :-
 771	nb_setval(chr_debug,mutable(off)).
 772
 773%	chr_leash(+Spec)
 774%
 775%	Define the set of ports at which we prompt for user interaction
 776
 777chr_leash(Spec) :-
 778	leashed_ports(Spec, Ports),
 779	nb_setval(chr_leash,mutable(Ports)).
 780
 781leashed_ports(none, []).
 782leashed_ports(off,  []).
 783leashed_ports(all,  [call, exit, redo, fail, wake, try, apply, insert, remove]).
 784leashed_ports(default, [call,exit,fail,wake,apply]).
 785leashed_ports(One, Ports) :-
 786	atom(One), One \== [], !,
 787	leashed_ports([One], Ports).
 788leashed_ports(Set, Ports) :-
 789	sort(Set, Ports),		% make unique
 790	leashed_ports(all, All),
 791	valid_ports(Ports, All).
 792
 793valid_ports([], _).
 794valid_ports([H|T], Valid) :-
 795	(   memberchk(H, Valid)
 796	->  true
 797	;   throw(error(domain_error(chr_port, H), _))
 798	),
 799	valid_ports(T, Valid).
 800
 801user:exception(undefined_global_variable, Name, retry) :-
 802	chr_runtime_debug_global_variable(Name),
 803	chr_debug_init.
 804
 805chr_runtime_debug_global_variable(chr_leash).
 806
 807chr_debug_init :-
 808   leashed_ports(default, Ports),
 809   nb_setval(chr_leash, mutable(Ports)).
 810
 811:- initialization chr_debug_init.
 812
 813%	debug_event(+State, +Event)
 814
 815
 816%debug_event(trace, Event) :-
 817%	functor(Event, Name, Arity),
 818%	writeln(Name/Arity), fail.
 819debug_event(trace,Event) :-
 820	Event = call(_), !,
 821	get_debug_history(History,Depth),
 822	NDepth is Depth + 1,
 823	chr_debug_interact(Event,NDepth),
 824	set_debug_history([Event|History],NDepth).
 825debug_event(trace,Event) :-
 826	Event = wake(_), !,
 827	get_debug_history(History,Depth),
 828	NDepth is Depth + 1,
 829	chr_debug_interact(Event,NDepth),
 830	set_debug_history([Event|History],NDepth).
 831debug_event(trace,Event) :-
 832	Event = redo(_), !,
 833	get_debug_history(_History, Depth),
 834	chr_debug_interact(Event, Depth).
 835debug_event(trace,Event) :-
 836	Event = exit(_),!,
 837	get_debug_history([_|History],Depth),
 838	chr_debug_interact(Event,Depth),
 839	NDepth is Depth - 1,
 840	set_debug_history(History,NDepth).
 841debug_event(trace,Event) :-
 842	Event = fail(_),!,
 843	get_debug_history(_,Depth),
 844	chr_debug_interact(Event,Depth).
 845debug_event(trace, Event) :-
 846	Event = remove(_), !,
 847	get_debug_history(_,Depth),
 848	chr_debug_interact(Event, Depth).
 849debug_event(trace, Event) :-
 850	Event = insert(_), !,
 851	get_debug_history(_,Depth),
 852	chr_debug_interact(Event, Depth).
 853debug_event(trace, Event) :-
 854	Event = try(_,_,_,_), !,
 855	get_debug_history(_,Depth),
 856	chr_debug_interact(Event, Depth).
 857debug_event(trace, Event) :-
 858	Event = apply(_,_,_,_), !,
 859	get_debug_history(_,Depth),
 860	chr_debug_interact(Event,Depth).
 861
 862debug_event(skip(_,_),Event) :-
 863	Event = call(_), !,
 864	get_debug_history(History,Depth),
 865	NDepth is Depth + 1,
 866	set_debug_history([Event|History],NDepth).
 867debug_event(skip(_,_),Event) :-
 868	Event = wake(_), !,
 869	get_debug_history(History,Depth),
 870	NDepth is Depth + 1,
 871	set_debug_history([Event|History],NDepth).
 872debug_event(skip(SkipSusp,SkipDepth),Event) :-
 873	Event = exit(Susp),!,
 874	get_debug_history([_|History],Depth),
 875	( SkipDepth == Depth,
 876	  SkipSusp == Susp ->
 877		set_chr_debug(trace),
 878		chr_debug_interact(Event,Depth)
 879	;
 880		true
 881	),
 882	NDepth is Depth - 1,
 883	set_debug_history(History,NDepth).
 884debug_event(skip(_,_),_) :- !,
 885	true.
 886
 887%	chr_debug_interact(+Event, +Depth)
 888%
 889%	Interact with the user on Event that took place at Depth.  First
 890%	calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
 891%	fails the event is printed and the system prompts for a command.
 892
 893chr_debug_interact(Event, Depth) :-
 894	chr:debug_interact(Event, Depth, Command), !,
 895	handle_debug_command(Command,Event,Depth).
 896chr_debug_interact(Event, Depth) :-
 897	print_event(Event, Depth),
 898	(   leashed(Event)
 899	->  ask_continue(Command)
 900	;   Command = creep
 901	),
 902	handle_debug_command(Command,Event,Depth).
 903
 904leashed(Event) :-
 905	functor(Event, Port, _),
 906	nb_getval(chr_leash, mutable(Ports)),
 907	memberchk(Port, Ports).
 908
 909:- multifile
 910	chr:debug_ask_continue/1.
 911
 912ask_continue(Command) :-
 913	chr:debug_ask_continue(Command), !.
 914ask_continue(Command) :-
 915	print_message(trace, chr(prompt)),
 916	get_single_char(CharCode),
 917	(   CharCode == -1
 918	->  Char = end_of_file
 919	;   char_code(Char, CharCode)
 920	),
 921	(   debug_command(Char, Command)
 922	->  print_message(trace, chr(command(Command)))
 923	;   print_message(help, chr(invalid_command)),
 924	    ask_continue(Command)
 925	).
 926
 927
 928'chr debug command'(Char, Command) :-
 929	debug_command(Char, Command).
 930
 931debug_command(c, creep).
 932debug_command(' ', creep).
 933debug_command('\r', creep).
 934debug_command(s, skip).
 935debug_command(g, ancestors).
 936debug_command(n, nodebug).
 937debug_command(a, abort).
 938debug_command(f, fail).
 939debug_command(b, break).
 940debug_command(?, help).
 941debug_command(h, help).
 942debug_command(end_of_file, exit).
 943
 944
 945handle_debug_command(creep,_,_) :- !.
 946handle_debug_command(skip, Event, Depth) :- !,
 947	Event =.. [Type|Rest],
 948	( Type \== call,
 949	  Type \== wake ->
 950		handle_debug_command(creep,Event,Depth)
 951	;
 952		Rest = [Susp],
 953		set_chr_debug(skip(Susp,Depth))
 954	).
 955handle_debug_command(ancestors,Event,Depth) :- !,
 956	print_chr_debug_history,
 957	chr_debug_interact(Event,Depth).
 958handle_debug_command(nodebug,_,_) :- !,
 959	chr_notrace.
 960handle_debug_command(abort,_,_) :- !,
 961	abort.
 962handle_debug_command(exit,_,_) :- !,
 963	(   thread_self(main)		% Only allow terminating from the
 964	->  halt			% main thread
 965	;   permission_error(access, chr_debug, halt)
 966	).
 967handle_debug_command(fail,_,_) :- !,
 968	fail.
 969handle_debug_command(break,Event,Depth) :- !,
 970	break,
 971	chr_debug_interact(Event,Depth).
 972handle_debug_command(help,Event,Depth) :- !,
 973	print_message(help, chr(debug_options)),
 974	chr_debug_interact(Event,Depth).
 975handle_debug_command(Cmd, _, _) :-
 976	throw(error(domain_error(chr_debug_command, Cmd), _)).
 977
 978print_chr_debug_history :-
 979	get_debug_history(History,Depth),
 980	print_message(trace, chr(ancestors(History, Depth))).
 981
 982print_event(Event, Depth) :-
 983	print_message(trace, chr(event(Event, Depth))).
 984
 985%	{set,get}_debug_history(Ancestors, Depth)
 986%
 987%	Set/get the list of ancestors and the depth of the current goal.
 988
 989get_debug_history(History,Depth) :-
 990	nb_getval(chr_debug_history,mutable(History,Depth)).
 991
 992set_debug_history(History,Depth) :-
 993	nb_getval(chr_debug_history,Mutable),
 994	setarg(1,Mutable,History),
 995	setarg(2,Mutable,Depth).
 996
 997set_chr_debug(State) :-
 998	nb_getval(chr_debug,Mutable),
 999	setarg(1,Mutable,State).
1000
1001'chr chr_indexed_variables'(Susp,Vars) :-
1002        Susp =.. [_,_,_,_,_,_,_|Args],
1003	term_variables(Args,Vars).
1004
1005
1006		 /*******************************
1007		 *	      SANDBOX		*
1008		 *******************************/
1009:- multifile
1010	sandbox:safe_primitive/1.
1011
1012sandbox:safe_primitive(chr_runtime:handle_debug_command(_,_,_)).
1013sandbox:safe_primitive(chr_runtime:ask_continue(_)).