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).
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
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).
75
76length_safe(X,Y):- catch(length(X,Y),E,(dmsg(length(X,Y)=E),break)).
77
79certainly((A,B)):-!,certainly(A),certainly(B).
81certainly(G):- notrace(tracing),!,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
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)). 136always(Var):- notrace(var(Var)),!,throw(var_always(Var)).
137always([]):-!.
138always([A|B]):-!,always(A),always(B),!.
140
141always(MG):- always_skip_always, !, (call(MG) *->true;throw(failed_always(MG))).
149
163
164cross_cut(_Cut,_Cut2).
165
168:- module_transparent(dinterp/5). 170dinterp(Must,N,Cut,M:G,L):-!,assertion(callable(G)),N:dinterp(Must,M,Cut,G,L).
173dinterp(_,_,_,true,_):-!.
174dinterp(_Must,_M, Cut, (!),_):-!,(nonvar(Cut)->true;Cut=!).
175
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
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). 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).
213dinterp(Must,M,Cut,lquietly(G),L):- cross_cut(Cut,Cut2),!,quietly(dinterp(Must,M,Cut2,G,L)).
216dinterp(Must,M,Cut, quietly(G),L):- cross_cut(Cut,Cut2),!, dinterp(Must,M,Cut2,G,L).
218dinterp(Must,M,Cut, notrace(G),L):- !, 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
226
227
228dinterp(_Must,M,_Cut,catch(G,E,F),_L):- !,M:catch(G,E,F).
229
232
233dinterp(Must,M,Cut,CallN,L):-
234 notrace((fix_callables(CallN,CallNew)->CallN\=@=CallNew)),!,
235 dinterp(Must,M,Cut,CallNew,L).
236
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).
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
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
299
300dinterp_e(_Must,M,_Cut,G, GG, _L):-
301 (((nb_current('$w_dinterp',false) ; just_call(M,GG)))),!,
302 (call(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').
351
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
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.
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
453
454:- use_module(debugio). 456
457wl:interned_eval("(defparameter sys:*markdown* cl:t)")