1/*******************************************************************
    2 *
    3 * A Common Lisp compiler/interpretor, written in Prolog
    4 *
    5 * 8ball.pl 
    6 *
    7 * Douglas'' Notes:
    8 *
    9 * 8BALL is used to predict when failure and errors may occur
   10 *
   11 * (c) Douglas Miles, 2017
   12 *
   13 * The program is a *HUGE* common-lisp compiler/interpreter. It is written for YAP/SWI-Prolog .
   14 *
   15 *******************************************************************/
   16:- module('8ball', []).   17:- set_module(class(library)).   18
   19:- use_module(library(logicmoo_common)).   20
   21
   22di_test:- lisp_compile_to_prolog(pkg_user,
   23
   24                          [ defun,
   25                            'mapcar-visualize',
   26                            [func, l],
   27
   28                            [ if,
   29                              [null, l],
   30                              [],
   31
   32                              [ cons,
   33                                [apply, func, [list, [first, l]]],
   34                                [mapcar, func, [rest, l]]
   35                              ]
   36                            ]
   37                          ]).
   38
   39
   40
   41nonplainvar(V):- notrace(nonvar(V);attvar_non_vn(V)),!.
   42attvar_non_vn(V):- attvar(V),get_attr(V,searchvar,_),!.
   43attvar_non_vn(V):- attvar(V),copy_term(V,VV),del_attr(VV,vn),del_attr(VV,rwstate),del_attr(VV,varuse),
   44  (get_attrs(VV,[]);\+attvar(VV)).
   45
   46bind_breaks(More):- put_attr(More,bind_breaks,break).
   47:- meta_predicate bind_breaks:attr_unify_hook(0,*).   48bind_breaks:attr_unify_hook(G,_):-G.
   49
   50lisp_dump_break:- both_outputs(dumpST),!,trace,!,throw(lisp_dump_break).
   51%lisp_dump_break:- trace,throw(lisp_dump_break).
   52lisp_dump_break:- lisp_dumpST,!,break.
   53lisp_dumpST:- both_outputs(dumpST).
   54
   55true_or_die(Goal):-functor(Goal,_,A),arg(A,Goal,Ret),always((Goal,Ret\==[])).
   56
   57always_skip_always:- true.
   58
   59% Must offer_rtrace succeed (or else there is a bug in the lisp impl!)
   60offer_rtrace((A->B;C)):- !, (A-> offer_rtrace(B);offer_rtrace(C)).
   61offer_rtrace((A,!,B)):-!,offer_rtrace(A),!,offer_rtrace(B).
   62offer_rtrace((A,B)):-!,offer_rtrace(A),offer_rtrace(B).
   63offer_rtrace(notrace(G)):- !, quietly_must_or_rtrace(G).
   64offer_rtrace(always(G)):-!,offer_rtrace(G).
   65offer_rtrace(rtrace(G)):-!,offer_rtrace(G).
   66offer_rtrace(call(G)):-!,offer_rtrace(G).
   67offer_rtrace(G):-slow_trace,trace,maybe_trace(G).
   68
   69maybe_trace(G):- notrace(tracing)->user:rtrace(G);show_call_trace(user:G).
   70/*offer_rtrace(G):- notrace(tracing),!,( G -> true; (dbginfo(failed(G)),dumpST,dbginfo(failed(G)),break,G,!,fail)),!.
   71offer_rtrace(G):- !,( G-> true; (dbginfo(failed(G)),dumpST,dbginfo(failed(G)),trace,G,!,fail)),!.
   72%offer_rtrace(G):- notrace(tracing),!,(G->true;break). % nonquietly_must_or_rtrace(G).
   73offer_rtrace(G):- nonquietly_must_or_rtrace(G),!.
   74*/
   75
   76length_safe(X,Y):- catch(length(X,Y),E,(dmsg(length(X,Y)=E),break)).
   77
   78% Must certainly succeed (or else there is a bug in the users code!)
   79certainly((A,B)):-!,certainly(A),certainly(B).
   80% certainly(notrace(G)):- !, quietly_must_or_rtrace(G).
   81certainly(G):- notrace(tracing),!,G. % nonquietly_must_or_rtrace(G).
   82certainly(G):- nonquietly_must_or_rtrace(G).
   83
   84always_catch(G):- catch(catch(G,'$aborted',notrace),E,(dbginfo(always_uncaught(E)),notrace,!,fail)).
   85with_nat_term(G):-
   86  \+ \+ ((
   87  (term_attvars(G,Vs),
   88    maplist(del_attr_rev2(freeze),Vs),
   89    maplist(del_attr_rev2(tracker),Vs),
   90   G))).
   91
   92quietly_must_or_rtrace(G):-  
   93  (catch((G),E,gripe_problem(uncaught(E),(rtrace(G),!,fail)))
   94   *-> true ; (gripe_problem(fail_must_or_rtrace_failed,G),!,fail)),!.
   95
   96nonquietly_must_or_rtrace(MG):- always_skip_always,!,call(MG).
   97nonquietly_must_or_rtrace(MG):- 
   98  strip_module(MG,M,G),
   99   dinterp(w_tr_lvl(_),M, Cut ,  G, 0 ),
  100   (callable(Cut)->(!,call(Cut));true).
  101
  102:- '$hide'(lquietly/1).  103lquietly(G):- quietly((G)).
  104
  105slow_trace:- stop_rtrace,nortrace,trace,wdmsg(slow_trace).
  106on_x_rtrace(G):- catch(G,E,(dbginfo(E),rtrace(G),break)).
  107
  108
  109
  110% nonquietly_must_or_rtrace
  111nmot1 :- true,true,fail,true.
  112
  113nmot2 :- true,true,call_fail,true.
  114
  115call_fail:- dmsg(fail),fail.
  116
  117incr_arg(N,Redo):- arg(N,Redo,Val),ValNext is 1 + Val,nb_setarg(N,Redo,ValNext).
  118
  119
  120show_call_trace(Info,Goal):-
  121  Redo = sol(0,0),
  122  dmsg(call:Info),!, 
  123  ( ((call((Goal,deterministic(YN))),
  124      nb_setarg(Redo,2,YN),
  125      (YN==yes -> dmsg(exit_det:Info);dmsg(exit_nd:Info)))) 
  126   *-> 
  127      (incr_arg(1,Redo);((arg(1,Redo,Stage),dmsg(Stage:Info),fail)))
  128   ;
  129  dmsg(fail(Redo):Info)),
  130
  131  (Redo == sol(0,0) -> (!,fail) ; (Redo=sol(_,yes) -> ! ; true)).
  132
  133:- export(((always)/1)).  134:- module_transparent(((always)/1)).  135% Must always succeed (or else there is a bug in the lisp impl!)
  136always(Var):- notrace(var(Var)),!,throw(var_always(Var)).
  137always([]):-!.
  138always([A|B]):-!,always(A),always(B),!.
  139%always(MG):- strip_module(MG,M,G),!,rtrace(M:G).
  140
  141always(MG):- always_skip_always, !, (call(MG) *->true;throw(failed_always(MG))).
  142/*
  143always(MG):- copy_term(MG,MGC),call(MG),once(always_borked(MGC)).
  144always_borked(MG):-
  145  strip_module(MG,M,G),
  146   w_dinterp(true,dinterp(w_tr_lvl(_),M, Cut , G, 0 )),
  147(callable(Cut)->(!,call(Cut));true).
  148*/
  149
  150/*
  151
  152always((A->B;C)):- !, (on_x_rtrace(user:A) -> always(B);always(C)).
  153always((A*->B;C)):- !, (on_x_rtrace(user:A) *-> always(B);always(C)).
  154always((A,!,B)):-!,always(A),!,always(B).
  155always((A,B)):-!,always(A),always(B).
  156always(always(G)):-!,always(G).
  157always(call(G)):-!,always(G).
  158always(notrace(G)):- !, quietly_must_or_rtrace(G),!.
  159always(G):- nonquietly_must_or_rtrace(G),!.
  160*/
  161%always(notrace(G)):- notrace(tracing),!, m(0)(quietly(user:G)),!.
  162%always(quietly(G)):- notrace(tracing),!, always(user:G).
  163
  164cross_cut(_Cut,_Cut2).
  165
  166%always(G):- !,(G-> true; (dbginfo(failed(G)),dumpST,dbginfo(failed(G)),trace,G,!,fail)),!.
  167%always(G):- notrace(tracing),!,(G->true;break). % nonquietly_must_or_rtrace(G).
  168:- module_transparent(dinterp/5).  169%dinterp(Must,M,Cut,G,L):-L > -1,!,M:call(G).
  170dinterp(Must,N,Cut,M:G,L):-!,assertion(callable(G)),N:dinterp(Must,M,Cut,G,L).
  171%dinterp(Must,_,_,compound_name_arity(G,F,A),_Level):-!,compound_name_arity(G,F,A).
  172%dinterp(Must,_,_,is_functionp(G),_Level):-!,rtrace(is_functionp(G)).
  173dinterp(_,_,_,true,_):-!.
  174dinterp(_Must,_M, Cut, (!),_):-!,(nonvar(Cut)->true;Cut=!).
  175
  176% dinterp(Must,M,Cut, G,L):- notrace(tracing),!,notrace,call_cleanup(dinterp(tracing(Must),M,Cut,G,L),trace).
  177dinterp(Must,M,Cut,call(G),L):- cross_cut(Cut,Cut2),!,dinterp(Must,M,Cut2,G,L) .
  178dinterp(_Must,_M,_Cut,dbginfo(G),_L):-!,dbginfo(G),!.
  179dinterp(_Must,_M,_Cut,compound(G),_L):-!,compound(G),!.
  180
  181dinterp(Must,M,Cut,(repeat,G),L):- cross_cut(Cut,Cut2),!,repeat,dinterp(Must,M,Cut2,G,L),(callable(Cut2)->(!,call(Cut2));true),(callable(Cut)->(!,call(Cut));true).
  182
  183%dinterp(_Must,_M, Cut,CutFail,_L):- CutFail==(!,fail),!,ignore(Cut=fail),!.
  184dinterp(_Must,_M,_Cut,fail,_):- !,fail.
  185
  186
  187dinterp(Must,M,Cut,once(G),L):-!,cross_cut(Cut,Cut2),dinterp(Must,M,Cut2,G,L),!.
  188
  189dinterp(Must,M,Cut, ( \+ \+ G),L):- L2 is L +1, cross_cut(Cut,Cut2), !, \+ \+ dinterp(Must,M,Cut2,G,L2).
  190dinterp(Must,M,Cut, ( \+ G),L):- L2 is L +1, cross_cut(Cut,Cut2), !, \+ dinterp(Must,M,Cut2,G,L2).
  191dinterp(Must,M,Cut,  not(G),L):- L2 is L +1, cross_cut(Cut,Cut2), !, \+ dinterp(Must,M,Cut2,G,L2).
  192
  193dinterp(Must,M,Cut,(Cond *-> Then ; Else),L):-!,L2 is L +1,
  194   (dinterp(Must,M,Cut,Cond,L2) *-> dinterp(Must,M,Cut,Then,L) ; dinterp(Must,M,Cut,Else,L)).
  195dinterp(Must,M,Cut,(Cond  -> Then ; Else),L):-!,L2 is L +1,
  196   (dinterp(Must,M,Cut,Cond,L2) -> dinterp(Must,M,Cut,Then,L) ; dinterp(Must,M,Cut,Else,L)).
  197
  198dinterp(Must,M,Cut,(Cond  -> Then),L):-!, (dinterp(Must,M,Cut,Cond,L) -> dinterp(Must,M,Cut,Then,L)).
  199
  200dinterp(Must,M,Cut,(Cond *-> Then),L):-!, (dinterp(Must,M,Cut,Cond,L)*-> dinterp(Must,M,Cut,Then,L)).
  201
  202dinterp(Must,M,Cut,(GoalsL;GoalsR),L):-!,L2 is L +1,
  203   (dinterp(Must,M,Cut,GoalsL,L2);dinterp(Must,M,Cut,GoalsR,L)).
  204
  205dinterp(Must,M,Cut,(Goals1,Goals2),L):- !,          
  206  (dinterp(Must,M,Cut,Goals1,L ),dinterp(Must,M,Cut,Goals2,L)).
  207
  208dinterp(_Must,M,_Cut, always(G),_):- !, always(M:G). % cross_cut(Cut,Cut2),!,dinterp(Must,M,Cut2,G,0),!.
  209dinterp(_Must,M,_Cut, must(G),_):- !, always(M:G).
  210dinterp(_Must,M,_Cut, call_call(G),_):- !, call(M:G).
  211dinterp(_Must,M,_Cut, call(call,G),_):- !, call(M:G).
  212% RESOTRE  dinterp(Must,M,Cut,  must(G),_):- cross_cut(Cut,Cut2),!,dinterp(Must,M,Cut2,G,0),!.
  213dinterp(Must,M,Cut,lquietly(G),L):- cross_cut(Cut,Cut2),!,quietly(dinterp(Must,M,Cut2,G,L)).
  214% RESOTRE dinterp(Must,M,Cut, quietly(G),L):-!,quietly(dinterp(Must,M,Cut,G,L)).
  215%dinterp(Must,M,Cut, quietly(G),L):-!,quietly(dinterp(Must,M,Cut,G,L)).
  216dinterp(Must,M,Cut, quietly(G),L):- cross_cut(Cut,Cut2),!, dinterp(Must,M,Cut2,G,L).
  217% RESOTRE  dinterp(Must,M,Cut, notrace(G),L):-!,quietly(dinterp(Must,M,Cut,G,L)).
  218dinterp(Must,M,Cut, notrace(G),L):- !, %wo_trace
  219   (((cross_cut(Cut,Cut2), dinterp(Must,M,Cut2,G,L)))).
  220dinterp(Must,M,Cut,findall(Template,G,Bag),L):-cross_cut(Cut,Cut2),!,L2 is L +1,findall(Template,dinterp(Must,M,Cut2,G,L2),Bag).
  221dinterp(Must,M,Cut,call_cleanup(G,Cleanup),L):-cross_cut(Cut,Cut2),!,call_cleanup(dinterp(Must,M,Cut2,G,L),Cleanup).
  222
  223
  224%wo_trace
  225% RESOTRE dinterp(Must,M,Cut,setup_call_cleanup(S,G,Cleanup),L):- cross_cut(Cut,Cut2),cross_cut(Cut,Cut3),!,setup_call_cleanup(dinterp(Must,M,_Cut,S,L),dinterp(Must,M,Cut2,G,L),dinterp(Must,M,Cut3,Cleanup,L)).
  226
  227
  228dinterp(_Must,M,_Cut,catch(G,E,F),_L):- !,M:catch(G,E,F).
  229
  230% RESOTRE dinterp(Must,M,Cut,catch(G,E,F),L):-cross_cut(Cut,Cut2),cross_cut(Cut,Cut3),!,catch(dinterp(Must,M,Cut2,G,L),E,dinterp(Must,M,Cut3,F,L)).
  231%d  i nterp(_,Cut,!,_):-!,(var(Cut);Cut=!).
  232
  233dinterp(Must,M,Cut,CallN,L):- 
  234  notrace((fix_callables(CallN,CallNew)->CallN\=@=CallNew)),!,
  235  dinterp(Must,M,Cut,CallNew,L).
  236
  237%dinterp(_Must,M,_Cut,Goal,_L):- notrace(tracing),!,M:call(M:Goal).
  238dinterp(Must,M,Cut,Goal,L):- dinterp_c(Must,M,Cut,Goal,L).
  239
  240
  241fix_callables(Atom,Atom):- \+ compound(Atom),!.
  242fix_callables(call(In),Out):- !, fix_callables(In,Out).
  243fix_callables(\+ (In), \+ Out):- !, fix_callables(In,Out).
  244fix_callables(apply(F,ARGS),NewCall2):- !, assertion(callable(F)),
  245   F=..FL,append(FL,ARGS,NewCallL),NewCall=..NewCallL,!,fix_callables(NewCall,NewCall2).
  246fix_callables(CallN,NewCall2):- CallN=..[call,F|ARGS],!,assertion(callable(F)),
  247   F=..FL,append(FL,ARGS,NewCallL),NewCall=..NewCallL,!,fix_callables(NewCall,NewCall2).
  248fix_callables(NewCall,NewCall).
  249
  250:- meta_predicate(wo_trace(0)).  251wo_trace(G):- !, call(G).
  252%wo_trace(G):- notrace(tracing)->each_call_cleanup(notrace,G,notrace(trace)); call(G).
  253/*
  254wo_trace(G):- !, 
  255  (notrace(tracing)->
  256   (visible(-all),visible(+exception),leash(-all),leash(+exception),call_cleanup(G,(visible(+full),leash(+full))));
  257    call(G)).
  258%wo_trace(G):- notrace(tracing)->(visible(-all),visible(+exception),call_cleanup(G,(visible(+full),leash(+full))));call(G).
  259%wo_trace(G):- notrace(tracing)->(visible(-all),visible(+exception),call_cleanup(G,(visible(+full),leash(+full))));call(G).
  260*/
  261dinterp_c(Must,M,Cut, G,L):-  notrace((fail,tracing)),!,  
  262  wo_trace(dinterp_c(tracing(Must),M,Cut,G,L)),
  263(callable(Cut)->(!,call(Cut));true).
  264
  265dinterp_c(tracing(Must),M,Cut, G,L):- !, 
  266  show_call_trace((Must->M:G),dinterp_d(Must,M,Cut, G,L)),
  267(callable(Cut)->(!,call(Cut));true).
  268
  269dinterp_c(Must,M,Cut,G,Level):-   
  270  notrace((Must = rtrace(TraceLvl), Level==TraceLvl,
  271  next_trace_level(Must,_NewTraceLevel))),!,
  272   rtrace(M:G),
  273(callable(Cut)->(!,call(Cut));true).
  274
  275
  276dinterp_c(Must,M,Cut,G,Level):-
  277  notrace((compound(Must),arg(1,Must,TraceLvl),Level==TraceLvl, !,     
  278   next_trace_level(Must,NextMust))),
  279   show_call_trace((Must->M:G),dinterp_d(NextMust,M,Cut,G,Level)),
  280(callable(Cut)->(!,call(Cut));true).
  281
  282dinterp_c(Must,M,Cut,G, Level):-
  283  next_trace_level(Must,NextMust),
  284  dinterp_d(NextMust,M,Cut,G, Level),
  285(callable(Cut)->(!,call(Cut));true).
  286
  287/*
  288*/
  289
  290dinterp_d(Must,M,Cut,G,L):- 
  291  (compound(G)->
  292    (compound_name_arity(G,F,A),compound_name_arity(GG,F,A)) ;
  293    GG =G),
  294 dinterp_e(Must,M,Cut,G,GG,L),
  295(callable(Cut)->(!,call(Cut));true).
  296                         
  297/*
  298*/
  299
  300dinterp_e(_Must,M,_Cut,G, GG, _L):- 
  301  (((nb_current('$w_dinterp',false) ; just_call(M,GG)))),!,
  302  (call(M:G)).
  303% (callable(Cut)->(!,call(Cut));true).
  304%:- '$hide'(rtrace:trace).
  305%dinterp_e(_Must,M,_UnseenCut,G,_GG,_L):- !, rtrace(M:G).
  306dinterp_e(Must,M,_UnseenCut,G,GG,L):- 
  307   notrace((L2 is L -1,predicate_property(M:GG,number_of_clauses(_)))),!,
  308   (( M:clause(GG,Body), G=GG)),
  309   dinterp(Must,M,Cut2,Body,L2),
  310(callable(Cut2)->(!,call(Cut2));true).
  311
  312dinterp_e(_Must,M,Cut,G,GG,_L):- 
  313   predicate_property(M:GG,defined),!,
  314   M:call(M:G),
  315(callable(Cut)->(!,call(Cut));true).
  316
  317dinterp_e(Must,_M,Cut,G,GG,L):-  
  318  notrace(( current_module(MM),    
  319    predicate_property(MM:GG,number_of_clauses(_)),
  320    \+ predicate_property(MM:GG,imported_from(_)))),!,
  321  dmsg("Found Inaccessable predicate!"),
  322  trace,G=GG,dinterp_e(Must,MM,Cut,G,GG,L).
  323
  324dinterp_e(_Must,M,Cut,G,_GG,_L):- 
  325   M:on_x_rtrace(M:G),
  326(callable(Cut)->(!,call(Cut));true).
  327
  328next_trace_level(In,Out):- notrace((In=@=w_tr_lvl(_),In=Out)),!.
  329next_trace_level(In,Out):- compound(In),arg(1,In,Mid),!,
  330  next_trace_level(Mid,MidOut),ignore(In=Out),!,setarg(1,Out,MidOut).
  331next_trace_level(In,Out):- number(In),!, Out is In+1.
  332next_trace_level(In,In).
  333
  334
  335w_dinterp(V,G):- (nb_current('$w_dinterp',Was);Was=[]),!,
  336 ((V = Was) -> G ; 
  337    (b_setval('$w_dinterp',V),G,b_setval('$w_dinterp',Was))).
  338
  339just_call(_,G):- var(G),!.
  340just_call(_,=(_,_)):-!.
  341just_call(_,call_call(_)):-!.
  342just_call(_,G):- compound(G),functor(G,F,_),just_call_f(F),!.
  343just_call(M,G):- predicate_property(M:G,nodebug),!.
  344just_call(M,G):- M:predicate_property(_:G,nodebug),!.
  345just_call(M,G):- \+ \+ (predicate_property(M:G,meta_predicate(GG)),arg(_,GG,N),integer(N)),!.
  346just_call(M,G):-  predicate_property(M:G,number_of_clauses(_)),notrace(catch( (M:clause(G,_),fail), _, true)),!.
  347
  348
  349just_call_f('$sig_atomic').
  350%%just_call_f(maplist).
  351
  352%set_prolog_flag(gc,false),
  353just_call_f(F):- atom_concat(_,ii,F).
  354just_call_f(F):- atom_concat(atom_,_,F).
  355
  356just_call_f(F):- atom_concat(get_opv,_,F).
  357just_call_f(F):- atom_concat(nb_,_,F).
  358just_call_f(F):- atom_concat(package_,_,F).
  359just_call_f(F):- atom_concat(is_,_,F).
  360just_call_f(F):- atom_concat(dinterp,_,F).
  361just_call_f(F):- atom_concat(filter_var_chars,_,F).
  362
  363just_call_f(with_mutex).
  364just_call_f(flag).
  365just_call_f(is).
  366just_call_f(=).
  367just_call_f(call_call).
  368just_call_f(gensym).
  369
  370nonquietly_must_or_rtrace_now(G):- 
  371  (catch((G),E,gripe_problem(uncaught(E),(rtrace(G),!,fail)))
  372   *-> true ; (gripe_problem(fail_must_or_rtrace_failed,rtrace((slow_trace,G))),!,fail)),!.
  373
                        
  374
  375gripe_problem(Problem,G):- always_catch(gripe_problem0(Problem,(G))).
  376gripe_problem0(Problem,G):-
  377     notrace(( 
  378     dbginfo((Problem=G)),
  379     dumpST,
  380     dbginfo((Problem=G)))),
  381     nortrace,
  382     trace,!,
  383     lisp_dump_break,
  384     slow_trace,
  385     ((G)*->(slow_trace,lisp_dump_break);
  386       (dbginfo(warn(failed_rtrace(G))),notrace,lisp_dump_break,!,fail)).
  387
  388
  389:- meta_predicate(timel(+,:)).  390timel(_,MG):- wam_cl_option(call_statistics,false),!, call(MG).
  391timel(What,M:X):- notrace(( write('## '),write(What))),prolog_statistics:time(M:X).
  392
  393
  394% is_assert_op(_,_):-!,fail.
  395is_assert_op(A,B,C):- notrace(is_assert_op0(A,B,C)),!.
  396is_assert_op0(A,_,_):- \+ compound(A),!,fail.
  397is_assert_op0(M:I,W,M:O):- !, is_assert_op0(I,W,O).
  398is_assert_op0(assert_lsp(W,P),W,P).
  399is_assert_op0(assert_lsp(P),u,P).
  400is_assert_op0(assertz(P),u,P).
  401is_assert_op0(asserta(P),u,P).
  402is_assert_op0(assert(P),u,P).
  403is_assert_op0(asserta_if_new(P),u,P).
  404is_assert_op0(asserta_new(P),u,P).
  405is_assert_op0(assertz_if_new(P),u,P).
  406is_assert_op0(assertz_new(P),u,P).
  407is_assert_op0(assert_if_new(P),u,P).
  408
  409
  410fmt99(O):- in_md(prolog,always((make_pretty(O,P),fmt999(P)))),!.
  411
  412fmt999(P):- \+ compound(P),!,fmt9(P).
  413fmt999((:- M:P)):-
  414  with_output_to(string(A),fmt9(:-P)),
  415  trim_off(':-',A,B),
  416  format('~N:- ~q:~s~n',[M,B]).
  417fmt999((M:H :- Body)):- P= (M:H :- Body),
  418  with_output_to(string(A),fmt9(:-P)),
  419  trim_off(':-',A,B),
  420  format('~N:- ~q:~s~n',[M,B]).
  421fmt999(M:P):- functor(P,':-',_),!,fmt9(M:P).
  422fmt999(M:P):- with_output_to(string(A),fmt9(:-P)),
  423  trim_off(':-',A,B),
  424  format('~N~q:~s~n',[M,B]).
  425fmt999(P):- functor(P,':-',_),!,fmt9(P).
  426fmt999(P):- with_output_to(string(A),fmt9(:-P)),
  427  trim_off(':-',A,B),
  428  format('~N~s~n',[B]).
  429fmt999(P):- fmt9(P),nl.
  430% notrace((dbmsg0(Var))).
  431trim_off(W,A,B):- atomic(A), string_concat(W,B,A),!.
  432trim_off(_,A,A).
  433
  434assert_lsp(G):- assert_lsp(u,G).
  435assert_lsp(S,(G1,G2)):- !,assert_lsp(S,G1),assert_lsp(S,G2).
  436assert_lsp(_,G):-  wo_trace((copy_term_nat(G,GG),assert_local(GG))).
  437
  438assert_local(user:G):-!,assert_local(G).
  439assert_local(user:G:-B):-!,assert_local(G:-B).
  440assert_local((G,B)):- !,assert_local(G),assert_local(B).
  441assert_local(G:-B):- B==true,!,assert_local(G).
  442assert_local(G):- assert_local0(G).
  443assert_local0(G):- \+ \+ (clause_asserted_local(G,_)),!.
  444assert_local0(G):- doall((clause_asserted_local(G,E),erase(E),fail)),!,user:asserta(G),!.
  445
  446clause_asserted_local((H:-_),R):-!,  predicate_property(H,number_of_clauses(_)),clause(H,_,R).
  447clause_asserted_local(H,R):-  predicate_property(H,number_of_clauses(_)),clause(H,true,R).
  448
  449:- fixup_exports.  450
  451%system:goal_expansion(always(G),G) :- wam_cl_option(speed,S),S>2.
  452%system:goal_expansion(certainly(G),G) :- wam_cl_option(safety,0).
  453
  454:- use_module(debugio).  455%:- include('./header').
  456
  457wl:interned_eval("(defparameter sys:*markdown* cl:t)")