1% ---------------------------------------------------------------------- 2% BEGIN LICENSE BLOCK 3% Version: CMPL 1.1 4% 5% The contents of this file are subject to the Cisco-style Mozilla Public 6% License Version 1.1 (the "License"); you may not use this file except 7% in compliance with the License. You may obtain a copy of the License 8% at www.eclipse-clp.org/license. 9% 10% Software distributed under the License is distributed on an "AS IS" 11% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See 12% the License for the specific language governing rights and limitations 13% under the License. 14% 15% The Original Code is The ECLiPSe Constraint Logic Programming System. 16% The Initial Developer of the Original Code is Cisco Systems, Inc. 17% Portions created by the Initial Developer are 18% Copyright (C) 1989-2006 Cisco Systems, Inc. All Rights Reserved. 19% 20% Contributor(s): ECRC GmbH 21% 22% END LICENSE BLOCK 23% 24% System: ECLiPSe Constraint Logic Programming System 25% Version: $Id: paddy.pl,v 1.2 2008/08/04 10:28:36 jschimpf Exp $ 26% ---------------------------------------------------------------------- 27 28% The PADDY system. 29 30% PUT BINDING PROPAGATION IN POST-TRANSFORMATION! 31 32:- module(paddy). 33 34:- pragma(deprecated_warnings(off)). 35:- pragma(undeclared_warnings(off)). 36:- pragma(nowarnings). % lots of singleton variables in this file! 37 38:- local (help)/0. 39 40:- local 41 variable(bounds), 42 variable(index), 43 variable(clause_id), 44 variable(source_files), 45 variable(progsize), 46 variable(temp), 47 variable(many_patterns), 48 variable(name_count), 49 variable(prune), 50 variable(pattern_count), 51 variable(pointer), 52 variable(predicate_size), 53 variable(pattern_number), 54 variable(term_depth). 55 56:- import 57 term_size/2, current_array_body/3, setval_body/3, getval_body/3, 58 make_local_array_body/2, erase_array_body/2 59 from sepia_kernel. 60 61:- export 62 pin/1, p/0, p/1, p/2, pout/1, pout/0, 63 term_depth/1, pattern_number/1, bounds/1. 64 65:- dynamic 66 temp_side/1, temp_prop/1, temp_head_pred/1, temp_delay_pred/1, 67 temp_op/3, temp_dynamic_pred/1, temp_pd_predicate/1, 68 temp_parallel_pred/1, deprolog_module/2, deprolog_file/1. 69 70array_size(F,N,T) :- 71 functor(Old, F, 1), 72 (current_array(Old,_) -> 73 erase_array(F/1) 74 ; true), 75 X=..[F,N], make_local_array(X,T). 76 77bounds :- 78 setval(progsize,0), getval(bounds,N), 79 array_size(prune,N,byte), 80 array_size(auxdef,N,byte), 81 array_size(transformed,N,byte), 82 array_size(recursive,N,byte), 83 array_size(side,N,byte), 84 array_size(prop,N,byte), 85 array_size(clau,N,prolog), 86 array_size(prog,N,prolog), 87 array_size(proc,N,prolog). 88 89:- set_flag(print_depth,100), set_stream(divert,output), 90 set_stream(log_output,null), 91 ensure_loaded(library(lists)), 92 set_stream(log_output,output), 93 setval(term_depth,5), setval(pattern_number,100), 94 setval(predicate_size,2000), setval(bounds,2000), bounds. 95 96pattern_number(N) :- 97 getval(pattern_number,N1), setval(pattern_number,N), 98 write(" pattern_number changed from "), write(N1), 99 write(" to "), writeln(N). 100 101term_depth(N) :- 102 getval(term_depth,N1), setval(term_depth,N), 103 write(" term_depth changed from "), write(N1), 104 write(" to "), writeln(N). 105 106pin(In) :- deprolog(In), static_analysis. 107 108p :- partial_deduction. 109 110pout :- write_relevant_clauses. 111 112pout(Out) :- write_relevant_clauses(Out). 113 114p(In) :- pin(In), partial_deduction, write_relevant_clauses. 115 116p(In,Out) :- pin(In), partial_deduction, write_relevant_clauses(Out). 117 118write_relevant_clauses(Out) :- 119 divert(Out), 120 writeclause(divert,(?-((current_predicate(get_cut/1) -> 121 true 122 ; import get_cut/1 from sepia_kernel)))), 123 writeclause(divert,(?-((current_predicate(cut_to/1) -> 124 true 125 ; import cut_to/1 from sepia_kernel)))), 126 getval(source_files,SF), pathnames(SF,SF1), writeclause(divert,(?-SF1)), 127 write_relevant_clauses, 128 undivert. 129 130pathnames([],[]). 131pathnames([F|L],[F1|L1]) :- 132 name_string(F,Fc), 133 (substring(Fc,"/",1) -> 134 F1=F, pathnames(L,L1) 135 ; get_flag(cwd,X), append_strings(X,Fc,F1), pathnames(L,L1)). 136 137name_string(A,B) :- 138 atom(A) -> 139 atom_string(A,B) 140 ; B=A. 141 142write_relevant_clauses :- 143 not (relevant_pred(F,A,L), nl(divert), 144 rmember(I,L), getval(clau(I),(H,T)), 145 not writeclause(divert,(H:-T))). 146 147bounds(N) :- 148 getval(bounds,N1), setval(bounds,N), bounds, 149 write(" Bounds changed from "), write(N1), 150 write(" to "), writeln(N). 151 152% Preprocessor (deprolog) for PADDY. 153 154deprolog(In) :- 155 deprolog_initialise, 156 compile_term(cut_pred('0','0')), 157 start_compile_stream(cut), 158 clear_table(cut_table), 159 clear_table(head_table), 160 read_pd_file(In), 161 clear_table(head_table), 162 clear_table(cut_table), 163 end_compile_stream(cut), 164 make_static(temp_dynamic_pred(P),dynamic_pred(P)), 165 make_static(temp_delay_pred(P),delay_pred(P)), 166 make_static(temp_parallel_pred(P),parallel_pred(P)), 167 drop_ops, 168 add_cut_args, 169 make_static(temp_head_pred(X),head_pred(X)), 170 store_prog. 171 172deprolog_initialise :- 173 retract_all(temp_head_pred(_)), retract_all(deprolog_module(_,_)), 174 retract_all(temp_dynamic_pred(_)), retract_all(temp_pd_predicate(_)), 175 retract_all(temp_parallel_pred(_)), 176 clear_table(index_table), setval(clause_id,0), setval(index,0), 177 retract_all(temp_delay_pred(_)), retract_all(temp_op(_,_,_)), 178 retract_all(deprolog_file(_)). 179 180read_pd_file(In) :- 181 exists(In) -> 182 open(In,read,S), read(S,X), 183 ((X=(?-L); X=(:-L)) -> 184 setval(source_files,L), 185 read_prolog(L), read_pd_clauses(S), close(S), 186 make_static(temp_pd_predicate(P),pd_predicate(P)) 187 ; write(" PADDY ERROR: file "), write(In), 188 writeln(" must begin with `:-[..]'"), abort) 189 ; write(" PADDY ERROR: query file "), write(In), 190 writeln(" does not exist"), abort. 191 192read_pd_clauses(S) :- 193 read(S,X), 194 (X==end_of_file -> 195 true 196 ;X=(H:-T), functor(H,F,A), concat_atom([F,'_',A],FA) -> 197 (table_entry(FA,head_table) -> 198 write(" PADDY ERROR: "), write(F/A), 199 writeln(" already occurred in the program"), abort 200 ; true), 201 (temp_pd_predicate(H) -> 202 write(" PADDY ERROR: "), write(F/A), 203 writeln(" has more than one clause"), abort 204 ; true), 205 (pure_conjunction(T) -> 206 true 207 ; writeln(" PADDY ERROR: "), writeclause((H:-T)), 208 writeln(" is not a valid query clause"), abort), 209 incval(index), getval(index,Ind), check_bounds(Ind), 210 setval(proc(Ind),[]), predicate_key(H,Hk), 211 write_table(Hk,Ind,index_table), addclause(Ind,(H:-T)), 212 functor(G,F,A), assert(temp_pd_predicate(G)), 213 assert(temp_head_pred(G)), write_table(FA,'0',head_table), 214 read_pd_clauses(S) 215 ; writeln(" PADDY ERROR: "), writeclause(X), 216 writeln(" is not a valid query clause"), abort). 217 218pure_conjunction((A,B)) :- !, pure_conjunction(A), pure_conjunction(B). 219pure_conjunction(A) :- A\=(_;_), A\=(not _), A\=once(_), A\=(_->_), A\==!. 220 221read_prolog([]) :- !. 222read_prolog([H|T]) :- !, 223 read_prolog(H), read_prolog(T). 224read_prolog(F) :- 225 exists(F), !, write(" Enter file "), writeln(F), 226 asserta(deprolog_file(F)), open(F,read,S), read_prolog_clause(S), 227 close(S), retract(deprolog_file(F)), write(" Exit file "), writeln(F). 228read_prolog(F) :- 229 term_string(F,FS), append_strings(FS,".pl",FSPL), exists(FSPL), !, 230 write(" Reading "), writeln(FSPL), asserta(deprolog_file(F)), 231 open(FSPL,read,S), read_prolog_clause(S), 232 close(S), retract(deprolog_file(F)), write(" Exit file "), writeln(F). 233read_prolog(F) :- 234 write(" PADDY warning: could not find file "), writeln(F). 235 236read_prolog_clause(S) :- 237 read(S,X), 238 (X==end_of_file -> 239 deprolog_file(F), 240 (retract(deprolog_module(M,F)) -> 241 write(" Skipped module "), writeln(M) 242 ; true) 243 ; prolog_clause_analyse(X), read_prolog_clause(S)). 244 245prolog_clause_analyse((:-X)) :- !, dec_process((?-X)). 246prolog_clause_analyse((?-X)) :- !, dec_process((?-X)). 247prolog_clause_analyse((delay P if C)) :- !, assert(temp_delay_pred(P)). % DUPS? 248prolog_clause_analyse(_) :- deprolog_module(_,_), !. 249prolog_clause_analyse((H:-T)) :- !, prolog_clause_process(H,T). 250prolog_clause_analyse(X) :- prolog_clause_process(X,true). 251 252dec_process((?-A,B)) :- not (varof(V,A), occurs(V,B)), !, 253 dec_process((?-A)), dec_process((?-B)). 254dec_process((?-compile(F))) :- !, 255 (nonvar(F), exists(F) -> 256 read_prolog(F) 257 ;nonvar(F), term_string(F,FS), 258 append_strings(FS,".pl",FSPL), exists(FSPL) -> 259 read_prolog(FSPL) 260 ; write(" PADDY warning: could not find file "), 261 writeln(F)). 262dec_process((?-[A,B|T])) :- !, dec_process((?-compile(A))), 263 dec_process((?-[B|T])). 264dec_process((?-[A])) :- !, dec_process((?-compile(A))). 265dec_process((?-op(P,A,N))) :- !, assert(temp_op(P,A,N)), op(P,A,N). 266dec_process((?-local_op(P,A,N))) :- !, assert(temp_op(P,A,N)), op(P,A,N). 267dec_process((?-global_op(P,A,N))) :- !, assert(temp_op(P,A,N)), op(P,A,N). 268dec_process((?-dynamic Spec)) :- !, 269 not (extract_atom(F/A,Spec), functor(P,F,A), 270 not assert(temp_dynamic_pred(P))). 271dec_process((?-parallel Spec)) :- !, 272 not (extract_atom(F/A,Spec), functor(P,F,A), 273 not assert(temp_parallel_pred(P))). 274dec_process((?-module(M))) :- !, 275 deprolog_file(F), 276 (retract(deprolog_module(M1,F)) -> 277 write(" Skipped module "), writeln(M1) 278 ; true), 279 asserta(deprolog_module(M,F)), 280 write(" Skipping module "), writeln(M). 281dec_process((?-G)). 282 283prolog_clause_process(H,T) :- 284 functor(H,HF,HA), concat_atom([HF,'_',HA],FA), 285 (table_entry(FA,head_table) -> 286 true 287 ; functor(H1,HF,HA), assert(temp_head_pred(H1)), 288 write_table(FA,'0',head_table)), 289 prolog_body_process(HF/HA,T,T1), predicate_key(H,Hk), 290 (read_table(Hk,Ind,index_table) -> 291 addclause(Ind,(H:-T1)) 292 ; incval(index), getval(index,Ind), check_bounds(Ind), 293 setval(proc(Ind),[]), write_table(Hk,Ind,index_table), 294 addclause(Ind,(H:-T1))). 295 296prolog_body_process(_,G,P) :- 297 var(G), !, P=call(G). 298prolog_body_process(HF/HA,call(A),P) :- 299 !, prolog_body_process(HF/HA,A,P). 300prolog_body_process(HF/HA,(A->B;C),P) :- 301 !, cond_process(HF/HA,(A->B;C),K,D), 302 prolog_body_process(HF/HA,(get_cut(K),D),P). 303prolog_body_process(HF/HA,(A->B),P) :- 304 !, cond_process(HF/HA,(A->B),K,D), 305 prolog_body_process(HF/HA,(get_cut(K),D),P). 306prolog_body_process(HF/HA,(A;B),(C;D)) :- 307 !, prolog_body_process(HF/HA,A,C), prolog_body_process(HF/HA,B,D). 308prolog_body_process(HF/HA,(A,B),(C,D)) :- 309 !, prolog_body_process(HF/HA,A,C), prolog_body_process(HF/HA,B,D). 310prolog_body_process(HF/HA,(not A),P) :- 311 !, prolog_body_process(HF/HA,(get_cut(C),(A,cut_to(C),fail;true)),P). 312prolog_body_process(HF/HA,once(A),P) :- 313 !, prolog_body_process(HF/HA,(get_cut(C),A,cut_to(C)),P). 314prolog_body_process(HF/HA,!,!) :- 315 !, concat_atom([HF,'_',HA],FA), 316 (table_entry(FA,cut_table) -> 317 true 318 ; write_table(FA,'0',cut_table), 319 stream_compile_term(cut,cut_pred(HF,HA))). 320prolog_body_process(HF/HA,(if A then B else C),(if D then E else F)) :- 321 !, prolog_body_process(HF/HA,A,D), prolog_body_process(HF/HA,B,E), 322 prolog_body_process(HF/HA,C,F). 323prolog_body_process(_,G,G). 324 325cond_process(HF/HA,X,K,X) :- var(X), !. 326cond_process(HF/HA,(A->B;C),K,(A,cut_to(K),B;Z)) :- !, 327 cond_process(HF/HA,C,K,Z). 328cond_process(HF/HA,(A->B),K,(A,cut_to(K),B)) :- !. 329cond_process(HF/HA,!,K,!) :- !, 330 concat_atom([HF,'_',HA],FA), 331 (table_entry(FA,cut_table) -> 332 true 333 ; write_table(FA,'0',cut_table), 334 stream_compile_term(cut,cut_pred(HF,HA))). 335cond_process(HF/HA,X,K,X). 336 337drop_ops :- 338 not (retract(temp_op(P,A,N)), current_op(P,A,N), not abolish_op(N,A)). 339 340add_cut_args :- 341 not (cut_pred(F,A), F/A\=='0'/'0', functor(G,F,A), 342 not delay_pred(G), not dynamic_pred(G), not parallel_pred(G), 343 not (incval(index), getval(index,IndC), 344 G=..[F|Z], append(Z,[C],ZC), concat_atom([F,'_',cut],FC), 345 GC=..[FC|ZC], assert(temp_head_pred(GC)), 346 predicate_key(G,Gk), read_table(Gk,Ind,index_table), 347 predicate_key(GC,GCk), write_table(GCk,IndC,index_table), 348 getval(proc(Ind),L), setval(proc(IndC),L), setval(proc(Ind),[]), 349 addclause(Ind,(G:-get_cut(C),GC)), 350 add_cut_tos(L,FC))). 351 352add_cut_tos([],HF1). 353add_cut_tos([I|L],HF1) :- 354 getval(clau(I),(H,T)), H=..[_|X], append(X,[C],X1), 355 H1=..[HF1|X1], add_cut_tos_body(C,T,T1), 356 setval(clau(I),(H1,T1)), add_cut_tos(L,HF1). 357 358add_cut_tos_body(C,(A,B),(X,Y)) :- !, 359 add_cut_tos_body(C,A,X), add_cut_tos_body(C,B,Y). 360add_cut_tos_body(C,(A;B),(X;Y)) :- !, 361 add_cut_tos_body(C,A,X), add_cut_tos_body(C,B,Y). 362add_cut_tos_body(C,!,cut_to(C)) :- !. 363add_cut_tos_body(C,T,T). 364 365store_prog :- 366 setval(progsize,0), 367 not (head_pred(P), predicate_key(P,Pk), 368 read_table(Pk,Ind,index_table), getval(proc(Ind),L), 369 rmember(I,L), getval(clau(I),(H,T)), 370 incval(progsize), getval(progsize,PS), 371 not setval(prog(PS),(H,T))). 372 373% Static Analyser for PADDY 374 375static_analysis :- 376 static_initialise, 377 setup_callgraph, 378 setup_symbols, 379 setup_body_preds, 380 setup_side_preds, 381 setup_prop_preds, 382 setup_rec_analysis, 383 make_name_table. 384 385make_name_table :- 386 clear_table(name_table), 387 not ((head_pred(G); body_pred(G), not head_pred(G)), 388 functor(G,F,_), not write_table(F,'0',name_table)). 389 390static_initialise :- 391 retract_all(temp_side(_)), retract_all(temp_prop(_)). 392 393setup_callgraph :- 394 compile_term(calls('0','0')), 395 start_compile_stream(comp), 396 clear_table(call_table), 397 not (head_pred(H), calls_atom(H,G), head_pred(G), 398 functor(G,X,Y), functor(H,F,A), 399 concat_atom([F,/,A,/,X,/,Y],FAXY), 400 not table_entry(FAXY,call_table), 401 not (stream_compile_term(comp,calls(F/A,X/Y)), 402 write_table(FAXY,'0',call_table))), 403 clear_table(call_table), 404 end_compile_stream(comp). 405 406setup_symbols :- 407 start_compile_stream(comp), 408 clear_table(symbol_table), 409 stream_compile_term(comp,symbol(true)), 410 stream_compile_term(comp,symbol(_=_)), 411 write_table('true/0','0',symbol_table), 412 write_table('=/2','0',symbol_table), 413 not (head_pred(H), predicate_key(H,Hk), 414 read_table(Hk,Ind,index_table), 415 getval(proc(Ind),L), member(I,L), getval(clau(I),C), 416 extract_atom(A,C), not symbols(A)), 417 clear_table(symbol_table), 418 end_compile_stream(comp). 419 420symbols(T) :- 421 var(T) -> 422 true 423 ;number(T) -> 424 true 425 ;string(T) -> 426 true 427 ; functor(T,F,A), concat_atom([F,'_',A],FA), 428 (table_entry(FA,symbol_table) -> 429 true 430 ; functor(T1,F,A), stream_compile_term(comp,symbol(T1)), 431 write_table(FA,'0',symbol_table)), 432 symbols(A,T). 433 434symbols(N,T) :- 435 N==0 -> 436 true 437 ; arg(N,T,X), symbols(X), M is N-1, symbols(M,T). 438 439setup_side_preds :- 440 clear_table(side_table), 441 not (head_pred(G), once((calls_atom(G,X), side_atom(X))), 442 not (predicate_key(G,Gk), write_table(Gk,'0',side_table), 443 assert(temp_side(G)))), 444 propagate_side, 445 make_static(temp_side(S),side(S)), 446 clear_table(side_table). 447 448setup_prop_preds :- 449 clear_table(prop_table), 450 not (head_pred(G), once((calls_atom(G,X), prop_atom(X))), 451 not (predicate_key(G,Gk), write_table(Gk,'0',prop_table), 452 assert(temp_prop(G)))), 453 propagate_prop, 454 make_static(temp_prop(S),prop(S)), 455 clear_table(prop_table). 456 457propagate_side :- 458 setval(temp,no), 459 not (temp_side(G), functor(G,F,A), calls(F1/A1,F/A), 460 functor(X,F1,A1), concat_atom([F1,'_',A1],FA1), 461 not table_entry(FA1,side_table), 462 not (setval(temp,yes), write_table(FA1,'0',side_table), 463 assert(temp_side(X)))), 464 getval(temp,yes), !, 465 propagate_side. 466propagate_side. 467 468propagate_prop :- 469 setval(temp,no), 470 not (temp_prop(G), functor(G,F,A), calls(F1/A1,F/A), 471 functor(X,F1,A1), concat_atom([F1,'_',A1],FA1), 472 not table_entry(FA1,prop_table), 473 not (setval(temp,yes), write_table(FA1,'0',prop_table), 474 assert(temp_prop(X)))), 475 getval(temp,yes), !, 476 propagate_prop. 477propagate_prop. 478 479calls_atom(G,X) :- 480 predicate_key(G,Gk), read_table(Gk,Ind,index_table), 481 getval(proc(Ind),L), rmember(Id,L), getval(clau(Id),(_,T)), 482 extract_atom(X,T). 483 484side_atom(G) :- var(G), !. 485side_atom(call(X)) :- !, side_atom(X). 486side_atom(G) :- not head_pred(G), not open_no_side(G). 487 488prop_atom(G) :- var(G), !. 489prop_atom(call(X)) :- !, prop_atom(X). 490prop_atom(G) :- not head_pred(G), not open_no_prop(G). 491 492setup_body_preds :- 493 start_compile_stream(body), 494 clear_table(body_table), 495 not (head_pred(P), not setup_body_pred(P)), 496 clear_table(body_table), 497 end_compile_stream(body). 498 499setup_body_pred(P) :- 500 predicate_key(P,Pk), read_table(Pk,Ind,index_table), getval(proc(Ind),L), 501 not (member(Id,L), getval(clau(Id),(_,T)), extract_atom(A,T), 502 predicate_key(A,Ak), not setup_body_atom(A,Ak)). 503 504setup_body_atom(A,Ak) :- 505 table_entry(Ak,body_table) -> 506 true 507 ; write_table(Ak,'0',body_table), 508 functor(A,X,Y), functor(A1,X,Y), 509 stream_compile_term(body,body_pred(A1)). 510 511setup_rec_analysis :- 512 compile_term(non_recursive('0')), 513 clear_table(nonrec_table), 514 start_compile_stream(nonrec), 515 not (head_pred(H), functor(H,F,A), 516 not (calls(F/A,X/Y), functor(Z,X,Y), head_pred(Z)), 517 not (stream_compile_term(nonrec,non_recursive(H)), 518 concat_atom([F,'_',A],FA), write_table(FA,'0',nonrec_table))), 519 propagate_nonrec, 520 end_compile_stream(nonrec), 521 clear_table(nonrec_table). 522 523propagate_nonrec :- 524 setval(temp,no), 525 not (head_pred(H), functor(H,F,A), 526 concat_atom([F,'_',A],FA), not table_entry(FA,nonrec_table), 527 not (calls(F/A,X/Y), concat_atom([X,'_',Y],XY), 528 not table_entry(XY,nonrec_table)), 529 not (setval(temp,yes), 530 write_table(FA,'0',nonrec_table), 531 stream_compile_term(nonrec,non_recursive(H)))), 532 getval(temp,yes), !, 533 propagate_nonrec. 534propagate_nonrec. 535 536% Partial deduction phase 537 538partial_deduction :- 539 pd_initialise, 540 cputime(T1), 541 main_transformation, 542 post_transformation, 543 cputime(T2), T is T2-T1, 544 write(" Transformation took "), 545 write(T), writeln(" seconds"). 546 547% Initialisation 548 549pd_initialise :- 550 clear_table(index_table), clear_table(defn_table), 551 clear_table(aux_table), 552 setval(many_patterns,false), setval(clause_id,0), 553 setval(name_count,0), setval(index,0), setval(prune,0), 554 setval(pattern_count,0), 555 getval(progsize,S), setval(pointer,0), check_program_exists(S), 556 pd_readclauses(S). 557 558check_program_exists(S) :- 559 S==0 -> 560 writeln(" PADDY ERROR: empty program"), abort 561 ; true. 562 563pd_readclauses(S) :- 564 incval(pointer), getval(pointer,P), 565 (P>S -> 566 true 567 ; getval(prog(P),(H,T)), once(pd_clause_process(H,T)), pd_readclauses(S)). 568 569pd_clause_process(H,T) :- 570 pd_body_process(T,T1), predicate_key(H,Hk), 571 (read_table(Hk,Ind,index_table) -> 572 addclause(Ind,(H:-T1)) 573 ; incval(index), getval(index,Ind), check_bounds(Ind), 574 setval(proc(Ind),[]), write_table(Hk,Ind,index_table), 575 addclause(Ind,(H:-T1))). 576 577pd_body_process((A,B),(C,D)) :- 578 !, pd_body_process(A,C), pd_body_process(B,D). 579pd_body_process((A;B),(C;D)) :- 580 !, pd_body_process(A,C), pd_body_process(B,D). 581pd_body_process(call(A),call(A)) :- 582 var(A), !. 583pd_body_process(call(A),P) :- 584 !, pd_body_process(A,P). 585pd_body_process(G,G). 586 587% Transformation 588 589main_transformation :- 590 not (pd_predicate(I), functor(I,F,A), write(" Goal "), writeln(F/A), 591 predicate_key(I,Ik), read_table(Ik,II,index_table), 592 getval(proc(II),[Id]), setval(proc(II),[]), getval(clau(Id),(I,G)), 593 not transform(II,i,I,G)). 594 595transform(II,IU,I,G) :- 596 setval(transformed(II),0), first_rest(G,F,R), 597 unfold(II,IU,(I:-F,R),no_prune), fail 598 ;set_properties(I,II). 599 600set_properties(I,Ind) :- 601 setval(transformed(Ind),1), functor(I,F,A), 602 getval(proc(Ind),L), recursive_class(L,F,A,Ind), 603 improve_side_class(L,F,A,Ind), improve_prop_class(L,F,A,Ind). 604 605recursive_class(L,F,A,Ind) :- 606 risky_recursion(F,A,L) -> 607 setval(recursive(Ind),2) 608 ;direct_recursion(L,F,A) -> 609 setval(recursive(Ind),1) 610 ; setval(recursive(Ind),0). 611 612risky_recursion(F,A,L) :- 613 member(Id,L), getval(clau(Id),(_,T)), extract_atom(G,T), 614 not functor(G,F,A), predicate_key(G,Gk), read_table(Gk,Ind,index_table), 615 (getval(transformed(Ind),0); getval(recursive(Ind),2)). 616 617direct_recursion(L,F,A) :- 618 member(Id,L), getval(clau(Id),(_,T)), extract_atom(G,T), 619 functor(G,F,A). 620 621improve_side_class(L,F,A,Ind) :- 622 getval(side(Ind),1), 623 not (rmember(Id,L), getval(clau(Id),(_,G)), 624 extract_atom(X,G), not functor(X,F,A), may_be_side(X)) -> 625 setval(side(Ind),0) 626 ; true. 627 628improve_prop_class(L,F,A,Ind) :- 629 getval(prop(Ind),1), 630 not (rmember(Id,L), getval(clau(Id),(_,G)), 631 extract_atom(X,G), not functor(X,F,A), may_be_prop(X)) -> 632 setval(prop(Ind),0) 633 ; true. 634 635unfold(II,IU,(I:-F,R),Prune) :- 636 F==true, R==true -> 637 addclause(II,(I:-true)) 638 ;head_pred(F), not dynamic_pred(F), 639 not parallel_pred(F), not delay_pred(F) -> 640 (IU==u, not non_recursive(F) -> 641 make_fold(F,Ff,Indf), may_reunfold_def(Indf,Ff,R,F1,R1), 642 unfold(II,u,(I:-F1,R1),no_prune) 643 ; predicate_key(F,Fk), read_table(Fk,Ind,index_table), 644 step(F,Ind,R,RF,RR,NewPrune), unfold(II,u,(I:-RF,RR),NewPrune)) 645 ;F=call(G), nonvar(G) -> 646 unfold(II,IU,(I:-G,R),Prune) 647 ;executable_open(F) -> 648 execute_open(F), first_rest(R,RF,RR), 649 unfold(II,u,(I:-RF,RR),Prune) 650 ;F=(F1;F2) -> 651 (first_rest1(F1,R,Fd,Rd); first_rest1(F2,R,Fd,Rd)), 652 unfold(II,IU,(I:-Fd,Rd),Prune) 653 ;nonrecursive_auxdef(F,Ind) -> 654 step(F,Ind,R,RF,RR,NewPrune), unfold(II,u,(I:-RF,RR),NewPrune) 655 ; may_prune(F,Prune,I), new_aux(I1,R,I,F,Ind1), 656 may_reunfold_aux(II,Ind1,I,F,I1). 657 658nonrecursive_auxdef(F,Ind) :- 659 not head_pred(F), predicate_key(F,Fk), read_table(Fk,Ind,index_table), 660 getval(transformed(Ind),1), getval(recursive(Ind),0). 661 662make_fold(F,Ff,Ind1) :- 663 pattern_key(F,Sk), 664 (read_table(Sk,[Ff1,F1,Ind,N1],defn_table) -> 665 (instance(F,F1) -> 666 Ff=Ff1, F=F1, Ind1=Ind 667 ;term_size(F,N), N<N1 -> 668 choose_fold(Sk,F,F,Ff,Ind1) 669 ; generalise(F,F1,G), choose_fold(Sk,G,F,Ff,Ind1)) 670 ; choose_fold(Sk,F,F,Ff,Ind1)). 671 672choose_fold(Sk,Fg,F,Fold,Ind) :- 673 new_def(Fg,Sk,Foldg,Indg), transform(Indg,i,Foldg,Fg), 674 (getval(recursive(Indg),0) -> 675 Fold=Foldg, F=Fg, Ind=Indg 676 ;read_table(Sk,[Foldr,Fr,Indr,_],defn_table), instance(F,Fr) -> 677 Fold=Foldr, F=Fr, Ind=Indr 678 ; Fold=Foldg, F=Fg, Ind=Indg). 679 680new_aux(I1,R,I,F,Ind) :- 681 aux_key(R,Rk), 682 (read_table(Rk,[I1,R1,Ind],aux_table), getval(transformed(Ind),1), 683 variant(R,R1), R=R1, internal_check(R,I1,I+F) -> 684 true 685 ; newpred(I1,R,I+F), incval(index), getval(index,Ind), 686 check_bounds(Ind), predicate_key(I1,I1k), 687 write_table(I1k,Ind,index_table), setval(proc(Ind),[]), 688 setval(auxdef(Ind),0), tentative_side_class(Ind,R), 689 tentative_prop_class(Ind,R), 690 write_table(Rk,[I1,R,Ind],aux_table), transform(Ind,u,I1,R)). 691 692aux_key(A,B) :- 693 getval(term_depth,N), aux_key(A,C,N), 694 (term_size(C,CS), getval(predicate_size,PS), CS>PS -> 695 B='0' 696 ; term_string(C,D), atom_string(B,D)). 697 698aux_key(((A,B),C),D,N) :- !, aux_key((A,B,C),D,N). 699aux_key((A,B),(C,D),N) :- !, sk(N,A,C), aux_key(B,D,N). 700aux_key(((A;B);C),D,N) :- !, aux_key((A;B;C),D,N). 701aux_key((A;B),(C;D),N) :- !, sk(N,A,C), aux_key(B,D,N). 702aux_key(A,B,N) :- sk(N,A,B). 703 704may_reunfold_aux(II,Ind,I,F,I1) :- 705 getval(proc(Ind),L), may_reunfold_aux(L,II,Ind,I,F,I1). 706 707may_reunfold_aux([],II,Ind,I,F,I1) :- !, 708 may_be_side(F), cj(F,fail,F1), addclause(II,(I:-F1)). 709may_reunfold_aux([Id],II,Ind,I,F,I1) :- !, 710 getval(clau(Id),(I1c,T)), 711 (may_be_prop(F) -> 712 unifier(I1,I1c,E), cj(E,T,ET), cj(F,ET,F1), addclause(II,(I:-F1)) 713 ; I1=I1c, cj(F,T,FT), addclause(II,(I:-FT))). 714may_reunfold_aux(L,II,Ind,I,F,I1) :- 715 cj(F,I1,F1), addclause(II,(I:-F1)). 716 717calls_cut_to(Id,K,I) :- 718 getval(clau(Id),(I,T)), 719 (first_rest(T,cut_to(_),T1) -> 720 true 721 ; T1=T), 722 extract_atom(cut_to(V),T1), V==K. 723 724unifier(A,B,E) :- unifier(A,B,[],E1), list_to_tuple(E1,E). 725 726unifier(A,B,Ei,Eo) :- 727 var(A) -> 728 (member(X=Y,Ei), (X==A; Y==A) -> 729 Eo=Ei 730 ; Eo=[A=B|Ei]) 731 ;var(B) -> 732 (member(X=Y,Ei), (X==B; Y==B) -> 733 Eo=Ei 734 ; Eo=[B=A|Ei]) 735 ; A=..[FA|LA], B=..[FB|LB], 736 (FA==FB -> 737 unifierl(LA,LB,Ei,Eo) 738 ; Eo=[fail]). 739 740unifierl(LA,LB,Ei,Eo) :- 741 LA==[] -> 742 (LB==[] -> 743 Eo=Ei 744 ; Eo=[fail]) 745 ;LB==[] -> 746 Eo=[fail] 747 ; LA=[A|RA], LB=[B|RB], 748 unifier(A,B,Ei,Et), unifierl(RA,RB,Et,Eo). 749 750list_to_tuple(L,T) :- 751 L=[] -> 752 T=true 753 ;L=[X|Y] -> 754 list_to_tuple(Y,A), eqjoin(X,A,T). 755 756eqjoin(A,B,C) :- 757 A==fail -> 758 C=fail 759 ;B==fail -> 760 C=fail 761 ; C=(A,B). 762 763internal_check(R1,I1,Rest) :- 764 not (varof(V,R1), not occurs(V,I1), occurs(V,Rest)). 765 766new_def(G,Sk,Ff,Ind) :- 767 newpred(Ff,G), incval(index), getval(index,Ind), 768 check_bounds(Ind), predicate_key(Ff,Ffk), setval(auxdef(Ind),1), 769 write_table(Ffk,Ind,index_table), setval(proc(Ind),[]), 770 tentative_side_class(Ind,G), tentative_prop_class(Ind,G), 771 term_size(G,N), write_table(Sk,[Ff,G,Ind,N],defn_table), 772 check_pattern_number. 773 774check_pattern_number :- 775 incval(pattern_count), getval(pattern_count,N), 776 getval(pattern_number,M), getval(term_depth,D), 777 (N==M, D>1 -> 778 setval(many_patterns,true), 779 nl, writeln(" PADDY warning: pattern number exceeded") 780 ; true). 781 782step(F,Ind,R,RF,RR,NewPrune) :- 783 getval(proc(Ind),L), setup_prune_point(L,NewPrune), 784 select_clause(NewPrune,Id,L), getval(clau(Id),(F,U)), 785 first_rest1(U,R,RF,RR). 786 787setup_prune_point([],no_prune). 788setup_prune_point([_],no_prune). 789setup_prune_point([_,_|_],NewPrune) :- 790 incval(prune), getval(prune,NewPrune), 791 check_bounds(NewPrune), setval(prune(NewPrune),0). 792 793may_prune(_,no_prune,_) :- !. 794may_prune(cut_to(_),Prune,I) :- most_general(I), !, setval(prune(Prune),1). 795may_prune(_,_,_). 796 797select_clause(Prune,Id,[_|L]) :- select_clause(Prune,Id,L). 798select_clause(no_prune,Id,[Id|_]) :- !. 799select_clause(Prune,Id,[Id|_]) :- getval(prune(Prune),0). 800 801may_reunfold_def(Ind,Ff,R,F1,R1) :- 802 getval(transformed(Ind),1), getval(proc(Ind),[Id]) -> 803 getval(clau(Id),(Ff,T)), first_rest1(T,R,F1,R1) 804 ; F1=Ff, R1=R. 805 806% Post-transformation 807 808post_transformation :- 809 find_relevant_code, expand_dets, find_relevant_code, 810 drop_equals, cut_args, cut_delabelling, last_cut_deletion, 811 setup_trim, cut_reductions, add_once. 812 813find_relevant_code :- 814 compile_term(relevant_pred('0','0','0')), 815 start_compile_stream(relevant), 816 clear_table(relevant), 817 not (pd_predicate(G), functor(G,F,A), concat_atom([F,'_',A],FA), 818 not table_entry(FA,relevant), read_table(FA,Ind,index_table), 819 not find_relevant(FA,F/A,Ind)), 820 clear_table(relevant), 821 end_compile_stream(relevant). 822 823find_relevant(FA,F/A,Ind) :- 824 getval(proc(Ind),L), L\==[] -> 825 write_table(FA,'0',relevant), 826 stream_compile_term(relevant,relevant_pred(F,A,L)), relevant_list(L) 827 ; true. 828 829relevant_list([]). 830relevant_list([I|L]) :- 831 getval(clau(I),(_,T)), relevant_body(T), relevant_list(L). 832 833relevant_body(T) :- 834 not (extract_atom(P,T), not body_pred(P), not head_pred(P), 835 predicate_key(P,Pk), read_table(Pk,Ind,index_table), functor(P,F,A), 836 concat_atom([F,'_',A],FA), not table_entry(FA,relevant), 837 not find_relevant(FA,F/A,Ind)). 838 839expand_dets :- 840 not (relevant_pred(F,A,L), member(Id,L), getval(clau(Id),(H,T)), 841 not (expand_dets(H,T,T1), setval(clau(Id),(H,T1)))). 842 843expand_dets(H,((A,B),C),T) :- 844 !, expand_dets(H,(A,B,C),T). 845expand_dets(H,(A,B),(E,TX)) :- 846 predicate_key(A,Ak), read_table(Ak,Ind,index_table), 847 getval(proc(Ind),[Id]), !, 848 getval(clau(Id),(P,T)), expand_dets(H,B,X), cj(T,X,TX), unifier(A,P,E). 849expand_dets(H,(A,B),AT) :- 850 !, expand_dets(H,B,T), cj(A,T,AT). 851expand_dets(H,A,(E,T)) :- 852 predicate_key(A,Ak), read_table(Ak,Ind,index_table), 853 getval(proc(Ind),[Id]), !, 854 getval(clau(Id),(P,T)), unifier(A,P,E). 855expand_dets(H,A,A). 856 857add_once :- 858 not (relevant_pred(F,A,L), member(Id,L), getval(clau(Id),(H,T)), 859 split5(T,TL,get_cut(K),TM,cut_to(K1),TR), K==K1, 860 not (cj(TL,once(TM),LM), cj(LM,TR,LMR), setval(clau(Id),(H,LMR)))). 861 862split5(T,A,B,C,D,E) :- 863 split(T,A,T1), 864 split(T1,B,T2), B\==true, 865 split(T2,C,T3), C\==true, 866 split(T3,D,E), D\==true. 867 868split(T,L,R) :- 869 split2(T,L,R) 870 ;L=T, R=true. 871 872split2(T,L,R) :- 873 T=((A,B),C) -> 874 split2((A,B,C),L,R) 875 ; (L=true, R=T 876 ;T=(H,S), split2(S,X,R), cj(H,X,L)). 877 878drop_equals :- 879 not (relevant_pred(F,A,L), member(Id,L), getval(clau(Id),(H,T)), 880 not drop_equals(Id,H,true,T,no)). 881 882drop_equals(Id,H,X,A,Z) :- 883 A==true -> 884 (Z==yes -> 885 setval(clau(Id),(H,X)) 886 ; true) 887 ; first_rest(A,F,R), 888 (F=(P=Q), safe_equals(P=Q,(H,X)) -> 889 P=Q, drop_equals(Id,H,X,R,yes) 890 ; cj(X,F,XF), drop_equals(Id,H,XF,R,Z)). 891 892% could further weaken safe_equals 893 894safe_equals(P=Q,T) :- 895 not P\=Q, 896 (not not (copy_term(T,T1), P=Q, variant(T,T1)) -> 897 true 898 ; not (extract_atom(A,T), may_be_prop(A))). 899 900cut_args :- 901 compile_term([cut_arg('0','0','0'),no_cut_arg('0','0')]), 902 start_compile_stream(cut_arg), 903 start_compile_stream(no_cut_arg), 904 clear_table(cut_arg), 905 clear_table(no_cut_arg), 906 not (relevant_pred(_,_,L), rmember(Id,L), getval(clau(Id),(_,T)), 907 pair(T,A,B), functor(B,F,M), relevant_pred(F,M,_), 908 concat_atom([F,'_',M],FM), not table_entry(FM,no_cut_arg), 909 not new_cut_arg(A,B,F,M,FM)), 910 clear_table(no_cut_arg), 911 clear_table(cut_arg), 912 end_compile_stream(no_cut_arg), 913 end_compile_stream(cut_arg). 914 915new_cut_arg(A,B,F,M,FM) :- 916 A=get_cut(K), interval(1,N,M), arg(N,B,V), V==K -> 917 (read_table(FM,N1,cut_arg), N\==N1 -> 918 write_table(FM,'0',no_cut_arg), 919 stream_compile_term(no_cut_arg,no_cut_arg(F,M)) 920 ;read_table(FM,N,cut_arg) -> 921 true 922 ; write_table(FM,N,cut_arg), 923 stream_compile_term(cut_arg,cut_arg(F,M,N))) 924 ; write_table(FM,'0',no_cut_arg), 925 stream_compile_term(no_cut_arg,no_cut_arg(F,M)). 926 927cut_delabelling :- 928 not (cut_arg(F,M,N), (F,M,N)\==('0','0','0'), 929 not no_cut_arg(F,M), relevant_pred(F,M,L), rmember(Id,L), 930 not (getval(clau(Id),(H,T)), arg(N,H,K), 931 cut_delabel(T,K,T1), setval(clau(Id),(H,T1)))). 932 933cut_delabel((A;B),K,(X;Y)) :- !, cut_delabel(A,K,X), cut_delabel(B,K,Y). 934cut_delabel((A,B),K,(X,Y)) :- !, cut_delabel(A,K,X), cut_delabel(B,K,Y). 935cut_delabel(cut_to(V),K,!) :- V==K, !. 936cut_delabel(X,_,X). 937 938pair(A,X,Y) :- pairtail((true,A),X,R), pairhead(R,Y). 939 940pairtail(((A,B),C),X,R) :- !, 941 pairtail((A,B,C),X,R). 942pairtail(((A;B),C),X,R) :- !, 943 pairhead(C,F), 944 (pairtail((A,F),X,R); pairtail((B,F),X,R); pairtail(C,X,R)). 945pairtail((A,B),X,Y) :- !, 946 (X=A, Y=B; pairtail(B,X,Y)). 947pairtail((A;B),X,R) :- 948 (pairtail(A,X,R); pairtail(B,X,R)). 949 950pairhead((A,B),F) :- !, 951 pairhead(A,F). 952pairhead((A;B),F) :- !, 953 (pairhead(A,F); pairhead(B,F)). 954pairhead(F,F). 955 956last_cut_deletion :- 957 not (relevant_pred(F,A,[Id|L]), getval(clau(Id),(H,T)), 958 first_rest(T,!,R), not setval(clau(Id),(H,R))). 959 960cut_reductions :- 961 not (relevant_pred(F,A,L), rmember(Id,L), 962 not (getval(clau(Id),(H,T)), trim_body((H,T),(Hd,Td)), 963 tidy(Td,T1), setval(clau(Id),(Hd,T1)))). 964 965setup_trim :- 966 clear_table(redarg_table), 967 repeat, setval(temp,no), 968 setup_trim_loop, 969 getval(temp,no), !. 970 971setup_trim_loop :- 972 not (relevant_pred(F,A,L), F\=='0', 973 nlist(A,[],Ri), trim_intersect(L,Ri,Ro), Ro\==[], 974 functor(P,F,A), concat_atom([F,'_',A],Pk), 975 (read_table(Pk,Ro1,redarg_table) -> 976 Ro1\==Ro 977 ; true), 978 setval(temp,yes), not write_table(Pk,Ro,redarg_table)). 979 980trim_intersect([],Ri,Ri) :- !. 981trim_intersect(_,[],[]) :- !. 982trim_intersect([I|L],Ri,Ro) :- 983 getval(clau(I),(H,T)), redargs(Ri,H,T,Rt), trim_intersect(L,Rt,Ro). 984 985trim_body((A,B),(X,Y)) :- !, trim_body(A,X), trim_body(B,Y). 986trim_body((A;B),(X;Y)) :- !, trim_body(A,X), trim_body(B,Y). 987trim_body(G,G) :- pd_predicate(G), !. 988trim_body(G,D) :- predicate_key(G,Gk), read_table(Gk,L,redarg_table), 989 L\==[], !, G=..[F|X], droplis(X,L,Y,1), D=..[F|Y]. 990trim_body(G,G). 991 992redargs([],_,_,[]). 993redargs([N|Ri],H,T,Ro) :- 994 arg(N,H,V), var(V), functor(H,HF,HA), 995 not will_occur(V,T,N,HF,HA), unique_in_head(V,H,N,HA) -> 996 Ro=[N|R], redargs(Ri,H,T,R) 997 ; redargs(Ri,H,T,Ro). 998 999will_occur(V,T,N,HF,HA) :- 1000 extract_atom(A,T), functor(A,AF,AA), 1001 (concat_atom([AF,'_',AA],Ak), read_table(Ak,L,redarg_table) -> 1002 true 1003 ; L=[]), 1004 (HF/HA=AF/AA -> 1005 interval(1,I,AA), not memberchk(I,[N|L]) 1006 ; interval(1,I,AA), not memberchk(I,L)), 1007 arg(I,A,X), occurs(V,X). 1008 1009unique_in_head(V,H,N,HN) :- 1010 not (interval(1,I,HN), I\==N, arg(I,H,A), occurs(V,A)). 1011 1012nlist(0,Li,Li) :- !. 1013nlist(N,Li,Lo) :- M is N-1, nlist(M,[N|Li],Lo). 1014 1015droplis([],L,[],_) :- !. 1016droplis(X,[],X,_) :- !. 1017droplis([A|B],[N|L],Y,N) :- !, M is N+1, droplis(B,L,Y,M). 1018droplis([A|B],L,[A|C],N) :- M is N+1, droplis(B,L,C,M). 1019 1020% General facilities 1021 1022make_static(D,S) :- 1023 not D, !, S=..[F|L], dummies(L,L1), S1=..[F|L1], compile_term(S1). 1024make_static(D,S) :- 1025 start_compile_stream(comp), 1026 not (retract(D), not stream_compile_term(comp,S)), 1027 end_compile_stream(comp). 1028 1029dummies([],[]). 1030dummies([_|L],['0'|D]) :- dummies(L,D). 1031 1032start_compile_stream(S) :- 1033 open(_,string,S). 1034 1035stream_compile_term(S,X) :- 1036 printf(S,"%q. ",X). 1037 1038end_compile_stream(S) :- 1039 seek(S,0), set_stream(log_output,null), 1040 compile_stream(S), set_stream(log_output,output), 1041 close(S). 1042 1043% Generalisation (due to Joachim Schimpf) 1044 1045generalise(A,B,G) :- 1046 map(A,B,G,[],Map), 1047 sort(0,=<,Map,SortedMap), 1048 unify_duplicates(SortedMap). 1049 1050map(A,B,G,Map,NewMap) :- 1051 (nonvar(A), nonvar(B), functor(A,Name,Arity), functor(B,Name,Arity) -> 1052 functor(G,Name,Arity), map_arg(Arity,A,B,G,Map,NewMap) 1053 ; NewMap=[subst(A,B,G)|Map]). 1054 1055map_arg(0,A,B,G,NewMap,NewMap) :- !. 1056map_arg(N,A,B,G,Map0,NewMap) :- 1057 arg(N,A,An), arg(N,B,Bn), arg(N,G,Gn), 1058 map(An,Bn,Gn,Map0,Map1), N1 is N-1, 1059 map_arg(N1,A,B,G,Map1,NewMap). 1060 1061unify_duplicates(M) :- 1062 M=[subst(A1,B1,G1)|T], T=[subst(A2,B2,G2)|_] -> 1063 (A1==A2, B1==B2 -> 1064 G1=G2 1065 ; true), 1066 unify_duplicates(T) 1067 ; true. 1068 1069% New predicate generation 1070 1071newpred(N,R) :- 1072 varset(R,S), newpred1(N,S,R). 1073 1074newpred(N,R,R1) :- 1075 varset_inter(R1,R,S), newpred1(N,S,R). 1076 1077newpred1(N,S,R) :- 1078 (R=(_,_) -> 1079 Z=aux 1080 ;R=(_;_) -> 1081 Z=aux 1082 ; functor(R,Z,_)), 1083 getval(name_count,NC), 1084 once((interval(NC,K,9999999), concat_atom([Z,'_',K],Name), 1085 not table_entry(Name,name_table))), 1086 K1 is K+1, setval(name_count,K1), 1087 write_table(Name,'0',name_table), N=..[Name|S]. 1088 1089% Pattern function 1090 1091pattern_key(A,S) :- 1092 getval(term_depth,N), 1093 (N>1, getval(many_patterns,true) -> 1094 M=1 1095 ; M=N), 1096 sk(N,A,S1), 1097 term_string(S1,Ss), atom_string(S,Ss). 1098 1099:- export sk/3. 1100 1101sk(0,_,'0') :- !. 1102sk(_,T,'0') :- var(T), !. 1103sk(N,T,S) :- symbol(T), !, functor(T,F,A), functor(S,F,A), 1104 M is N-1, sk(A,M,T,S). 1105sk(_,_,'0'). 1106 1107sk(0,_,_,_) :- !. 1108sk(A,N,T,S) :- 1109 arg(A,T,X), sk(N,X,Y), arg(A,S,Y), B is A-1, sk(B,N,T,S). 1110 1111% Side effect and propagation sensitivity 1112 1113may_be_side(G) :- var(G), !. 1114may_be_side(call(X)) :- !, may_be_side(X). 1115may_be_side(G) :- head_pred(G), !, side(G). 1116may_be_side(G) :- predicate_key(G,Gk), read_table(Gk,Ind,index_table), !, 1117 getval(side(Ind),1). 1118may_be_side(G) :- not open_no_side(G). 1119 1120may_be_prop(G) :- var(G), !. 1121may_be_prop(call(X)) :- !, may_be_prop(X). 1122may_be_prop(G) :- head_pred(G), !, 1123 (prop(G) -> 1124 true 1125 ; side(G), nonground(G)). 1126may_be_prop(G) :- predicate_key(G,Gk), read_table(Gk,Ind,index_table), !, 1127 (getval(side(Ind),1) -> 1128 true 1129 ; getval(prop(Ind),1), nonground(G)). 1130may_be_prop(G) :- not open_no_prop(G). 1131 1132tentative_side_class(Ind,G) :- 1133 extract_atom(X,G), may_be_side(X) -> 1134 setval(side(Ind),1) 1135 ; setval(side(Ind),0). 1136 1137tentative_prop_class(Ind,G) :- 1138 extract_atom(X,G), may_be_prop(X) -> 1139 setval(prop(Ind),1) 1140 ; setval(prop(Ind),0). 1141 1142/* TABLES: 1143write_table writes Term to Table given key Atom. 1144read_table retrieves it via Sepia hashing. 1145delete_entry deletes an entry with key Atom from Table. 1146table_entry tests to see if Table has an entry with key Atom. 1147clear_table empties Table if it exists and starts it off again empty. 1148*/ 1149 1150predicate_key(P,K) :- functor(P,F,A), concat_atom([F,'_',A],K). 1151 1152write_table(Atom,Term,Table) :- 1153 (current_array_body(Atom,_,Table) -> 1154 true 1155 ; make_local_array_body(Atom,Table)), 1156 setval_body(Atom,Term,Table). 1157 1158read_table(Atom,Term,Table) :- 1159 current_array_body(Atom,_,Table) -> 1160 getval_body(Atom,Term,Table). 1161 1162delete_entry(Atom,Table) :- 1163 erase_array_body(Atom,Table). 1164 1165table_entry(Atom,Table) :- 1166 current_array_body(Atom,_,Table). 1167 1168clear_table(Table) :- 1169 erase_module(Table), create_module(Table). 1170 1171% BUILT-IN SIDE EFFECTS 1172% Logic & control 1173open_no_side(call(G)) :- nonvar(G), open_no_side(G). 1174open_no_side(fail). 1175open_no_side(false). 1176open_no_side(true). 1177open_no_side(get_cut(_)). 1178% Database 1179open_no_side(clause(_)). 1180open_no_side(clause(_,_)). 1181open_no_side(current_built_in(_)). 1182open_no_side(current_predicate(_)). 1183open_no_side(get_flag(_,_,_)). 1184open_no_side(is_dynamic(_)). 1185% Internal Indexed database 1186open_no_side(current_record(_)). 1187open_no_side(is_record(_)). 1188open_no_side(recorded(_,_)). 1189open_no_side(recorded(_,_,_)). 1190open_no_side(recorded_list(_,_)). 1191open_no_side(referenced_record(_,_)). 1192% Type testing 1193open_no_side(atom(_)). 1194open_no_side(atomic(_)). 1195open_no_side(integer(_)). 1196open_no_side(nonground(_)). 1197open_no_side(nonvar(_)). 1198open_no_side(number(_)). 1199open_no_side(float(_)). 1200open_no_side(string(_)). 1201open_no_side(type_of(_,_)). 1202open_no_side(var(_)). 1203% Term comparison 1204open_no_side(_==_). 1205open_no_side(_\=_). 1206open_no_side(_\==_). 1207open_no_side(_@<_). 1208open_no_side(_@=<_). 1209open_no_side(_@>_). 1210open_no_side(_@>=_). 1211open_no_side(compare(_,_,_)). 1212open_no_side(compare_instances(_,_,_)). 1213open_no_side(instance(_,_)). 1214open_no_side(occurs(_,_)). 1215open_no_side(variant(_,_)). 1216% Term manipulation 1217open_no_side(_=.._). 1218open_no_side(arg(_,_,_)). 1219open_no_side(atom_string(_,_)). 1220open_no_side(char_int(_,_)). 1221open_no_side(copy_term(_,_)). 1222open_no_side(functor(_,_,_)). 1223open_no_side(integer_atom(_,_)). 1224open_no_side(name(_,_)). 1225open_no_side(string_list(_,_)). 1226open_no_side(term_string(_,_)). 1227% All solution 1228% Arithmetic 1229open_no_side(+(_,_,_)). 1230open_no_side(*(_,_,_)). 1231open_no_side(-(_,_)). 1232open_no_side(-(_,_,_)). 1233open_no_side(<<(_,_,_)). 1234open_no_side(>>(_,_,_)). 1235open_no_side(\(_,_)). 1236open_no_side(\/(_,_,_)). 1237open_no_side(+(_,_)). 1238open_no_side(_<_). 1239open_no_side(_=<_). 1240open_no_side(_=\=_). 1241open_no_side(_>_). 1242open_no_side(_>=_). 1243open_no_side(_=:=_). 1244open_no_side(/\(_,_,_)). 1245open_no_side(/(_,_,_)). 1246open_no_side(//(_,_,_)). 1247open_no_side(_ is _). 1248open_no_side(abs(_,_)). 1249open_no_side(acos(_,_)). 1250open_no_side(asin(_,_)). 1251open_no_side(atan(_,_)). 1252open_no_side(cos(_,_)). 1253open_no_side(exp(_,_)). 1254open_no_side(fix(_,_)). 1255open_no_side(float(_,_)). 1256open_no_side(ln(_,_)). 1257open_no_side(max(_,_,_)). 1258open_no_side(min(_,_,_)). 1259open_no_side(mod(_,_,_)). 1260open_no_side(plus(_,_,_)). 1261open_no_side(round(_,_)). 1262open_no_side(sin(_,_)). 1263open_no_side(sqrt(_,_)). 1264open_no_side(tan(_,_)). 1265open_no_side(times(_,_,_)). 1266open_no_side(xor(_,_,_)). 1267open_no_side(^(_,_,_)). 1268% Strings & atoms 1269open_no_side(atom_length(_,_)). 1270open_no_side(concat_atom(_,_)). 1271open_no_side(concat_atoms(_,_,_)). 1272open_no_side(concat_string(_,_)). 1273open_no_side(concat_strings(_,_,_)). 1274open_no_side(string_length(_,_)). 1275open_no_side(substring(_,_,_)). 1276% Module handling 1277open_no_side(current_module(_)). 1278open_no_side(is_locked(_)). 1279open_no_side(is_module(_)). 1280open_no_side(is_protected(_)). 1281open_no_side(tool_body(_,_,_)). 1282% Stream I/O 1283open_no_side(at(_,_)). 1284open_no_side(at_eof(_)). 1285open_no_side(current_stream(_,_,_)). 1286open_no_side(get_stream(_,_)). 1287open_no_side(stream_number(_)). 1288% Character I/O 1289% Term I/O 1290% Event handling 1291open_no_side(current_error(_)). 1292open_no_side(current_interrupt(_,_)). 1293open_no_side(error_id(_,_)). 1294open_no_side(get_error_handler(_,_)). 1295open_no_side(get_error_handler(_,_,_)). 1296open_no_side(get_interrupt_flag(_,_)). 1297open_no_side(get_interrupt_handler(_,_)). 1298open_no_side(get_interrupt_handler(_,_,_)). 1299open_no_side(list_error(_,_,_)). 1300% Debugging 1301open_no_side(get_leash(_,_)). 1302% Arrays & global variables 1303open_no_side(current_array(_,_,_)). 1304open_no_side(current_array(_,_)). 1305open_no_side(getval(_,_)). 1306% Coroutining 1307open_no_side(~X) :- open_no_side(X). 1308open_no_side(_~=_). 1309open_no_side(delayed_goals(_)). 1310open_no_side(delayed_goals_number(_,_)). 1311open_no_side(no_delayed_goals). 1312% Constructive negation 1313open_no_side(ineq(_,_,_)). 1314% External Interface 1315% Prolog environment 1316open_no_side(current_atom(_)). 1317open_no_side(current_functor(_)). 1318open_no_side(current_op(_)). 1319open_no_side(is_built_in(_)). 1320open_no_side(is_predicate(_)). 1321open_no_side(phrase(_,_)). 1322open_no_side(phrase(_,_,_)). 1323open_no_side(statistics(_,_)). 1324% Operating system 1325open_no_side(argc(_)). 1326open_no_side(argv(_,_)). 1327open_no_side(cputime(_)). 1328open_no_side(date(_)). 1329open_no_side(exists(_)). 1330open_no_side(get_file_info(_)). 1331open_no_side(getcwd(_)). 1332open_no_side(getenv(_,_)). 1333open_no_side(pathname(_,_)). 1334open_no_side(pathname(_,_,_)). 1335open_no_side(read_directory(_,_,_,_)). 1336open_no_side(random(_)). 1337open_no_side(suffix(_,_)). 1338% Libraries 1339 1340% BUILT-IN BACKWARD PROPAGATION SENSITIVITY 1341% Logic & control 1342open_no_prop(call(G)) :- nonvar(G), open_no_prop(G). 1343open_no_prop(fail). 1344open_no_prop(false). 1345open_no_prop(true). 1346open_no_prop(get_cut(_)). 1347% Database 1348open_no_prop(clause(_)). 1349open_no_prop(clause(_,_)). 1350open_no_prop(current_built_in(_)). 1351open_no_prop(current_predicate(_)). 1352open_no_prop(get_flag(_,_,_)). 1353open_no_prop(is_dynamic(_)). 1354% Internal Indexed database 1355open_no_prop(current_record(_)). 1356open_no_prop(is_record(_)). 1357open_no_prop(recorded(_,_)). 1358open_no_prop(recorded(_,_,_)). 1359open_no_prop(recorded_list(_,_)). 1360open_no_prop(referenced_record(_,_)). 1361% Type testing 1362% Term manipulation 1363open_no_prop(_=.._). 1364open_no_prop(arg(_,_,_)). 1365open_no_prop(atom_string(_,_)). 1366open_no_prop(char_int(_,_)). 1367open_no_prop(functor(_,_,_)). 1368open_no_prop(integer_atom(_,_)). 1369open_no_prop(name(_,_)). 1370open_no_prop(string_list(_,_)). 1371% All solution 1372% Arithmetic 1373open_no_prop(*(_,_,_)). 1374open_no_prop(+(_,_,_)). 1375open_no_prop(-(_,_)). 1376open_no_prop(-(_,_,_)). 1377open_no_prop(<<(_,_,_)). 1378open_no_prop(>>(_,_,_)). 1379open_no_prop(\(_,_)). 1380open_no_prop(\/(_,_,_)). 1381open_no_prop(+(_,_)). 1382open_no_prop(_<_). 1383open_no_prop(_=<_). 1384open_no_prop(_=\=_). 1385open_no_prop(_>_). 1386open_no_prop(_>=_). 1387open_no_prop(_=:=_). 1388open_no_prop(/\(_,_,_)). 1389open_no_prop(/(_,_,_)). 1390open_no_prop(//(_,_,_)). 1391open_no_prop(_ is _). 1392open_no_prop(abs(_,_)). 1393open_no_prop(acos(_,_)). 1394open_no_prop(asin(_,_)). 1395open_no_prop(atan(_,_)). 1396open_no_prop(cos(_,_)). 1397open_no_prop(exp(_,_)). 1398open_no_prop(fix(_,_)). 1399open_no_prop(float(_,_)). 1400open_no_prop(ln(_,_)). 1401open_no_prop(max(_,_,_)). 1402open_no_prop(min(_,_,_)). 1403open_no_prop(mod(_,_,_)). 1404open_no_prop(plus(_,_,_)). 1405open_no_prop(round(_,_)). 1406open_no_prop(sin(_,_)). 1407open_no_prop(sqrt(_,_)). 1408open_no_prop(tan(_,_)). 1409open_no_prop(times(_,_,_)). 1410open_no_prop(xor(_,_,_)). 1411open_no_prop(^(_,_,_)). 1412% Strings & atoms 1413open_no_prop(atom_length(_,_)). 1414open_no_prop(concat_atom(_,_)). 1415open_no_prop(concat_atoms(_,_,_)). 1416open_no_prop(concat_string(_,_)). 1417open_no_prop(concat_strings(_,_,_)). 1418open_no_prop(string_length(_,_)). 1419open_no_prop(substring(_,_,_)). 1420% Module handling 1421open_no_prop(current_module(_)). 1422open_no_prop(is_locked(_)). 1423open_no_prop(is_module(_)). 1424open_no_prop(is_protected(_)). 1425open_no_prop(tool_body(_,_,_)). 1426% Stream I/O 1427open_no_prop(at(_,_)). 1428open_no_prop(at_eof(_)). 1429open_no_prop(current_stream(_,_,_)). 1430open_no_prop(get_stream(_,_)). 1431open_no_prop(stream_number(_)). 1432% Character I/O 1433% Term I/O 1434% Event handling 1435open_no_prop(current_error(_)). 1436open_no_prop(current_interrupt(_,_)). 1437open_no_prop(error_id(_,_)). 1438open_no_prop(get_error_handler(_,_)). 1439open_no_prop(get_error_handler(_,_,_)). 1440open_no_prop(get_interrupt_flag(_,_)). 1441open_no_prop(get_interrupt_handler(_,_)). 1442open_no_prop(get_interrupt_handler(_,_,_)). 1443open_no_prop(list_error(_,_,_)). 1444% Debugging 1445open_no_prop(get_leash(_,_)). 1446% Arrays & global variables 1447open_no_prop(current_array(_,_,_)). 1448open_no_prop(current_array(_,_)). 1449open_no_prop(getval(_,_)). 1450% Coroutining 1451open_no_prop(_ ~= _). 1452open_no_prop(no_delayed_goals). 1453% Constructive negation 1454open_no_prop(ineq(_,_,_)). 1455% External Interface 1456% Prolog environment 1457open_no_prop(current_atom(_)). 1458open_no_prop(current_functor(_)). 1459open_no_prop(is_built_in(_)). 1460open_no_prop(is_predicate(_)). 1461open_no_prop(phrase(_,_)). 1462open_no_prop(phrase(_,_,_)). 1463open_no_prop(statistics(_,_)). 1464% Operating system 1465open_no_prop(argc(_)). 1466open_no_prop(argv(_,_)). 1467open_no_prop(cputime(_)). 1468open_no_prop(date(_)). 1469open_no_prop(exists(_)). 1470open_no_prop(getcwd(_)). 1471open_no_prop(getenv(_,_)). 1472open_no_prop(pathname(_,_)). 1473open_no_prop(pathname(_,_,_)). 1474open_no_prop(random(_)). 1475open_no_prop(read_directory(_,_,_,_)). 1476open_no_prop(suffix(_,_)). 1477% Libraries 1478 1479% BUILT-IN EXECUTABILITY 1480% Logic & control 1481executable_open(call(G)) :- nonvar(G), executable_open(G). 1482executable_open(fail). 1483executable_open(false). 1484% Database 1485executable_open(clause(X)) :- nonvar(X). 1486executable_open(clause(X,_)) :- 1487 nonvar(X), (functor(X,F,A), current_built_in(F/A) 1488 ;head_pred(X), not dynamic_pred(X)). 1489executable_open(current_built_in(X)) :- ground(X). 1490% Internal Indexed database 1491% Type testing 1492executable_open(atom(A)) :- nonvar(A). 1493executable_open(atomic(A)) :- nonvar(A). 1494executable_open(compound(A)) :- atomic(A); compound(A). 1495executable_open(integer(A)) :- nonvar(A). 1496executable_open(nonground(A)) :- ground(A). 1497executable_open(nonvar(A)) :- nonvar(A). 1498executable_open(number(A)) :- nonvar(A). 1499executable_open(float(A)) :- nonvar(A). 1500executable_open(string(A)) :- nonvar(A). 1501executable_open(type_of(A,B)) :- ground(A); compound(A). 1502executable_open(var(V)) :- nonvar(V). 1503% Term comparison 1504executable_open(A==B) :- A==B; A\=B. 1505executable_open(A\=B) :- A==B; A\=B. 1506executable_open(A\==B) :- A==B; A\=B. 1507executable_open(A=B). 1508executable_open(A@<B) :- ground(A), ground(B). 1509executable_open(A@=<B) :- ground(A), ground(B). 1510executable_open(A@>B) :- ground(A), ground(B). 1511executable_open(A@>=B) :- ground(A), ground(B). 1512executable_open(compare(A,B,C)) :- ground(B), ground(C). 1513%executable_open(compare_instances(A,B,C)) :- ? 1514% ground(B), ground(C); B\=C. ? 1515%executable_open(instance(A,B)) :- ? 1516% ground(A), ground(B); A\=B. ? 1517executable_open(occurs(A,B)) :- occurs(A,B). 1518executable_open(variant(A,B)) :- A==B; A\=B. 1519% Term manipulation 1520executable_open(A=..B) :- nonvar(A); clist(B), B=[H|T], atom(H). 1521executable_open(arg(A,B,C)) :- nonvar(A), compound(B). 1522executable_open(atom_string(A,B)) :- ground(A); ground(B). 1523executable_open(char_int(A,B)) :- ground(A); ground(B). 1524executable_open(copy_term(A,B)) :- 1525 ground(A); ground(B); A\=B. 1526executable_open(functor(A,B,C)) :- nonvar(A); ground(B), ground(C). 1527executable_open(integer_atom(A,B)) :- ground(A); ground(B). 1528executable_open(name(A,B)) :- ground(A); ground(B). 1529executable_open(string_list(A,B)) :- ground(A); ground(B). 1530executable_open(term_string(A,B)) :- ground(A); ground(B). 1531% All solution 1532% Arithmetic 1533executable_open(*(A,B,C)) :- nonvar(A), nonvar(B). 1534executable_open(+(A,B,C)) :- nonvar(A), nonvar(B). 1535executable_open(-(A,B)) :- nonvar(A). 1536executable_open(-(A,B,C)) :- nonvar(A), nonvar(B). 1537executable_open(<<(A,B,C)) :- nonvar(A), nonvar(B). 1538executable_open(>>(A,B,C)) :- nonvar(A), nonvar(B). 1539executable_open(\(A,B)) :- nonvar(A). 1540executable_open(\/(A,B,C)) :- nonvar(A), nonvar(B). 1541executable_open(+(A,B)) :- nonvar(A). 1542executable_open(A<B) :- ground(A), ground(B). 1543executable_open(A=<B) :- ground(A), ground(B). 1544executable_open(A=\=B) :- ground(A), ground(B). 1545executable_open(A>B) :- ground(A), ground(B). 1546executable_open(A>=B) :- ground(A), ground(B). 1547executable_open(A=:=B) :- ground(A), ground(B). 1548executable_open(/\(A,B,C)) :- nonvar(A), nonvar(B). 1549executable_open(/(A,B,C)) :- nonvar(A), nonvar(B). 1550executable_open(//(A,B,C)) :- nonvar(A), nonvar(B). 1551executable_open(A is B) :- ground(B). 1552executable_open(abs(A,B)) :- nonvar(A). 1553executable_open(acos(A,B)) :- nonvar(A). 1554executable_open(asin(A,B)) :- nonvar(A). 1555executable_open(atan(A,B)) :- nonvar(A). 1556executable_open(cos(A,B)) :- nonvar(A). 1557executable_open(exp(A,B)) :- nonvar(A). 1558executable_open(fix(A,B)) :- nonvar(A). 1559executable_open(float(A,B)) :- nonvar(A). 1560executable_open(ln(A,B)) :- nonvar(A). 1561executable_open(max(A,B,C)) :- nonvar(A), nonvar(B). 1562executable_open(min(A,B,C)) :- nonvar(A), nonvar(B). 1563executable_open(mod(A,B,C)) :- nonvar(A), nonvar(B). 1564executable_open(plus(A,B,C)) :- nonvar(A), (nonvar(B); nonvar(C)); 1565 nonvar(B), nonvar(C). 1566executable_open(round(A,B)) :- nonvar(A). 1567executable_open(sin(A,B)) :- nonvar(A). 1568executable_open(sqrt(A,B)) :- nonvar(A). 1569executable_open(tan(A,B)) :- nonvar(A). 1570executable_open(times(A,B,C)) :- nonvar(A), (nonvar(B); nonvar(C)); 1571 nonvar(B), nonvar(C). 1572executable_open(xor(A,B,C)) :- nonvar(A), nonvar(B). 1573executable_open(^(A,B,C)) :- nonvar(A), nonvar(B). 1574% Strings & atoms 1575executable_open(atom_length(A,B)) :- nonvar(A). 1576executable_open(concat_atom(A,B)) :- ground(A). 1577executable_open(concat_atoms(A,B,C)) :- ground(A), ground(B). 1578executable_open(concat_string(A,B)) :- ground(A). 1579executable_open(concat_strings(A,B,C)) :- nonvar(A), nonvar(B). 1580executable_open(string_length(A,B)) :- nonvar(A). 1581executable_open(substring(A,B,C)) :- nonvar(A), nonvar(B). 1582% Module handling 1583% Stream I/O 1584% Character I/O 1585% Term I/O 1586% Event handling 1587% Debugging 1588% Arrays & global variables 1589% Coroutining 1590executable_open(A~=B) :- A==B; A\=B. 1591% Constructive negation 1592executable_open(ineq(V,A,B)) :- ineq_expand(V,A,B). 1593% External Interface 1594% Prolog environment 1595executable_open(is_built_in(A)) :- nonvar(A), A=(B/C), nonvar(B), nonvar(C). 1596% Operating system 1597% Libraries 1598 1599% EXECUTION OF BUILT-INS 1600 1601execute_open(clause((A:-B))) :- !, fail. 1602execute_open(clause(A)) :- !, fail. 1603execute_open(clause(A,B)) :- !, fail. 1604execute_open(ineq(V,A,B)) :- !, A\=B. 1605execute_open((A~=B)) :- !, A\=B. 1606execute_open(G) :- G. 1607 1608ineq_expand(V,A,B) :- A==B. 1609ineq_expand(V,A,B) :- copy_term(V,V1), not (A=B, variant(V,V1)). 1610 1611clist(L) :- nonvar(L), (L==[]; L=[_|T], clist(T)). 1612 1613addclause(Ind,(H:-T)) :- 1614 metacall_process(T,T1), tidy(T1,Tp), % for gc(A),ct(A),fail etc 1615 (Tp==fail -> 1616 true 1617 ; incval(clause_id), getval(clause_id,ID), check_bounds(ID), 1618 setval(clau(ID),(H,Tp)), getval(proc(Ind),L), 1619 setval(proc(Ind),[ID|L])). 1620 1621metacall_process(T,Tm) :- 1622 var(T) -> 1623 Tm=call(T) 1624 ;T=call(X), nonvar(X) -> 1625 metacall_process(X,Tm) 1626 ; Tm=T. 1627 1628check_bounds(Ind) :- 1629 getval(bounds,Ind) -> 1630 writeln(" PADDY ERROR: transformation halted, bounds exceeded."), 1631 writeln(" The bounds can be increased using `bounds'"), 1632 writeln(" (type `help' for details)."), abort 1633 ; true. 1634 1635extract_atom(G,(A,B)) :- !, (extract_atom(G,A); extract_atom(G,B)). 1636extract_atom(G,(A;B)) :- !, (extract_atom(G,A); extract_atom(G,B)). 1637extract_atom(T,T). 1638 1639rmember(X,[A|B]) :- rmember(X,B); X=A. 1640 1641% ASSUMES get_cut(K) => K NOT IN CLAUSE HEAD! TRUE FOR AUTO-GEN GC... 1642 1643tidy(A,B) :- norm(A,C), tidy1(C,B). 1644 1645norm(((A;B);C),X) :- !, norm((A;B;C),X). 1646norm((A;B),(C;D)) :- !, norm(A,C), norm(B,D). 1647norm(((A,B),C),X) :- !, norm((A,B,C),X). 1648norm((A,B),(C,D)) :- !, norm(A,C), norm(B,D). 1649norm(A,A). 1650 1651tidy1((A;B),C) :- !, tidy1(A,D), tidy1(B,E), dj(D,E,C). 1652tidy1((get_cut(X),A),B) :- !, tidy1(A,C), shift_gc(X,C,B). 1653tidy1(get_cut(_),true) :- !. 1654tidy1((cut_to(X),cut_to(Y),A),B) :- !, tidy1((cut_to(Y),A),B). 1655tidy1((cut_to(X),cut_to(Y)),cut_to(Y)) :- !. 1656tidy1((cut_to(X),A),B) :- !, tidy1(A,C), shift_ct(X,C,B). 1657tidy1((!,cut_to(X),A),B) :- !, tidy1((cut_to(X),A),B). 1658tidy1((!,cut_to(X)),cut_to(X)) :- !. 1659tidy1((call(A),B),C) :- nonvar(A), !, tidy1((A,B),C). 1660tidy1(call(A),C) :- nonvar(A), !, tidy1(A,C). 1661tidy1((A,B),C) :- !, tidy1(B,D), cj(A,D,C). 1662tidy1(A,A). 1663 1664/* Could also have: 1665tidy1((cut_to(X),(A;B)),D) :- !, tidy1((cut_to(X),A;cut_to(X),B),D). 1666tidy1(((A;B),C),D) :- !, tidy1((A,C;B,C),D). 1667*/ 1668 1669shift_gc(X,(A;B),AXB) :- not occurs(X,A), !, shift_gc(X,B,XB), dj(A,XB,AXB). 1670shift_gc(X,(A=B,C),D) :- A\==X, B\==X, !, shift_gc(X,C,E), cj(A=B,E,D). 1671shift_gc(X,A,A) :- A\=(_;_), not occurs(X,A), !. 1672shift_gc(X,(cut_to(Y),A),B) :- X==Y, !, shift_gc(X,A,B). 1673shift_gc(X,cut_to(Y),true) :- X==Y, !. 1674shift_gc(X,(get_cut(Y),A),(X=Y,B)) :- !, cj(get_cut(X),A,B). 1675shift_gc(X,A,B) :- cj(get_cut(X),A,B). 1676 1677shift_ct(X,C,B) :- 1678 (C=(get_cut(Y),D) -> 1679 cj(Y=X,D,E), B=(cut_to(X),E) 1680 ; cj(cut_to(X),C,B)). 1681 1682cj(fail,_,fail) :- !. 1683cj(abort,_,abort) :- !. 1684cj(true,B,B) :- !. 1685cj(A,true,A) :- !. 1686cj(A,B,(A,B)). 1687 1688dj(fail,B,B) :- !. 1689dj(abort,B,abort) :- !. 1690dj(A,fail,A) :- !. 1691dj(A,B,(A;B)). 1692 1693first_rest(((A,B),C),F,R) :- !, first_rest((A,B,C),F,R). 1694first_rest((F,R),F1,R1) :- !, F=F1, R=R1. 1695first_rest(T,T,true). 1696 1697first_rest1(fail,_,fail,fail) :- !. 1698first_rest1(true,A,B,C) :- !, first_rest(A,B,C). 1699first_rest1(A,true,B,C) :- !, first_rest(A,B,C). 1700first_rest1(((A,B),C),D,X,Y) :- !, first_rest1((A,B,C),D,X,Y). 1701first_rest1((A,fail),_,A,fail) :- !. 1702first_rest1((A,true),C,A,C) :- !. 1703first_rest1((A,B),C,A,(B,C)) :- !. 1704first_rest1(A,B,A,B). 1705 1706natural(0). 1707natural(I) :- natural(J), I is J+1. 1708 1709interval(A,A,B) :- A=<B. 1710interval(A,B,C) :- A<C, D is A+1, interval(D,B,C). 1711 1712most_general(H) :- functor(H,_,N), copy_term(H,H1), most_general(N,H1). 1713 1714most_general(0,H) :- !. 1715most_general(N,H) :- 1716 arg(N,H,A), var(A), A=N, M is N-1, most_general(M,H). 1717 1718varof(V,T) :- 1719 term_string(T,X), open(X,string,I), readvar(I,T,S1), 1720 close(I), member([_|V],S1). 1721 1722% A slight flaw in this varset: (A,B,A) -> [B,A], ie ordering changed 1723% for repeated variables. But it's faster than explicitly coding it. 1724% For varset_inter should have largest argument first, for speed. 1725 1726varset(T,S) :- 1727 term_string(T,X), open(X,string,I), 1728 readvar(I,T,S1), close(I), strip_names(S1,S). 1729 1730strip_names([],[]). 1731strip_names([[_|A]|B],[A|C]) :- strip_names(B,C). 1732 1733varset_inter(A,B,S) :- varset(A,T), inter(T,B,S). 1734 1735inter([],_,[]). 1736inter([A|B],C,D) :- (occurs(A,C) -> D=[A|E]; D=E), inter(B,C,E). 1737 1738divert(F) :- open(F,write,file), set_stream(divert,file). 1739 1740undivert :- set_stream(divert,output), close(file). 1741 1742help :- 1743 writeln("COMMANDS"), 1744 nl, 1745 writeln("p(Infile)"), 1746 writeln(" partially deduces Infile, result to screen"), 1747 writeln("p(Infile,Outfile)"), 1748 writeln(" partially deduces Infile, result to Outfile"), 1749 nl, 1750 writeln("pin(Infile)"), 1751 writeln(" reads in the query file Infile"), 1752 writeln("p"), 1753 writeln(" performs the partial deduction"), 1754 writeln("pout(Outfile)"), 1755 writeln(" writes the result to the file Outfile"), 1756 writeln("pout"), 1757 writeln(" writes the result to the screen"), 1758 nl, 1759 writeln("term_depth(N)"), 1760 writeln(" sets the term abstraction depth to N (default 5)"), 1761 writeln("pattern_number(N)"), 1762 writeln(" sets the threshold number of patterns to N (default 100)"), 1763 writeln("bounds(N)"), 1764 writeln(" sets the array sizes to N"). 1765 1766?- writeln(" *-------------------------------------------------------*"), 1767 writeln(" | The PADDY partial deduction system |"), 1768 writeln(" | |"), 1769 writeln(" | S.D.Prestwich ECRC 1992 |"), 1770 writeln(" | |"), 1771 writeln(" | (type `help' for help) |"), 1772 writeln(" *-------------------------------------------------------*"). 1773 1774:- set_error_handler(231, (help)/0). 1775 1776