1/* Part of SWI-Prolog 2 3 Author: Douglas R. Miles, ... 4 E-mail: logicmoo@gmail.com 5 WWW: http://www.logicmoo.org 6 Copyright (c) 2016,2017,2021, LogicMOO Basic Tools 7 All rights reserved. 8 9 Redistribution and use in source and binary forms, with or without 10 modification, are permitted provided that the following conditions 11 are met: 12 13 1. Redistributions of source code must retain the above copyright 14 notice, this list of conditions and the following disclaimer. 15 16 2. Redistributions in binary form must reproduce the above copyright 17 notice, this list of conditions and the following disclaimer in 18 the documentation and/or other materials provided with the 19 distribution. 20 21 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS 24 FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE 25 COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, 26 INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 27 BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 28 LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 29 CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 31 ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 32 POSSIBILITY OF SUCH DAMAGE. 33*/ 34 35:- module(each_call_cleanup, 36 [ 37 each_call_cleanup/3, % +Setup, +Goal, +Cleanup 38 each_call_catcher_cleanup/4, % +Setup, +Goal, ?Catcher, +Cleanup 39 redo_call_cleanup/3, % +Setup, +Goal, +Cleanup 40 trusted_redo_call_cleanup/3 % +Setup, +Goal, +Cleanup 41 ]).

Utility LOGICMOO EACH CALL

Before a clause does a redo it allows code to be called. To execute between calls during backtracking. Allows us to put code before and after a clause.

Utility LOGICMOO_EACH_CALL_CLEANUP Works together with Each Call to allow code before and after a clause for backtracking.

@author Douglas R. Miles
@license LGPL @see https://groups.google.com/forum/#!searchin/comp.lang.prolog/redo_call_cleanup%7Csort:relevance/comp.lang.prolog/frH_4RzMAHg/2bBub5t6AwAJ
*/

56:- set_module(class(library)). 57 58:- meta_predicate 59 redo_call_cleanup(0,0,0), 60 call_then_cut(0), 61 each_call_catcher_cleanup(0,0,?,0), 62 each_call_cleanup(0,0,0), 63 trusted_redo_call_cleanup(0,0,0). 64 65 66 67% call_then_cut(G):- call((G,(deterministic(true)->!;true))) 68 69call_then_cut(G):- 70 prolog_current_choice(CP), 71 prolog_choice_attribute(CP,parent,PC), 72 prolog_choice_attribute(PC,frame,Frame),prolog_frame_attribute(Frame,goal,PG), 73 prolog_choice_attribute(CP,frame,CFrame),prolog_frame_attribute(CFrame,goal,CG),nop(dmsg(call_then_cut(PG,CG))), 74 call((G,(deterministic(true)->prolog_cut_to(PC);true))). 75 76 77 78:- module_transparent(pt1/1). 79:- module_transparent(pt2/1). 80 81 82/* 83?- undo((write(foo), nl)), !, (X=1; X=2). 84X = 1 ; 85X = 2. 86 87foo 88?- undo(writeln('done!')), (X=1; X=2), writeln(side_effect=X) undo(writeln(removing_side_effect=X)). 89X = 1 ; 90X = 2. 91 92done! 93?- undo(writeln('done!')), (X=1; X=2). 94X = 1 ; 95X = 2. 96 97done! 98 99skip_tracing(G):- 100 setup_call_cleanup_redo(notrace,G,trace). 101 102undo(writeln('done!')), (X=1; X=2), writeln(side_effect=X) undo(writeln(removing_side_effect=X)). 103 104*/

112redo_call_cleanup(Setup,Goal,Cleanup):- 113 assertion(each_call_cleanup:unshared_vars(Setup,Goal,Cleanup)), 114 trusted_redo_call_cleanup(Setup,Goal,Cleanup). 115 116trusted_redo_call_cleanup(Setup,Goal,Cleanup):- 117 HdnCleanup = mquietly(Cleanup), 118 setup_call_cleanup(Setup, 119 ((Goal,deterministic(DET)), 120 (notrace(DET == true) -> ! ; 121 ((HdnCleanup,notrace(nb_setarg(1,HdnCleanup,true))); 122 (Setup,notrace(nb_setarg(1,HdnCleanup,Cleanup)),notrace(fail))))), 123 HdnCleanup). 124 125:- '$hide'(trusted_redo_call_cleanup/3).

134each_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup):- 135 setup_call_catcher_cleanup(true, 136 each_call_cleanup(Setup, Goal, Cleanup), Catcher, true). 137 138:- thread_local(ecc:'$each_call_cleanup'/2). 139:- thread_local(ecc:'$each_call_undo'/2).

147each_call_cleanup(Setup,Goal,Cleanup):- 148 ((ground(Setup);ground(Cleanup)) -> 149 trusted_redo_call_cleanup(Setup,Goal,Cleanup); 150 setup_call_cleanup( 151 asserta((ecc:'$each_call_cleanup'(Setup,Cleanup)),HND), 152 trusted_redo_call_cleanup(pt1(HND),Goal,pt2(HND)), 153 (pt2(HND),erase(HND)))). 154 155 /******************************* 156 * UTILITIES * 157 *******************************/ 158 159:- public(ecc_throw_failure/1). 160 161ecc_throw_failure(Why):- throw(error(assertion_error(Why),_)). 162 163pt1(HND) :- 164 clause(ecc:'$each_call_cleanup'(Setup,Cleanup),true,HND) 165 -> 166 ('$sig_atomic'(Setup) -> 167 asserta(ecc:'$each_call_undo'(HND,Cleanup)) ; 168 ecc_throw_failure(failed_setup(Setup))) 169 ; 170 ecc_throw_failure(pt1(HND)). 171 172pt2(HND) :- 173 retract(ecc:'$each_call_undo'(HND,Cleanup)) -> 174 ('$sig_atomic'(Cleanup)->true ;ecc_throw_failure(failed_cleanup(Cleanup))); 175 ecc_throw_failure(failed('$each_call_undo'(HND))). 176 177:- if(true). 178:- system:import(each_call_cleanup/3). 179:- system:import(each_call_catcher_cleanup/4). 180:- system:import(redo_call_cleanup/3). 181:- system:import(pt1/1). 182:- system:import(pt2/1). 183:- endif. 184 185% Only checks for shared vars (not shared structures) 186% @TODO what if someone got tricky with setarging? 187unshared_vars(Setup,_,_):- ground(Setup),!. 188unshared_vars(Setup,Goal,Cleanup):- 189 term_variables(Setup,SVs), 190 term_variables(Cleanup,CVs), 191 ( CVs==[] -> true; unshared_set(SVs,CVs)), 192 term_variables(Goal,GVs), 193 ( GVs==[] -> true; 194 (unshared_set(SVs,GVs), 195 unshared_set(CVs,GVs))). 196 197unshared_set([],_). 198unshared_set([E1|Set1],Set2):- 199 not_in_identical(E1,Set2), 200 unshared_set(Set1,Set2). 201 202not_in_identical(X, [Y|Ys]) :- X \== Y, not_in_identical(X, Ys)