chr_runtime.pl

   1 /*  $Id$
   2
   3     Part of CHR (Constraint Handling Rules)
   4
   5     Author:        Christian Holzbaur and Tom Schrijvers
   6     E-mail:        christian@ai.univie.ac.at
   7                    Tom.Schrijvers@cs.kuleuven.ac.be
   8     WWW:           http://www.swi-prolog.org
   9     Copyright (C): 2003-2004, K.U. Leuven
  10
  11     This program is free software; you can redistribute it and/or
  12     modify it under the terms of the GNU General Public License
  13     as published by the Free Software Foundation; either version 2
  14     of the License, or (at your option) any later version.
  15
  16     This program is distributed in the hope that it will be useful,
  17     but WITHOUT ANY WARRANTY; without even the implied warranty of
  18     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19     GNU General Public License for more details.
  20
  21     You should have received a copy of the GNU Lesser General Public
  22     License along with this library; if not, write to the Free Software
  23     Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  24
  25     As a special exception, if you link this library with other files,
  26     compiled with a Free Software compiler, to produce an executable, this
  27     library does not by itself cause the resulting executable to be covered
  28     by the GNU General Public License. This exception does not however
  29     invalidate any other reasons why the executable file might be covered by
  30     the GNU General Public License.
  31
  32     Distributed with SWI-Prolog under the above conditions with
  33     permission from the authors.
  34 */
  35
  36
  37 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  38 %%       _                             _   _
  39 %%   ___| |__  _ __   _ __ _   _ _ __ | |_(_)_ __ ___   ___
  40 %%  / __| '_ \| '__| | '__| | | | '_ \| __| | '_ ` _ \ / _ \
  41 %% | (__| | | | |    | |  | |_| | | | | |_| | | | | | |  __/
  42 %%  \___|_| |_|_|    |_|   \__,_|_| |_|\__|_|_| |_| |_|\___|
  43 %%
  44 %% hProlog CHR runtime:
  45 %%
  46 %%      * based on the SICStus CHR runtime by Christian Holzbaur
  47 %%
  48 %%          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  49 %%          %  Constraint Handling Rules                      version 2.2 %
  50 %%          %                                                             %
  51 %%          %  (c) Copyright 1996-98                                      %
  52 %%          %  LMU, Muenchen                                              %
  53 %%          %                                                             %
  54 %%          %  File:   chr.pl                                             %
  55 %%          %  Author: Christian Holzbaur       christian@ai.univie.ac.at %
  56 %%          %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  57 %%
  58 %%
  59 %%      * modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
  60 %%              - ported to hProlog
  61 %%              - modified for eager suspension removal
  62 %%
  63 %%      * First working version: 6 June 2003
  64 %%
  65 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  66 %% SWI-Prolog changes
  67 %%
  68 %%      * Added initialization directives for saved-states
  69 %%      * Renamed merge/3 --> sbag_merge/3 (name conflict)
  70 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
  71
  72 :- module(chr_runtime,
  73           [ 'chr sbag_del_element'/3,
  74             'chr sbag_member'/2,
  75             'chr merge_attributes'/3,
  76
  77             'chr run_suspensions'/1,
  78             'chr run_suspensions_loop'/1,
  79
  80             'chr run_suspensions_d'/1,
  81             'chr run_suspensions_loop_d'/1,
  82
  83             'chr insert_constraint_internal'/5,
  84             'chr remove_constraint_internal'/2,
  85             'chr allocate_constraint'/4,
  86             'chr activate_constraint'/3,
  87
  88             'chr global_term_ref_1'/1,
  89
  90             'chr via_1'/2,
  91             'chr via_2'/3,
  92             'chr via'/2,
  93
  94             'chr lock'/1,
  95             'chr unlock'/1,
  96             'chr not_locked'/1,
  97             'chr none_locked'/1,
  98
  99             'chr update_mutable'/2,
 100             'chr get_mutable'/2,
 101
 102             'chr novel_production'/2,
 103             'chr extend_history'/2,
 104             'chr empty_history'/1,
 105
 106             'chr gen_id'/1,
 107
 108             'chr debug_event'/1,
 109             'chr debug command'/2,      % Char, Command
 110
 111             'chr chr_indexed_variables'/2,
 112
 113             chr_trace/0,
 114             chr_notrace/0,
 115             chr_leash/1
 116           ]).
 117 :- set_prolog_flag(generate_debug_info, false).
 118
 119 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 120
 121 :- use_module(library(assoc)).
 122 :- use_module(hprolog).
 123 :- use_module(library(lists)).
 124 :- include(chr_op).
 125
 126 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 127
 128 %   I N I T I A L I S A T I O N
 129
 130 ?- initialization                       % SWI
 131    nb_setval(id,0).
 132
 133 ?- initialization                       % SWI
 134    nb_setval(chr_global,_).
 135
 136 ?- initialization
 137    nb_setval(chr_debug,mutable(off)).
 138
 139 ?- initialization
 140    nb_setval(chr_debug_history,mutable([],0)).
 141
 142 show_store(Mod) :-
 143         (
 144                 Mod:'$enumerate_suspensions'(Susp),
 145                 arg(6,Susp,C),
 146                 writeln(C),
 147                 fail
 148         ;
 149                 true
 150         ).
 151
 152 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 153 'chr merge_attributes'( As, Bs, Cs) :-
 154         sbag_union(As,Bs,Cs).
 155
 156 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 157 'chr run_suspensions'( Slots) :-
 158             run_suspensions( Slots).
 159
 160 'chr run_suspensions_loop'([]).
 161 'chr run_suspensions_loop'([L|Ls]) :-
 162         run_suspensions(L),
 163         'chr run_suspensions_loop'(Ls).
 164
 165 run_suspensions([]).
 166 run_suspensions([S|Next] ) :-
 167         arg( 2, S, Mref),
 168         Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
 169         ( Status==active ->
 170             update_mutable( triggered, Mref),
 171             arg( 4, S, Gref),
 172             Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
 173             Generation is Gen+1,
 174             update_mutable( Generation, Gref),
 175             arg( 3, S, Goal),
 176             call( Goal),
 177                                                 % get_mutable( Post, Mref), % XXX Inlined
 178             ( Mref = mutable(triggered) ->      % Post==triggered ->
 179                 update_mutable( removed, Mref)
 180             ;
 181                 true
 182             )
 183         ;
 184             true
 185         ),
 186         run_suspensions( Next).
 187
 188 'chr run_suspensions_d'( Slots) :-
 189             run_suspensions_d( Slots).
 190
 191 'chr run_suspensions_loop_d'([]).
 192 'chr run_suspensions_loop_d'([L|Ls]) :-
 193         run_suspensions_d(L),
 194         'chr run_suspensions_loop_d'(Ls).
 195
 196 run_suspensions_d([]).
 197 run_suspensions_d([S|Next] ) :-
 198         arg( 2, S, Mref),
 199         Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
 200         ( Status==active ->
 201             update_mutable( triggered, Mref),
 202             arg( 4, S, Gref),
 203             Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
 204             Generation is Gen+1,
 205             update_mutable( Generation, Gref),
 206             arg( 3, S, Goal),
 207             (
 208                 'chr debug_event'(wake(S)),
 209                 call( Goal)
 210             ;
 211                 'chr debug_event'(fail(S)), !,
 212                 fail
 213             ),
 214             (
 215                 'chr debug_event'(exit(S))
 216             ;
 217                 'chr debug_event'(redo(S)),
 218                 fail
 219             ),
 220                                                 % get_mutable( Post, Mref), % XXX Inlined
 221             ( Mref = mutable(triggered) ->      % Post==triggered ->
 222                 update_mutable( removed, Mref)
 223             ;
 224                 true
 225             )
 226         ;
 227             true
 228         ),
 229         run_suspensions_d( Next).
 230 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 231 locked:attr_unify_hook(_,_) :- fail.
 232
 233 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 234 'chr lock'(T) :-
 235         lock(T).
 236
 237 'chr unlock'(T) :-
 238         unlock(T).
 239
 240 'chr not_locked'(T) :-
 241         not_locked(T).
 242
 243 lock(T) :-
 244         ( var(T)
 245         -> put_attr(T, locked, x)
 246         ;  term_variables(T,L),
 247            lockv(L)
 248         ).
 249
 250 lockv([]).
 251 lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
 252
 253 unlock(T) :-
 254         ( var(T)
 255         -> del_attr(T, locked)
 256         ;  term_variables(T,L),
 257            unlockv(L)
 258         ).
 259
 260 unlockv([]).
 261 unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
 262
 263 'chr none_locked'( []).
 264 'chr none_locked'( [V|Vs]) :-
 265         not_locked( V),
 266         'chr none_locked'( Vs).
 267
 268 not_locked( V) :-
 269         ( var( V) ->
 270                 ( get_attr( V, locked, _) ->
 271                         fail
 272                 ;
 273                         true
 274                 )
 275         ;
 276                 true
 277         ).
 278
 279 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 280 %
 281 % Eager removal from all chains.
 282 %
 283 'chr remove_constraint_internal'( Susp, Agenda) :-
 284         arg( 2, Susp, Mref),
 285         Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
 286         update_mutable( removed, Mref),         % mark in any case
 287         ( compound(State) ->                    % passive/1
 288             Agenda = []
 289         ; State==removed ->
 290             Agenda = []
 291         %; State==triggered ->
 292         %     Agenda = []
 293         ;
 294             Susp =.. [_,_,_,_,_,_,_|Args],
 295             term_variables( Args, Vars),
 296             global_term_ref_1( Global),
 297             Agenda = [Global|Vars]
 298         ).
 299
 300 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 301 'chr via_1'(X,V) :-
 302         ( var(X) ->
 303                 X = V
 304         ; atomic(X) ->
 305                 global_term_ref_1(V)
 306         ; nonground(X,V) ->
 307                 true
 308         ;
 309                 global_term_ref_1(V)
 310         ).
 311 % 'chr via_1'( X, V) :- var(X), !, X=V.
 312 % 'chr via_1'( T, V) :- compound(T), nonground( T, V), ! .
 313 % 'chr via_1'( _, V) :- global_term_ref_1( V).
 314
 315 'chr via_2'(X,Y,V) :-
 316         ( var(X) ->
 317                 X = V
 318         ; var(Y) ->
 319                 Y = V
 320         ; compound(X), nonground(X,V) ->
 321                 true
 322         ; compound(Y), nonground(Y,V) ->
 323                 true
 324         ;
 325                 global_term_ref_1(V)
 326         ).
 327 % 'chr via_2'( X, _, V) :- var(X), !, X=V.
 328 % 'chr via_2'( _, Y, V) :- var(Y), !, Y=V.
 329 % 'chr via_2'( T, _, V) :- compound(T), nonground( T, V), ! .
 330 % 'chr via_2'( _, T, V) :- compound(T), nonground( T, V), ! .
 331 % 'chr via_2'( _, _, V) :- global_term_ref_1( V).
 332
 333 %
 334 % The second arg is a witness.
 335 % The formulation with term_variables/2 is
 336 % cycle safe, but it finds a list of all vars.
 337 % We need only one, and no list in particular.
 338 %
 339 'chr via'(L,V) :-
 340         ( nonground(L,V) ->
 341                 true
 342         ;
 343                 global_term_ref_1(V)
 344         ).
 345
 346 nonground( Term, V) :-
 347         term_variables( Term, Vs),
 348         Vs = [V|_].
 349
 350 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 351 'chr novel_production'( Self, Tuple) :-
 352         arg( 5, Self, Ref),
 353         Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
 354         ( get_assoc( Tuple, History, _) ->
 355             fail
 356         ;
 357             true
 358         ).
 359
 360 %
 361 % Not folded with novel_production/2 because guard checking
 362 % goes in between the two calls.
 363 %
 364 'chr extend_history'( Self, Tuple) :-
 365         arg( 5, Self, Ref),
 366         Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
 367         put_assoc( Tuple, History, x, NewHistory),
 368         update_mutable( NewHistory, Ref).
 369
 370 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 371 constraint_generation( Susp, State, Generation) :-
 372         arg( 2, Susp, Mref),
 373         Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
 374         arg( 4, Susp, Gref),
 375         Gref = mutable(Generation). % get_mutable( Generation, Gref).   % not incremented meanwhile % XXX Inlined
 376
 377 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 378 'chr allocate_constraint'( Closure, Self, F, Args) :-
 379         'chr empty_history'( History),
 380         create_mutable( passive(Args), Mref),
 381         create_mutable( 0, Gref),
 382         create_mutable( History, Href),
 383         'chr gen_id'( Id),
 384         Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
 385
 386 %
 387 % 'chr activate_constraint'( -, +, -).
 388 %
 389 % The transition gc->active should be rare
 390 %
 391 'chr activate_constraint'( Vars, Susp, Generation) :-
 392         arg( 2, Susp, Mref),
 393         Mref = mutable(State), % get_mutable( State, Mref),  % XXX Inlined
 394         update_mutable( active, Mref),
 395         ( nonvar(Generation) ->                 % aih
 396             true
 397         ;
 398             arg( 4, Susp, Gref),
 399             Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
 400             Generation is Gen+1,
 401             update_mutable( Generation, Gref)
 402         ),
 403         ( compound(State) ->                    % passive/1
 404             term_variables( State, Vs),
 405             'chr none_locked'( Vs),
 406             global_term_ref_1( Global),
 407             Vars = [Global|Vs]
 408         ; State==removed ->                     % the price for eager removal ...
 409             Susp =.. [_,_,_,_,_,_,_|Args],
 410             term_variables( Args, Vs),
 411             global_term_ref_1( Global),
 412             Vars = [Global|Vs]
 413         ;
 414             Vars = []
 415         ).
 416
 417 'chr insert_constraint_internal'( [Global|Vars], Self, Closure, F, Args) :-
 418         term_variables( Args, Vars),
 419         'chr none_locked'( Vars),
 420         global_term_ref_1( Global),
 421         'chr empty_history'( History),
 422         create_mutable( active, Mref),
 423         create_mutable( 0, Gref),
 424         create_mutable( History, Href),
 425         'chr gen_id'( Id),
 426         Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
 427
 428 insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
 429         term_variables( Term, Vars),
 430         'chr none_locked'( Vars),
 431         global_term_ref_1( Global),
 432         'chr empty_history'( History),
 433         create_mutable( active, Mref),
 434         create_mutable( 0, Gref),
 435         create_mutable( History, Href),
 436         'chr gen_id'( Id),
 437         Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
 438
 439 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 440 change_state( Susp, State) :-
 441         arg( 2, Susp, Mref),
 442         update_mutable( State, Mref).
 443
 444 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 445 'chr empty_history'( E) :- empty_assoc( E).
 446
 447 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 448 'chr gen_id'( Id) :-
 449         incval( id, Id).
 450
 451 incval(id,Id) :-
 452         nb_getval(id,Id),
 453         NextId is Id + 1,
 454         nb_setval(id,NextId).
 455
 456 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 457 create_mutable(V,mutable(V)).
 458
 459 'chr get_mutable'(V, mutable(V)).
 460
 461 'chr update_mutable'(V,M) :-
 462         setarg(1,M,V).
 463
 464 get_mutable(V, mutable(V)).
 465
 466 update_mutable(V,M) :-
 467         setarg(1,M,V).
 468
 469 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 470 'chr global_term_ref_1'(X) :-
 471         global_term_ref_1(X).
 472
 473 global_term_ref_1(X) :-
 474         nb_getval(chr_global,X).
 475
 476 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 477
 478 'chr sbag_member'( Element, [Head|Tail]) :-
 479       sbag_member( Element, Tail, Head).
 480
 481 % auxiliary to avoid choicepoint for last element
 482
 483 sbag_member( E, _,           E).
 484 sbag_member( E, [Head|Tail], _) :-
 485         sbag_member( E, Tail, Head).
 486
 487 'chr sbag_del_element'( [],       _,    []).
 488 'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
 489         ( X==Elem ->
 490             Set2 = Xs
 491         ;
 492             Set2 = [X|Xss],
 493             'chr sbag_del_element'( Xs, Elem, Xss)
 494         ).
 495
 496 sbag_union( A, B, C) :-
 497         sbag_merge( A, B, C).
 498
 499 sbag_merge([],Ys,Ys).
 500 sbag_merge([X | Xs],YL,R) :-
 501   ( YL = [Y | Ys] ->
 502       arg(1,X,XId),
 503       arg(1,Y,YId),
 504        ( XId < YId ->
 505            R = [X | T],
 506            sbag_merge(Xs,YL,T)
 507        ; XId > YId ->
 508            R = [Y | T],
 509            sbag_merge([X|Xs],Ys,T)
 510        ;
 511            R = [X | T],
 512            sbag_merge(Xs,Ys,T)
 513        )
 514   ;
 515        R = [X | Xs]
 516   ).
 517
 518 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 519
 520 :- multifile
 521         chr:debug_event/2,              % +State, +Event
 522         chr:debug_interact/3.           % +Event, +Depth, -Command
 523
 524 'chr debug_event'(Event) :-
 525         nb_getval(chr_debug,mutable(State)),
 526         ( State == off ->
 527                 true
 528         ; chr:debug_event(State, Event) ->
 529                 true
 530         ;       debug_event(State,Event)
 531         ).
 532
 533 chr_trace :-
 534         nb_setval(chr_debug,mutable(trace)).
 535 chr_notrace :-
 536         nb_setval(chr_debug,mutable(off)).
 537
 538 %       chr_leash(+Spec)
 539 %
 540 %       Define the set of ports at which we prompt for user interaction
 541
 542 chr_leash(Spec) :-
 543         leashed_ports(Spec, Ports),
 544         nb_setval(chr_leash,mutable(Ports)).
 545
 546 leashed_ports(none, []).
 547 leashed_ports(off,  []).
 548 leashed_ports(all,  [call, exit, redo, fail, wake, try, apply, insert, remove]).
 549 leashed_ports(default, [call,exit,fail,wake,apply]).
 550 leashed_ports(One, Ports) :-
 551         atom(One), One \== [], !,
 552         leashed_ports([One], Ports).
 553 leashed_ports(Set, Ports) :-
 554         sort(Set, Ports),               % make unique
 555         leashed_ports(all, All),
 556         valid_ports(Ports, All).
 557
 558 valid_ports([], _).
 559 valid_ports([H|T], Valid) :-
 560         (   memberchk(H, Valid)
 561         ->  true
 562         ;   throw(error(domain_error(chr_port, H), _))
 563         ),
 564         valid_ports(T, Valid).
 565
 566
 567 :- initialization
 568    leashed_ports(default, Ports),
 569    nb_setval(chr_leash, mutable(Ports)).
 570
 571 %       debug_event(+State, +Event)
 572
 573
 574 %debug_event(trace, Event) :-
 575 %       functor(Event, Name, Arity),
 576 %       writeln(Name/Arity), fail.
 577 debug_event(trace,Event) :-
 578         Event = call(_), !,
 579         get_debug_history(History,Depth),
 580         NDepth is Depth + 1,
 581         chr_debug_interact(Event,NDepth),
 582         set_debug_history([Event|History],NDepth).
 583 debug_event(trace,Event) :-
 584         Event = wake(_), !,
 585         get_debug_history(History,Depth),
 586         NDepth is Depth + 1,
 587         chr_debug_interact(Event,NDepth),
 588         set_debug_history([Event|History],NDepth).
 589 debug_event(trace,Event) :-
 590         Event = redo(_), !,
 591         get_debug_history(_History, Depth),
 592         chr_debug_interact(Event, Depth).
 593 debug_event(trace,Event) :-
 594         Event = exit(_),!,
 595         get_debug_history([_|History],Depth),
 596         chr_debug_interact(Event,Depth),
 597         NDepth is Depth - 1,
 598         set_debug_history(History,NDepth).
 599 debug_event(trace,Event) :-
 600         Event = fail(_),!,
 601         get_debug_history(_,Depth),
 602         chr_debug_interact(Event,Depth).
 603 debug_event(trace, Event) :-
 604         Event = remove(_), !,
 605         get_debug_history(_,Depth),
 606         chr_debug_interact(Event, Depth).
 607 debug_event(trace, Event) :-
 608         Event = insert(_), !,
 609         get_debug_history(_,Depth),
 610         chr_debug_interact(Event, Depth).
 611 debug_event(trace, Event) :-
 612         Event = try(_,_,_,_), !,
 613         get_debug_history(_,Depth),
 614         chr_debug_interact(Event, Depth).
 615 debug_event(trace, Event) :-
 616         Event = apply(_,_,_,_), !,
 617         get_debug_history(_,Depth),
 618         chr_debug_interact(Event,Depth).
 619
 620 debug_event(skip(_,_),Event) :-
 621         Event = call(_), !,
 622         get_debug_history(History,Depth),
 623         NDepth is Depth + 1,
 624         set_debug_history([Event|History],NDepth).
 625 debug_event(skip(_,_),Event) :-
 626         Event = wake(_), !,
 627         get_debug_history(History,Depth),
 628         NDepth is Depth + 1,
 629         set_debug_history([Event|History],NDepth).
 630 debug_event(skip(SkipSusp,SkipDepth),Event) :-
 631         Event = exit(Susp),!,
 632         get_debug_history([_|History],Depth),
 633         ( SkipDepth == Depth,
 634           SkipSusp == Susp ->
 635                 set_chr_debug(trace),
 636                 chr_debug_interact(Event,Depth)
 637         ;
 638                 true
 639         ),
 640         NDepth is Depth - 1,
 641         set_debug_history(History,NDepth).
 642 debug_event(skip(_,_),_) :- !,
 643         true.
 644
 645 %       chr_debug_interact(+Event, +Depth)
 646 %
 647 %       Interact with the user on Event that took place at Depth.  First
 648 %       calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
 649 %       fails the event is printed and the system prompts for a command.
 650
 651 chr_debug_interact(Event, Depth) :-
 652         chr:debug_interact(Event, Depth, Command), !,
 653         handle_debug_command(Command,Event,Depth).
 654 chr_debug_interact(Event, Depth) :-
 655         print_event(Event, Depth),
 656         (   leashed(Event)
 657         ->  ask_continue(Command)
 658         ;   Command = creep
 659         ),
 660         handle_debug_command(Command,Event,Depth).
 661
 662 leashed(Event) :-
 663         functor(Event, Port, _),
 664         nb_getval(chr_leash, mutable(Ports)),
 665         memberchk(Port, Ports).
 666
 667 ask_continue(Command) :-
 668         print_message(debug, chr(prompt)),
 669         get_single_char(CharCode),
 670         (   CharCode == -1
 671         ->  Char = end_of_file
 672         ;   char_code(Char, CharCode)
 673         ),
 674         (   debug_command(Char, Command)
 675         ->  print_message(debug, chr(command(Command)))
 676         ;   print_message(help, chr(invalid_command)),
 677             ask_continue(Command)
 678         ).
 679
 680
 681 'chr debug command'(Char, Command) :-
 682         debug_command(Char, Command).
 683
 684 debug_command(c, creep).
 685 debug_command(' ', creep).
 686 debug_command('\r', creep).
 687 debug_command(s, skip).
 688 debug_command(g, ancestors).
 689 debug_command(n, nodebug).
 690 debug_command(a, abort).
 691 debug_command(f, fail).
 692 debug_command(b, break).
 693 debug_command(?, help).
 694 debug_command(h, help).
 695 debug_command(end_of_file, exit).
 696
 697
 698 handle_debug_command(creep,_,_) :- !.
 699 handle_debug_command(skip, Event, Depth) :- !,
 700         Event =.. [Type|Rest],
 701         ( Type \== call,
 702           Type \== wake ->
 703                 handle_debug_command('c',Event,Depth)
 704         ;
 705                 Rest = [Susp],
 706                 set_chr_debug(skip(Susp,Depth))
 707         ).
 708
 709 handle_debug_command(ancestors,Event,Depth) :- !,
 710         print_chr_debug_history,
 711         chr_debug_interact(Event,Depth).
 712 handle_debug_command(nodebug,_,_) :- !,
 713         chr_notrace.
 714 handle_debug_command(abort,_,_) :- !,
 715         abort.
 716 handle_debug_command(exit,_,_) :- !,
 717         halt.
 718 handle_debug_command(fail,_,_) :- !,
 719         fail.
 720 handle_debug_command(break,Event,Depth) :- !,
 721         break,
 722         chr_debug_interact(Event,Depth).
 723 handle_debug_command(help,Event,Depth) :- !,
 724         print_message(help, chr(debug_options)),
 725         chr_debug_interact(Event,Depth).
 726 handle_debug_command(Cmd, _, _) :-
 727         throw(error(domain_error(chr_debug_command, Cmd), _)).
 728
 729 print_chr_debug_history :-
 730         get_debug_history(History,Depth),
 731         print_message(debug, chr(ancestors(History, Depth))).
 732
 733 print_event(Event, Depth) :-
 734         print_message(debug, chr(event(Event, Depth))).
 735
 736 %       {set,get}_debug_history(Ancestors, Depth)
 737 %
 738 %       Set/get the list of ancestors and the depth of the current goal.
 739
 740 get_debug_history(History,Depth) :-
 741         nb_getval(chr_debug_history,mutable(History,Depth)).
 742
 743 set_debug_history(History,Depth) :-
 744         nb_getval(chr_debug_history,Mutable),
 745         setarg(1,Mutable,History),
 746         setarg(2,Mutable,Depth).
 747
 748 set_chr_debug(State) :-
 749         nb_getval(chr_debug,Mutable),
 750         setarg(1,Mutable,State).
 751
 752 'chr chr_indexed_variables'(Susp,Vars) :-
 753         Susp =.. [_,_,_,_,_,_,_|Args],
 754         term_variables(Args,Vars).