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_trace/0,
 112             chr_notrace/0,
 113             chr_leash/1
 114           ]).
 115 :- set_prolog_flag(generate_debug_info, false).
 116
 117 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 118
 119 :- use_module(library(assoc)).
 120 :- use_module(hprolog).
 121 :- use_module(library(lists)).
 122 :- include(chr_op).
 123
 124 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 125
 126 %   I N I T I A L I S A T I O N
 127
 128 ?- initialization                       % SWI
 129    nb_setval(id,0).
 130
 131 ?- initialization                       % SWI
 132    nb_setval(chr_global,_).
 133
 134 ?- initialization
 135    nb_setval(chr_debug,mutable(off)).
 136
 137 ?- initialization
 138    nb_setval(chr_debug_history,mutable([],0)).
 139
 140 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 141 'chr merge_attributes'( As, Bs, Cs) :-
 142         sbag_union(As,Bs,Cs).
 143
 144 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 145 'chr run_suspensions'( Slots) :-
 146             run_suspensions( Slots).
 147
 148 'chr run_suspensions_loop'([]).
 149 'chr run_suspensions_loop'([L|Ls]) :-
 150         run_suspensions(L),
 151         'chr run_suspensions_loop'(Ls).
 152
 153 run_suspensions([]).
 154 run_suspensions([S|Next] ) :-
 155         arg( 2, S, Mref),
 156         Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
 157         ( Status==active ->
 158             update_mutable( triggered, Mref),
 159             arg( 4, S, Gref),
 160             Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
 161             Generation is Gen+1,
 162             update_mutable( Generation, Gref),
 163             arg( 3, S, Goal),
 164             call( Goal),
 165                                                 % get_mutable( Post, Mref), % XXX Inlined
 166             ( Mref = mutable(triggered) ->      % Post==triggered ->
 167                 update_mutable( removed, Mref)
 168             ;
 169                 true
 170             )
 171         ;
 172             true
 173         ),
 174         run_suspensions( Next).
 175
 176 'chr run_suspensions_d'( Slots) :-
 177             run_suspensions_d( Slots).
 178
 179 'chr run_suspensions_loop_d'([]).
 180 'chr run_suspensions_loop_d'([L|Ls]) :-
 181         run_suspensions_d(L),
 182         'chr run_suspensions_loop_d'(Ls).
 183
 184 run_suspensions_d([]).
 185 run_suspensions_d([S|Next] ) :-
 186         arg( 2, S, Mref),
 187         Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
 188         ( Status==active ->
 189             update_mutable( triggered, Mref),
 190             arg( 4, S, Gref),
 191             Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
 192             Generation is Gen+1,
 193             update_mutable( Generation, Gref),
 194             arg( 3, S, Goal),
 195             (
 196                 'chr debug_event'(wake(S)),
 197                 call( Goal)
 198             ;
 199                 'chr debug_event'(fail(S)), !,
 200                 fail
 201             ),
 202             (
 203                 'chr debug_event'(exit(S))
 204             ;
 205                 'chr debug_event'(redo(S)),
 206                 fail
 207             ),
 208                                                 % get_mutable( Post, Mref), % XXX Inlined
 209             ( Mref = mutable(triggered) ->      % Post==triggered ->
 210                 update_mutable( removed, Mref)
 211             ;
 212                 true
 213             )
 214         ;
 215             true
 216         ),
 217         run_suspensions_d( Next).
 218 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 219 locked:attr_unify_hook(_,_) :- fail.
 220
 221 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 222 'chr lock'(T) :-
 223         lock(T).
 224
 225 'chr unlock'(T) :-
 226         unlock(T).
 227
 228 'chr not_locked'(T) :-
 229         not_locked(T).
 230
 231 lock(T) :-
 232         ( var(T)
 233         -> put_attr(T, locked, x)
 234         ;  term_variables(T,L),
 235            lockv(L)
 236         ).
 237
 238 lockv([]).
 239 lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
 240
 241 unlock(T) :-
 242         ( var(T)
 243         -> del_attr(T, locked)
 244         ;  term_variables(T,L),
 245            unlockv(L)
 246         ).
 247
 248 unlockv([]).
 249 unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
 250
 251 'chr none_locked'( []).
 252 'chr none_locked'( [V|Vs]) :-
 253         not_locked( V),
 254         'chr none_locked'( Vs).
 255
 256 not_locked( V) :-
 257         ( var( V) ->
 258                 ( get_attr( V, locked, _) ->
 259                         fail
 260                 ;
 261                         true
 262                 )
 263         ;
 264                 true
 265         ).
 266
 267 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 268 %
 269 % Eager removal from all chains.
 270 %
 271 'chr remove_constraint_internal'( Susp, Agenda) :-
 272         arg( 2, Susp, Mref),
 273         Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
 274         update_mutable( removed, Mref),         % mark in any case
 275         ( compound(State) ->                    % passive/1
 276             Agenda = []
 277         ; State==removed ->
 278             Agenda = []
 279         %; State==triggered ->
 280         %     Agenda = []
 281         ;
 282             Susp =.. [_,_,_,_,_,_,_|Args],
 283             term_variables( Args, Vars),
 284             global_term_ref_1( Global),
 285             Agenda = [Global|Vars]
 286         ).
 287
 288 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 289 'chr via_1'(X,V) :-
 290         ( var(X) ->
 291                 X = V
 292         ; atomic(X) ->
 293                 global_term_ref_1(V)
 294         ; nonground(X,V) ->
 295                 true
 296         ;
 297                 global_term_ref_1(V)
 298         ).
 299 % 'chr via_1'( X, V) :- var(X), !, X=V.
 300 % 'chr via_1'( T, V) :- compound(T), nonground( T, V), ! .
 301 % 'chr via_1'( _, V) :- global_term_ref_1( V).
 302
 303 'chr via_2'(X,Y,V) :-
 304         ( var(X) ->
 305                 X = V
 306         ; var(Y) ->
 307                 Y = V
 308         ; compound(X), nonground(X,V) ->
 309                 true
 310         ; compound(Y), nonground(Y,V) ->
 311                 true
 312         ;
 313                 global_term_ref_1(V)
 314         ).
 315 % 'chr via_2'( X, _, V) :- var(X), !, X=V.
 316 % 'chr via_2'( _, Y, V) :- var(Y), !, Y=V.
 317 % 'chr via_2'( T, _, V) :- compound(T), nonground( T, V), ! .
 318 % 'chr via_2'( _, T, V) :- compound(T), nonground( T, V), ! .
 319 % 'chr via_2'( _, _, V) :- global_term_ref_1( V).
 320
 321 %
 322 % The second arg is a witness.
 323 % The formulation with term_variables/2 is
 324 % cycle safe, but it finds a list of all vars.
 325 % We need only one, and no list in particular.
 326 %
 327 'chr via'(L,V) :-
 328         ( nonground(L,V) ->
 329                 true
 330         ;
 331                 global_term_ref_1(V)
 332         ).
 333
 334 nonground( Term, V) :-
 335         term_variables( Term, Vs),
 336         Vs = [V|_].
 337
 338 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 339 'chr novel_production'( Self, Tuple) :-
 340         arg( 5, Self, Ref),
 341         Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
 342         ( get_assoc( Tuple, History, _) ->
 343             fail
 344         ;
 345             true
 346         ).
 347
 348 %
 349 % Not folded with novel_production/2 because guard checking
 350 % goes in between the two calls.
 351 %
 352 'chr extend_history'( Self, Tuple) :-
 353         arg( 5, Self, Ref),
 354         Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
 355         put_assoc( Tuple, History, x, NewHistory),
 356         update_mutable( NewHistory, Ref).
 357
 358 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 359 constraint_generation( Susp, State, Generation) :-
 360         arg( 2, Susp, Mref),
 361         Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
 362         arg( 4, Susp, Gref),
 363         Gref = mutable(Generation). % get_mutable( Generation, Gref).   % not incremented meanwhile % XXX Inlined
 364
 365 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 366 'chr allocate_constraint'( Closure, Self, F, Args) :-
 367         'chr empty_history'( History),
 368         create_mutable( passive(Args), Mref),
 369         create_mutable( 0, Gref),
 370         create_mutable( History, Href),
 371         'chr gen_id'( Id),
 372         Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
 373
 374 %
 375 % 'chr activate_constraint'( -, +, -).
 376 %
 377 % The transition gc->active should be rare
 378 %
 379 'chr activate_constraint'( Vars, Susp, Generation) :-
 380         arg( 2, Susp, Mref),
 381         Mref = mutable(State), % get_mutable( State, Mref),  % XXX Inlined
 382         update_mutable( active, Mref),
 383         ( nonvar(Generation) ->                 % aih
 384             true
 385         ;
 386             arg( 4, Susp, Gref),
 387             Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
 388             Generation is Gen+1,
 389             update_mutable( Generation, Gref)
 390         ),
 391         ( compound(State) ->                    % passive/1
 392             term_variables( State, Vs),
 393             'chr none_locked'( Vs),
 394             global_term_ref_1( Global),
 395             Vars = [Global|Vs]
 396         ; State==removed ->                     % the price for eager removal ...
 397             Susp =.. [_,_,_,_,_,_,_|Args],
 398             term_variables( Args, Vs),
 399             global_term_ref_1( Global),
 400             Vars = [Global|Vs]
 401         ;
 402             Vars = []
 403         ).
 404
 405 'chr insert_constraint_internal'( [Global|Vars], Self, Closure, F, Args) :-
 406         term_variables( Args, Vars),
 407         'chr none_locked'( Vars),
 408         global_term_ref_1( Global),
 409         'chr empty_history'( History),
 410         create_mutable( active, Mref),
 411         create_mutable( 0, Gref),
 412         create_mutable( History, Href),
 413         'chr gen_id'( Id),
 414         Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
 415
 416 insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
 417         term_variables( Term, Vars),
 418         'chr none_locked'( Vars),
 419         global_term_ref_1( Global),
 420         'chr empty_history'( History),
 421         create_mutable( active, Mref),
 422         create_mutable( 0, Gref),
 423         create_mutable( History, Href),
 424         'chr gen_id'( Id),
 425         Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
 426
 427 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 428 change_state( Susp, State) :-
 429         arg( 2, Susp, Mref),
 430         update_mutable( State, Mref).
 431
 432 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 433 'chr empty_history'( E) :- empty_assoc( E).
 434
 435 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 436 'chr gen_id'( Id) :-
 437         incval( id, Id).
 438
 439 incval(id,Id) :-
 440         nb_getval(id,Id),
 441         NextId is Id + 1,
 442         nb_setval(id,NextId).
 443
 444 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 445 create_mutable(V,mutable(V)).
 446
 447 'chr get_mutable'(V, mutable(V)).
 448
 449 'chr update_mutable'(V,M) :-
 450         setarg(1,M,V).
 451
 452 get_mutable(V, mutable(V)).
 453
 454 update_mutable(V,M) :-
 455         setarg(1,M,V).
 456
 457 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 458 'chr global_term_ref_1'(X) :-
 459         global_term_ref_1(X).
 460
 461 global_term_ref_1(X) :-
 462         nb_getval(chr_global,X).
 463
 464 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 465
 466 'chr sbag_member'( Element, [Head|Tail]) :-
 467       sbag_member( Element, Tail, Head).
 468
 469 % auxiliary to avoid choicepoint for last element
 470
 471 sbag_member( E, _,           E).
 472 sbag_member( E, [Head|Tail], _) :-
 473         sbag_member( E, Tail, Head).
 474
 475 'chr sbag_del_element'( [],       _,    []).
 476 'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
 477         ( X==Elem ->
 478             Set2 = Xs
 479         ;
 480             Set2 = [X|Xss],
 481             'chr sbag_del_element'( Xs, Elem, Xss)
 482         ).
 483
 484 sbag_union( A, B, C) :-
 485         sbag_merge( A, B, C).
 486
 487 sbag_merge([],Ys,Ys).
 488 sbag_merge([X | Xs],YL,R) :-
 489   ( YL = [Y | Ys] ->
 490       arg(1,X,XId),
 491       arg(1,Y,YId),
 492        ( XId < YId ->
 493            R = [X | T],
 494            sbag_merge(Xs,YL,T)
 495        ; XId > YId ->
 496            R = [Y | T],
 497            sbag_merge([X|Xs],Ys,T)
 498        ;
 499            R = [X | T],
 500            sbag_merge(Xs,Ys,T)
 501        )
 502   ;
 503        R = [X | Xs]
 504   ).
 505
 506 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 507
 508 :- multifile
 509         chr:debug_event/2,              % +State, +Event
 510         chr:debug_interact/3.           % +Event, +Depth, -Command
 511
 512 'chr debug_event'(Event) :-
 513         nb_getval(chr_debug,mutable(State)),
 514         ( State == off ->
 515                 true
 516         ; chr:debug_event(State, Event) ->
 517                 true
 518         ;       debug_event(State,Event)
 519         ).
 520
 521 chr_trace :-
 522         nb_setval(chr_debug,mutable(trace)).
 523 chr_notrace :-
 524         nb_setval(chr_debug,mutable(off)).
 525
 526 %       chr_leash(+Spec)
 527 %
 528 %       Define the set of ports at which we prompt for user interaction
 529
 530 chr_leash(Spec) :-
 531         leashed_ports(Spec, Ports),
 532         nb_setval(chr_leash,mutable(Ports)).
 533
 534 leashed_ports(none, []).
 535 leashed_ports(off,  []).
 536 leashed_ports(all,  [call, exit, redo, fail, wake, try, apply, insert, remove]).
 537 leashed_ports(default, [call,exit,fail,wake,apply]).
 538 leashed_ports(One, Ports) :-
 539         atom(One), One \== [], !,
 540         leashed_ports([One], Ports).
 541 leashed_ports(Set, Ports) :-
 542         sort(Set, Ports),               % make unique
 543         leashed_ports(all, All),
 544         valid_ports(Ports, All).
 545
 546 valid_ports([], _).
 547 valid_ports([H|T], Valid) :-
 548         (   memberchk(H, Valid)
 549         ->  true
 550         ;   throw(error(domain_error(chr_port, H), _))
 551         ),
 552         valid_ports(T, Valid).
 553
 554
 555 :- initialization
 556    leashed_ports(default, Ports),
 557    nb_setval(chr_leash, mutable(Ports)).
 558
 559 %       debug_event(+State, +Event)
 560
 561
 562 %debug_event(trace, Event) :-
 563 %       functor(Event, Name, Arity),
 564 %       writeln(Name/Arity), fail.
 565 debug_event(trace,Event) :-
 566         Event = call(_), !,
 567         get_debug_history(History,Depth),
 568         NDepth is Depth + 1,
 569         chr_debug_interact(Event,NDepth),
 570         set_debug_history([Event|History],NDepth).
 571 debug_event(trace,Event) :-
 572         Event = wake(_), !,
 573         get_debug_history(History,Depth),
 574         NDepth is Depth + 1,
 575         chr_debug_interact(Event,NDepth),
 576         set_debug_history([Event|History],NDepth).
 577 debug_event(trace,Event) :-
 578         Event = redo(_), !,
 579         get_debug_history(_History, Depth),
 580         chr_debug_interact(Event, Depth).
 581 debug_event(trace,Event) :-
 582         Event = exit(_),!,
 583         get_debug_history([_|History],Depth),
 584         chr_debug_interact(Event,Depth),
 585         NDepth is Depth - 1,
 586         set_debug_history(History,NDepth).
 587 debug_event(trace,Event) :-
 588         Event = fail(_),!,
 589         get_debug_history(_,Depth),
 590         chr_debug_interact(Event,Depth).
 591 debug_event(trace, Event) :-
 592         Event = remove(_), !,
 593         get_debug_history(_,Depth),
 594         chr_debug_interact(Event, Depth).
 595 debug_event(trace, Event) :-
 596         Event = insert(_), !,
 597         get_debug_history(_,Depth),
 598         chr_debug_interact(Event, Depth).
 599 debug_event(trace, Event) :-
 600         Event = try(_,_,_,_), !,
 601         get_debug_history(_,Depth),
 602         chr_debug_interact(Event, Depth).
 603 debug_event(trace, Event) :-
 604         Event = apply(_,_,_,_), !,
 605         get_debug_history(_,Depth),
 606         chr_debug_interact(Event,Depth).
 607
 608 debug_event(skip(_,_),Event) :-
 609         Event = call(_), !,
 610         get_debug_history(History,Depth),
 611         NDepth is Depth + 1,
 612         set_debug_history([Event|History],NDepth).
 613 debug_event(skip(_,_),Event) :-
 614         Event = wake(_), !,
 615         get_debug_history(History,Depth),
 616         NDepth is Depth + 1,
 617         set_debug_history([Event|History],NDepth).
 618 debug_event(skip(SkipSusp,SkipDepth),Event) :-
 619         Event = exit(Susp),!,
 620         get_debug_history([_|History],Depth),
 621         ( SkipDepth == Depth,
 622           SkipSusp == Susp ->
 623                 set_chr_debug(trace),
 624                 chr_debug_interact(Event,Depth)
 625         ;
 626                 true
 627         ),
 628         NDepth is Depth - 1,
 629         set_debug_history(History,NDepth).
 630 debug_event(skip(_,_),_) :- !,
 631         true.
 632
 633 %       chr_debug_interact(+Event, +Depth)
 634 %
 635 %       Interact with the user on Event that took place at Depth.  First
 636 %       calls chr:debug_interact(+Event, +Depth, -Command) hook. If this
 637 %       fails the event is printed and the system prompts for a command.
 638
 639 chr_debug_interact(Event, Depth) :-
 640         chr:debug_interact(Event, Depth, Command), !,
 641         handle_debug_command(Command,Event,Depth).
 642 chr_debug_interact(Event, Depth) :-
 643         print_event(Event, Depth),
 644         (   leashed(Event)
 645         ->  ask_continue(Command)
 646         ;   Command = creep
 647         ),
 648         handle_debug_command(Command,Event,Depth).
 649
 650 leashed(Event) :-
 651         functor(Event, Port, _),
 652         nb_getval(chr_leash, mutable(Ports)),
 653         memberchk(Port, Ports).
 654
 655 ask_continue(Command) :-
 656         print_message(debug, chr(prompt)),
 657         get_single_char(CharCode),
 658         (   CharCode == -1
 659         ->  Char = end_of_file
 660         ;   char_code(Char, CharCode)
 661         ),
 662         (   debug_command(Char, Command)
 663         ->  print_message(debug, chr(command(Command)))
 664         ;   print_message(help, chr(invalid_command)),
 665             ask_continue(Command)
 666         ).
 667
 668
 669 'chr debug command'(Char, Command) :-
 670         debug_command(Char, Command).
 671
 672 debug_command(c, creep).
 673 debug_command(' ', creep).
 674 debug_command('\r', creep).
 675 debug_command(s, skip).
 676 debug_command(g, ancestors).
 677 debug_command(n, nodebug).
 678 debug_command(a, abort).
 679 debug_command(f, fail).
 680 debug_command(b, break).
 681 debug_command(?, help).
 682 debug_command(h, help).
 683 debug_command(end_of_file, exit).
 684
 685
 686 handle_debug_command(creep,_,_) :- !.
 687 handle_debug_command(skip, Event, Depth) :- !,
 688         Event =.. [Type|Rest],
 689         ( Type \== call,
 690           Type \== wake ->
 691                 handle_debug_command('c',Event,Depth)
 692         ;
 693                 Rest = [Susp],
 694                 set_chr_debug(skip(Susp,Depth))
 695         ).
 696
 697 handle_debug_command(ancestors,Event,Depth) :- !,
 698         print_chr_debug_history,
 699         chr_debug_interact(Event,Depth).
 700 handle_debug_command(nodebug,_,_) :- !,
 701         chr_notrace.
 702 handle_debug_command(abort,_,_) :- !,
 703         abort.
 704 handle_debug_command(exit,_,_) :- !,
 705         halt.
 706 handle_debug_command(fail,_,_) :- !,
 707         fail.
 708 handle_debug_command(break,Event,Depth) :- !,
 709         break,
 710         chr_debug_interact(Event,Depth).
 711 handle_debug_command(help,Event,Depth) :- !,
 712         print_message(help, chr(debug_options)),
 713         chr_debug_interact(Event,Depth).
 714 handle_debug_command(Cmd, _, _) :-
 715         throw(error(domain_error(chr_debug_command, Cmd), _)).
 716
 717 print_chr_debug_history :-
 718         get_debug_history(History,Depth),
 719         print_message(debug, chr(ancestors(History, Depth))).
 720
 721 print_event(Event, Depth) :-
 722         print_message(debug, chr(event(Event, Depth))).
 723
 724 %       {set,get}_debug_history(Ancestors, Depth)
 725 %
 726 %       Set/get the list of ancestors and the depth of the current goal.
 727
 728 get_debug_history(History,Depth) :-
 729         nb_getval(chr_debug_history,mutable(History,Depth)).
 730
 731 set_debug_history(History,Depth) :-
 732         nb_getval(chr_debug_history,Mutable),
 733         setarg(1,Mutable,History),
 734         setarg(2,Mutable,Depth).
 735
 736 set_chr_debug(State) :-
 737         nb_getval(chr_debug,Mutable),
 738         setarg(1,Mutable,State).
 739