diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

upgrade chr

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1957 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2007-10-16 23:17:04 +00:00
parent 19a5f81dec
commit 6cc9e24976
34 changed files with 10698 additions and 6541 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
C/init.c
View File

@ -1207,7 +1207,7 @@ InitCodes(void)
Yap_heap_regs->functor_creep = Yap_MkFunctor(AtomCreep, 1);
Yap_heap_regs->functor_static_clause = Yap_MkFunctor (Yap_FullLookupAtom("$static_clause"), 1);
Yap_heap_regs->functor_stream = Yap_MkFunctor (AtomStream, 1);
Yap_heap_regs->functor_stream_pos = Yap_MkFunctor (AtomStreamPos, 3);
Yap_heap_regs->functor_stream_pos = Yap_MkFunctor (AtomStreamPos, 5);
Yap_heap_regs->functor_stream_eOS = Yap_MkFunctor (Yap_LookupAtom("end_of_stream"), 1);
Yap_heap_regs->functor_thread_run = Yap_MkFunctor (Yap_FullLookupAtom("$top_thread_goal"), 2);
Yap_heap_regs->functor_change_module = Yap_MkFunctor (Yap_FullLookupAtom("$change_module"), 1);

5
C/iopreds.c
View File

@ -4115,7 +4115,7 @@ p_show_stream_flags(void)
static Int
p_show_stream_position (void)
{ /* '$show_stream_position'(+Stream,Pos) */
Term sargs[3], tout;
Term sargs[5], tout;
int sno =
CheckStream (ARG1, Input_Stream_f | Output_Stream_f | Append_Stream_f, "stream_position/2");
if (sno < 0)
@ -4132,8 +4132,9 @@ p_show_stream_position (void)
}
sargs[1] = MkIntTerm (Stream[sno].linecount);
sargs[2] = MkIntTerm (Stream[sno].linepos);
sargs[3] = sargs[4] = MkIntTerm (0);
UNLOCK(Stream[sno].streamlock);
tout = Yap_MkApplTerm (FunctorStreamPos, 3, sargs);
tout = Yap_MkApplTerm (FunctorStreamPos, 5, sargs);
return (Yap_unify (ARG2, tout));
}

2
C/parser.c
View File

@ -611,7 +611,7 @@ ParseTerm(int prio, JMPBUFF *FailBuff)
if (Yap_tokptr->Tok == Ord(Name_tok)
&& (opinfo = Yap_GetOpProp((Atom)(Yap_tokptr->TokInfo)))) {
OpEntry *save_opinfo = opinfo;
if (IsInfixOp(opinfo, &opprio, &oplprio, &oprprio)
if (IsInfixOp(opinfo, &opprio, &oplprio, &oprprio)
&& opprio <= prio && oplprio >= curprio) {
/* try parsing as infix operator */
Volatile int oldprio = curprio;

6
LGPL/chr/Makefile.in
View File

@ -37,10 +37,12 @@ INSTALL_DATA=@INSTALL_DATA@
LIBPL= $(srcdir)/chr_runtime.pl $(srcdir)/chr_op.pl chr_translate.pl $(srcdir)/chr_debug.pl \
$(srcdir)/chr_messages.pl $(srcdir)/hprolog.yap $(srcdir)/pairlist.pl $(srcdir)/clean_code.pl \
$(srcdir)/chr_messages.pl $(srcdir)/hprolog.pl $(srcdir)/pairlist.pl $(srcdir)/clean_code.pl \
$(srcdir)/find.pl $(srcdir)/a_star.pl $(srcdir)/binomialheap.pl $(srcdir)/builtins.pl \
$(srcdir)/chr_hashtable_store.pl $(srcdir)/listmap.pl guard_entailment.pl \
$(srcdir)/chr_compiler_options.pl $(srcdir)/chr_compiler_utility.pl
$(srcdir)/chr_compiler_errors.pl \
$(srcdir)/chr_compiler_options.pl $(srcdir)/chr_compiler_utility.pl \
$(srcdir)/chr_integertable_store.pl
CHRPL= $(srcdir)/chr_swi.pl
CHRYAP= $(srcdir)/chr.yap
EXAMPLES= $(srcdir)/Benchmarks/chrfreeze.chr $(srcdir)/Benchmarks/fib.chr $(srcdir)/Benchmarks/gcd.chr $(srcdir)/Benchmarks/primes.chr \

4
LGPL/chr/a_star.pl
View File

@ -1,6 +1,6 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(a_star,
@ -8,8 +8,6 @@
a_star/4
]).
:- use_module(library(lists)).
:- use_module(binomialheap).
:- use_module(find).

5
LGPL/chr/binomialheap.pl
View File

@ -6,7 +6,7 @@
% University of Glasgow
%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -19,7 +19,7 @@
find_min_q/2
]).
:- use_module(library(lists)).
:- use_module(library(lists),[reverse/2]).
% data Tree a = Node a [Tree a]
% type BinQueue a = [Maybe (Tree a)]
@ -82,7 +82,6 @@ least(one(node(X,Xs)),one(node(Y,Ys)),T) :-
T = one(node(Y,Ys))
).
remove_tree([],_,[]).
remove_tree([T|Ts],I,[NT|NTs]) :-
( T == zero ->

43
LGPL/chr/builtins.pl
View File

@ -1,17 +1,17 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(builtins,
[
negate_b/2,
entails_b/2,
binds_b/2
binds_b/2,
builtin_binds_b/2
]).
:- use_module(hprolog).
%:- use_module(library(lists)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
negate_b(A,B) :- once(negate(A,B)).
@ -79,6 +79,43 @@ entails_(number(X),nonvar(X)).
entails_(atom(X),nonvar(X)).
entails_(fail,true).
builtin_binds_b(G,Vars) :-
builtin_binds_(G,L,[]),
sort(L,Vars).
builtin_binds_(var(_),L,L).
builtin_binds_(nonvar(_),L,L).
builtin_binds_(ground(_),L,L).
builtin_binds_(compound(_),L,L).
builtin_binds_(number(_),L,L).
builtin_binds_(atom(_),L,L).
builtin_binds_(atomic(_),L,L).
builtin_binds_(integer(_),L,L).
builtin_binds_(float(_),L,L).
builtin_binds_(_ > _ ,L,L).
builtin_binds_(_ < _ ,L,L).
builtin_binds_(_ =< _,L,L).
builtin_binds_(_ >= _,L,L).
builtin_binds_(_ =:= _,L,L).
builtin_binds_(_ =\= _,L,L).
builtin_binds_(_ == _,L,L).
builtin_binds_(_ \== _,L,L).
builtin_binds_(true,L,L).
builtin_binds_(X is _,[X|L],L).
builtin_binds_((G1,G2),L,T) :-
builtin_binds_(G1,L,R),
builtin_binds_(G2,R,T).
builtin_binds_((G1;G2),L,T) :-
builtin_binds_(G1,L,R),
builtin_binds_(G2,R,T).
builtin_binds_((G1->G2),L,T) :-
builtin_binds_(G1,L,R),
builtin_binds_(G2,R,T).
builtin_binds_(\+ G,L,T) :-
builtin_binds_(G,L,T).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
binds_b(G,Vars) :-
binds_(G,L,[]),

149
LGPL/chr/chr_compiler_options.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_compiler_options.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_compiler_options.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2005-2006, K.U. Leuven
@ -34,22 +34,29 @@
, chr_pp_flag/2
]).
%% SICStus begin
%% :- use_module(hprolog, [nb_setval/2,nb_getval/2]).
%% local_current_prolog_flag(_,_) :- fail.
%% SICStus end
%% SWI begin
local_current_prolog_flag(X,Y) :- current_prolog_flag(X,Y).
%% SWI end
:- use_module(chr_compiler_errors).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Global Options
%
handle_option(Var,Value) :-
var(Var), !,
format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
format(' `--> First argument should be an atom, not a variable.\n',[]),
fail.
handle_option(Name,Value) :-
var(Name), !,
chr_error(syntax((:- chr_option(Name,Value))),'First argument should be an atom, not a variable.\n',[]).
handle_option(Name,Value) :-
var(Value), !,
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
format(' `--> Second argument should be a nonvariable.\n',[]),
fail.
chr_error(syntax((:- chr_option(Name,Value))),'Second argument cannot be a variable.\n',[]).
handle_option(Name,Value) :-
option_definition(Name,Value,Flags),
@ -58,30 +65,28 @@ handle_option(Name,Value) :-
handle_option(Name,Value) :-
\+ option_definition(Name,_,_), !,
setof(N,_V ^ _F ^ (option_definition(N,_V,_F)),Ns),
format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]),
format(' `--> Invalid option name ~w: should be one of ~w.\n',[Name,Ns]).
chr_error(syntax((:- chr_option(Name,Value))),'Invalid option name ~w: consult the manual for valid options.\n',[Name]).
handle_option(Name,Value) :-
findall(V,option_definition(Name,V,_),Vs),
format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
format(' `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
fail.
chr_error(syntax((:- chr_option(Name,Value))),'Invalid option value ~w: consult the manual for valid option values.\n',[Value]).
option_definition(optimize,experimental,Flags) :-
Flags = [ functional_dependency_analysis - on,
check_unnecessary_active - off,
check_unnecessary_active - full,
reorder_heads - on,
set_semantics_rule - off,
set_semantics_rule - on,
storage_analysis - on,
guard_via_reschedule - on,
guard_simplification - on,
check_impossible_rules - on,
occurrence_subsumption - on,
observation - on,
observation_analysis - on,
ai_observation_analysis - on,
late_allocation - on,
reduced_indexing - on
reduced_indexing - on,
term_indexing - on,
inline_insertremove - on,
mixed_stores - on
].
option_definition(optimize,full,Flags) :-
Flags = [ functional_dependency_analysis - on,
@ -93,26 +98,12 @@ option_definition(optimize,full,Flags) :-
guard_simplification - on,
check_impossible_rules - on,
occurrence_subsumption - on,
observation - on,
observation_analysis - on,
ai_observation_analysis - on,
late_allocation - on,
reduced_indexing - on
].
option_definition(optimize,sicstus,Flags) :-
Flags = [ functional_dependency_analysis - off,
check_unnecessary_active - simplification,
reorder_heads - off,
set_semantics_rule - off,
storage_analysis - off,
guard_via_reschedule - off,
guard_simplification - off,
check_impossible_rules - off,
occurrence_subsumption - off,
observation - off,
ai_observation_analysis - off,
late_allocation - off,
reduced_indexing - off
reduced_indexing - on,
inline_insertremove - on,
mixed_stores - off
].
option_definition(optimize,off,Flags) :-
@ -125,8 +116,8 @@ option_definition(optimize,off,Flags) :-
guard_simplification - off,
check_impossible_rules - off,
occurrence_subsumption - off,
observation - off,
ai_observation_analysis - off,
observation_analysis - off,
ai_observation_analysis - off,
late_allocation - off,
reduced_indexing - off
].
@ -183,6 +174,11 @@ option_definition(late_allocation,on,Flags) :-
option_definition(late_allocation,off,Flags) :-
Flags = [ late_allocation - off ].
option_definition(inline_insertremove,on,Flags) :-
Flags = [ inline_insertremove - on ].
option_definition(inline_insertremove,off,Flags) :-
Flags = [ inline_insertremove - off ].
option_definition(type_definition,TypeDef,[]) :-
( nonvar(TypeDef) ->
TypeDef = type(T,D),
@ -205,9 +201,16 @@ option_definition(store,FA-Store,[]) :-
chr_translate:store_type(FA,Store).
option_definition(debug,off,Flags) :-
Flags = [ debugable - off ].
option_definition(optimize,full,Flags2),
Flags = [ debugable - off | Flags2].
option_definition(debug,on,Flags) :-
Flags = [ debugable - on ].
( local_current_prolog_flag(generate_debug_info,false) ->
% TODO: should not be allowed when nodebug flag is set in SWI-Prolog
chr_warning(any,':- chr_option(debug,on) inconsistent with current_prolog_flag(generate_debug_info,off\n\tCHR option is ignored!\n)',[]),
Flags = []
;
Flags = [ debugable - on ]
).
option_definition(store_counter,off,[]).
option_definition(store_counter,on,[store_counter-on]).
@ -235,9 +238,48 @@ option_definition(observation,ai,Flags) :-
ai_observation_analysis - on
].
option_definition(store_in_guards, on, [store_in_guards - on]).
option_definition(store_in_guards, off, [store_in_guards - off]).
option_definition(solver_events,NMod,Flags) :-
Flags = [solver_events - NMod].
option_definition(toplevel_show_store,on,Flags) :-
Flags = [toplevel_show_store - on].
option_definition(toplevel_show_store,off,Flags) :-
Flags = [toplevel_show_store - off].
option_definition(term_indexing,on,Flags) :-
Flags = [term_indexing - on].
option_definition(term_indexing,off,Flags) :-
Flags = [term_indexing - off].
option_definition(verbosity,on,Flags) :-
Flags = [verbosity - on].
option_definition(verbosity,off,Flags) :-
Flags = [verbosity - off].
option_definition(ht_removal,on,Flags) :-
Flags = [ht_removal - on].
option_definition(ht_removal,off,Flags) :-
Flags = [ht_removal - off].
option_definition(mixed_stores,on,Flags) :-
Flags = [mixed_stores - on].
option_definition(mixed_stores,off,Flags) :-
Flags = [mixed_stores - off].
option_definition(line_numbers,on,Flags) :-
Flags = [line_numbers - on].
option_definition(line_numbers,off,Flags) :-
Flags = [line_numbers - off].
option_definition(dynattr,on,Flags) :-
Flags = [dynattr - on].
option_definition(dynattr,off,Flags) :-
Flags = [dynattr - off].
init_chr_pp_flags :-
chr_pp_flag_definition(Name,[DefaultValue|_]),
set_chr_pp_flag(Name,DefaultValue),
@ -264,6 +306,7 @@ chr_pp_flag_definition(debugable,[on,off]).
chr_pp_flag_definition(reduced_indexing,[off,on]).
chr_pp_flag_definition(observation_analysis,[off,on]).
chr_pp_flag_definition(ai_observation_analysis,[off,on]).
chr_pp_flag_definition(store_in_guards,[off,on]).
chr_pp_flag_definition(late_allocation,[off,on]).
chr_pp_flag_definition(store_counter,[off,on]).
chr_pp_flag_definition(guard_simplification,[off,on]).
@ -271,7 +314,15 @@ chr_pp_flag_definition(check_impossible_rules,[off,on]).
chr_pp_flag_definition(occurrence_subsumption,[off,on]).
chr_pp_flag_definition(observation,[off,on]).
chr_pp_flag_definition(show,[off,on]).
chr_pp_flag_definition(inline_insertremove,[on,off]).
chr_pp_flag_definition(solver_events,[none,_]).
chr_pp_flag_definition(toplevel_show_store,[on,off]).
chr_pp_flag_definition(term_indexing,[off,on]).
chr_pp_flag_definition(verbosity,[on,off]).
chr_pp_flag_definition(ht_removal,[off,on]).
chr_pp_flag_definition(mixed_stores,[off,on]).
chr_pp_flag_definition(line_numbers,[off,on]).
chr_pp_flag_definition(dynattr,[off,on]).
chr_pp_flag(Name,Value) :-
atom_concat('$chr_pp_',Name,GlobalVar),
@ -281,4 +332,16 @@ chr_pp_flag(Name,Value) :-
;
V = Value
).
% TODO: add whatever goes wrong with (debug,on), (optimize,full) combo here!
% trivial example of what does go wrong:
% b <=> true.
% !!!
sanity_check :-
chr_pp_flag(store_in_guards, on),
chr_pp_flag(ai_observation_analysis, on),
chr_warning(any, 'ai_observation_analysis should be turned off when using store_in_guards\n', []),
fail.
sanity_check.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

73
LGPL/chr/chr_compiler_utility.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_compiler_utility.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_compiler_utility.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2005-2006, K.U. Leuven
@ -40,19 +40,28 @@
, variable_replacement/3
, variable_replacement/4
, identical_rules/2
, identical_guarded_rules/2
, copy_with_variable_replacement/3
, my_term_copy/3
, my_term_copy/4
, atom_concat_list/2
%vsc , atomic_concat/3
, init/2
, member2/3
, select2/6
, set_elems/2
, instrument_goal/4
, sort_by_key/3
]).
:- use_module(pairlist).
:- use_module(library(lists), [permutation/2]).
%% SICStus begin
%% use_module(library(terms),[term_variables/2]).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
is_variant(A,B) :-
copy_term_nat(A,AC),
@ -75,12 +84,19 @@ is_variant2([X|Xs]) :-
is_variant2(Xs).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
time(Phase,Goal) :-
statistics(runtime,[T1|_]),
call(Goal),
statistics(runtime,[T2|_]),
T is T2 - T1,
format(' ~w:\t\t~w ms\n',[Phase,T]).
% time(Phase,Goal) :-
% statistics(runtime,[T1|_]),
% call(Goal),
% statistics(runtime,[T2|_]),
% T is T2 - T1,
% format(' ~w ~46t ~D~80| ms\n',[Phase,T]),
% deterministic(Det),
% ( Det == true ->
% true
% ;
% format('\t\tNOT DETERMINISTIC!\n',[])
% ).
time(_,Goal) :- call(Goal).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
replicate(N,E,L) :-
@ -101,9 +117,10 @@ pair_all_with([X|Xs],Y,[X-Y|Rest]) :-
conj2list(Conj,L) :- %% transform conjunctions to list
conj2list(Conj,L,[]).
conj2list(Conj,L,T) :-
Conj = (true,G2), !,
conj2list(G2,L,T).
conj2list(Var,L,T) :-
var(Var), !,
L = [Var|T].
conj2list(true,L,L) :- !.
conj2list(Conj,L,T) :-
Conj = (G1,G2), !,
conj2list(G1,L,T1),
@ -144,6 +161,13 @@ list2disj([G|Gs],C) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% check wether two rules are identical
identical_guarded_rules(rule(H11,H21,G1,_),rule(H12,H22,G2,_)) :-
G1 == G2,
permutation(H11,P1),
P1 == H12,
permutation(H21,P2),
P2 == H22.
identical_rules(rule(H11,H21,G1,B1),rule(H12,H22,G2,B2)) :-
G1 == G2,
identical_bodies(B1,B2),
@ -184,7 +208,7 @@ copy_with_variable_replacement_l([X|Xs],[Y|Ys],L) :-
copy_with_variable_replacement(X,Y,L),
copy_with_variable_replacement_l(Xs,Ys,L).
%% build variable replacement list
% build variable replacement list
variable_replacement(X,Y,L) :-
variable_replacement(X,Y,[],L).
@ -234,7 +258,25 @@ my_term_copy_list([X|Xs],Dict1,Dict3,[Y|Ys]) :-
atom_concat_list([X],X) :- ! .
atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
atom_concat(X,B,A).
atomic_concat(X,B,A).
/* vsc
atomic_concat(A,B,C) :-
make_atom(A,AA),
make_atom(B,BB),
atom_concat(AA,BB,C).
*/
make_atom(A,AA) :-
(
atom(A) ->
AA = A
;
number(A) ->
number_codes(A,AL),
atom_codes(AA,AL)
).
set_elems([],_).
set_elems([X|Xs],X) :-
@ -254,3 +296,8 @@ select2(X, Y, [X1|Xs], [Y1|Ys], [X1|NXs], [Y1|NYs]) :-
select2(X, Y, Xs, Ys, NXs, NYs).
instrument_goal(Goal,Pre,Post,(Pre,Goal,Post)).
sort_by_key(List,Keys,SortedList) :-
pairup(Keys,List,Pairs),
sort(Pairs,SortedPairs),
once(pairup(_,SortedList,SortedPairs)).

7
LGPL/chr/chr_debug.pl
View File

@ -1,4 +1,4 @@
/* $Id: chr_debug.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_debug.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
@ -46,7 +46,10 @@
chr_show_store(Mod) :-
(
Mod:'$enumerate_suspensions'(Susp),
arg(6,Susp,C),
% arg(6,Susp,C),
Susp =.. [_,_,_,_,_,_,F|Arg],
functor(F,Fun,_),
C =.. [Fun|Arg],
print(C),nl, % allows use of portray to control printing
fail
;

527
LGPL/chr/chr_hashtable_store.pl
View File

@ -1,231 +1,296 @@
% author: Tom Schrijvers
% email: Tom.Schrijvers@cs.kuleuven.ac.be
% copyright: K.U.Leuven, 2004
:- module(chr_hashtable_store,
[ new_ht/1,
lookup_ht/3,
insert_ht/3,
delete_ht/3,
value_ht/2
]).
:- use_module(pairlist).
:- use_module(hprolog).
%:- use_module(library(lists)).
initial_capacity(1).
new_ht(HT) :-
initial_capacity(Capacity),
new_ht(Capacity,HT).
new_ht(Capacity,HT) :-
functor(T1,t,Capacity),
HT = ht(Capacity,0,Table),
Table = T1.
lookup_ht(HT,Key,Values) :-
term_hash(Key,Hash),
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup_eq(Bucket,Key,Values)
).
lookup_pair_eq([P | KVs],Key,Pair) :-
P = K-_,
( K == Key ->
P = Pair
;
lookup_pair_eq(KVs,Key,Pair)
).
insert_ht(HT,Key,Value) :-
term_hash(Key,Hash),
HT = ht(Capacity0,Load,Table0),
LookupIndex is (Hash mod Capacity0) + 1,
arg(LookupIndex,Table0,LookupBucket),
( var(LookupBucket) ->
Inc = yes,
LookupBucket = Key - [Value]
; LookupBucket = K-Values ->
( K == Key ->
( hprolog:memberchk_eq(Value,Values) ->
true
;
Inc = yes,
setarg(2,LookupBucket,[Value|Values])
)
;
Inc = yes,
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
)
;
( lookup_pair_eq(LookupBucket,Key,Pair) ->
Pair = _-Values,
( hprolog:memberchk_eq(Value,Values) ->
true
;
Inc = yes,
setarg(2,Pair,[Value|Values])
)
;
Inc = yes,
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
)
),
( Inc == yes ->
NLoad is Load + 1,
setarg(2,HT,NLoad),
( Load == Capacity0 ->
expand_ht(HT,_Capacity)
;
true
)
;
true
).
delete_ht(HT,Key,Value) :-
HT = ht(Capacity,Load,Table),
NLoad is Load - 1,
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
true
;
( Bucket = K-Vs ->
( K == Key,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
setarg(Index,Table,_)
;
setarg(2,Bucket,NVs)
)
;
true
)
;
( lookup_pair_eq(Bucket,Key,Pair),
Pair = _-Vs,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
pairlist_delete_eq(Bucket,Key,NBucket),
setarg(Index,Table,NBucket)
;
setarg(2,Pair,NVs)
)
;
true
)
)
).
delete_first_fail([X | Xs], Y, Zs) :-
( X == Y ->
Zs = Xs
;
Zs = [X | Zs1],
delete_first_fail(Xs, Y, Zs1)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
value_ht(HT,Value) :-
HT = ht(Capacity,_,Table),
value_ht(1,Capacity,Table,Value).
value_ht(I,N,Table,Value) :-
I =< N,
arg(I,Table,Bucket),
(
nonvar(Bucket),
( Bucket = _-Vs ->
true
;
member(_-Vs,Bucket)
),
member(Value,Vs)
;
J is I + 1,
value_ht(J,N,Table,Value)
).
values_ht(HT,Values) :-
HT = ht(Capacity,_,Table),
values_ht(1,Capacity,Table,Values).
values_ht(I,N,Table,Values) :-
( I =< N ->
arg(I,Table,Bucket),
( nonvar(Bucket) ->
( Bucket = _-Vs ->
append(Vs,Tail,Values)
;
append_snd(Bucket,Tail,Values)
)
;
Values = Tail
),
J is I + 1,
values_ht(J,N,Table,Tail)
;
Values = []
).
append_snd([],L,L).
append_snd([_-H|Ps],L,NL) :-
append(H,T,NL),
append_snd(Ps,L,T).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
expand_ht(HT,NewCapacity) :-
HT = ht(Capacity,_,Table),
NewCapacity is Capacity * 2,
functor(NewTable,t,NewCapacity),
setarg(1,HT,NewCapacity),
setarg(3,HT,NewTable),
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
expand_copy(Table,I,N,NewTable,NewCapacity) :-
( I > N ->
true
;
arg(I,Table,Bucket),
( var(Bucket) ->
true
; Bucket = Key - Value ->
expand_insert(NewTable,NewCapacity,Key,Value)
;
expand_inserts(Bucket,NewTable,NewCapacity)
),
J is I + 1,
expand_copy(Table,J,N,NewTable,NewCapacity)
).
expand_inserts([],_,_).
expand_inserts([K-V|R],Table,Capacity) :-
expand_insert(Table,Capacity,K,V),
expand_inserts(R,Table,Capacity).
expand_insert(Table,Capacity,K,V) :-
term_hash(K,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
Bucket = K - V
; Bucket = _-_ ->
setarg(Index,Table,[K-V,Bucket])
;
setarg(Index,Table,[K-V|Bucket])
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
term_hash(Term,Hash) :-
hash_term(Term,Hash).
/* $Id: chr_hashtable_store.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
% author: Tom Schrijvers
% email: Tom.Schrijvers@cs.kuleuven.be
% copyright: K.U.Leuven, 2004
:- module(chr_hashtable_store,
[ new_ht/1,
lookup_ht/3,
insert_ht/3,
insert_ht/4,
delete_ht/3,
delete_first_ht/3,
value_ht/2
]).
:- use_module(pairlist).
:- use_module(hprolog).
:- use_module(library(lists)).
:- use_module(library(terms)). %yap
:- multifile user:goal_expansion/2.
:- dynamic user:goal_expansion/2.
user:goal_expansion(term_hash(Term,Hash),hash_term(Term,Hash)).
% term_hash(Term,Hash) :-
% hash_term(Term,Hash).
initial_capacity(1).
new_ht(HT) :-
initial_capacity(Capacity),
new_ht(Capacity,HT).
new_ht(Capacity,HT) :-
functor(T1,t,Capacity),
HT = ht(Capacity,0,Table),
Table = T1.
lookup_ht(HT,Key,Values) :-
term_hash(Key,Hash),
HT = ht(Capacity,_,Table),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
nonvar(Bucket),
( Bucket = K-Vs ->
K == Key,
Values = Vs
;
lookup(Bucket,Key,Values)
).
lookup_pair_eq([P | KVs],Key,Pair) :-
P = K-_,
( K == Key ->
P = Pair
;
lookup_pair_eq(KVs,Key,Pair)
).
insert_ht(HT,Key,Value) :-
term_hash(Key,Hash),
HT = ht(Capacity0,Load,Table0),
LookupIndex is (Hash mod Capacity0) + 1,
arg(LookupIndex,Table0,LookupBucket),
( var(LookupBucket) ->
LookupBucket = Key - [Value]
; LookupBucket = K-Values ->
( K == Key ->
setarg(2,LookupBucket,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value],LookupBucket])
)
;
( lookup_pair_eq(LookupBucket,Key,Pair) ->
Pair = _-Values,
setarg(2,Pair,[Value|Values])
;
setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
)
),
NLoad is Load + 1,
setarg(2,HT,NLoad),
( Load == Capacity0 ->
expand_ht(HT,_Capacity)
;
true
).
% LDK: insert version with extra argument denoting result
insert_ht(HT,Key,Value,Result) :-
HT = ht(Capacity,Load,Table),
term_hash(Key,Hash),
LookupIndex is (Hash mod Capacity) + 1,
arg(LookupIndex,Table,LookupBucket),
( var(LookupBucket)
-> Result = [Value],
LookupBucket = Key - Result,
NewLoad is Load + 1
; LookupBucket = K - V
-> ( K = Key
-> Result = [Value|V],
setarg(2,LookupBucket,Result),
NewLoad = Load
; Result = [Value],
setarg(LookupIndex,Table,[Key - Result,LookupBucket]),
NewLoad is Load + 1
)
; ( lookup_pair_eq(LookupBucket,Key,Pair)
-> Pair = _-Values,
Result = [Value|Values],
setarg(2,Pair,Result),
NewLoad = Load
; Result = [Value],
setarg(LookupIndex,Table,[Key - Result|LookupBucket]),
NewLoad is Load + 1
)
),
setarg(2,HT,NewLoad),
( NewLoad > Capacity
-> expand_ht(HT,_)
; true
).
% LDK: deletion of the first element of a bucket
delete_first_ht(HT,Key,Values) :-
HT = ht(Capacity,Load,Table),
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( Bucket = _-[_|Values]
-> ( Values = []
-> setarg(Index,Table,_),
NewLoad is Load - 1
; setarg(2,Bucket,Values),
NewLoad = Load
)
; lookup_pair_eq(Bucket,Key,Pair)
-> Pair = _-[_|Values],
( Values = []
-> pairlist_delete_eq(Bucket,Key,NewBucket),
( NewBucket = []
-> setarg(Index,Table,_)
; NewBucket = [OtherPair]
-> setarg(Index,Table,OtherPair)
; setarg(Index,Table,NewBucket)
),
NewLoad is Load - 1
; setarg(2,Pair,Values),
NewLoad = Load
)
).
delete_ht(HT,Key,Value) :-
HT = ht(Capacity,Load,Table),
NLoad is Load - 1,
term_hash(Key,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
true
;
( Bucket = K-Vs ->
( K == Key,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
setarg(Index,Table,_)
;
setarg(2,Bucket,NVs)
)
;
true
)
;
( lookup_pair_eq(Bucket,Key,Pair),
Pair = _-Vs,
delete_first_fail(Vs,Value,NVs) ->
setarg(2,HT,NLoad),
( NVs == [] ->
pairlist_delete_eq(Bucket,Key,NBucket),
( NBucket = [Singleton] ->
setarg(Index,Table,Singleton)
;
setarg(Index,Table,NBucket)
)
;
setarg(2,Pair,NVs)
)
;
true
)
)
).
delete_first_fail([X | Xs], Y, Zs) :-
( X == Y ->
Zs = Xs
;
Zs = [X | Zs1],
delete_first_fail(Xs, Y, Zs1)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
value_ht(HT,Value) :-
HT = ht(Capacity,_,Table),
value_ht(1,Capacity,Table,Value).
value_ht(I,N,Table,Value) :-
I =< N,
arg(I,Table,Bucket),
(
nonvar(Bucket),
( Bucket = _-Vs ->
true
;
member(_-Vs,Bucket)
),
member(Value,Vs)
;
J is I + 1,
value_ht(J,N,Table,Value)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
expand_ht(HT,NewCapacity) :-
HT = ht(Capacity,_,Table),
NewCapacity is Capacity * 2,
functor(NewTable,t,NewCapacity),
setarg(1,HT,NewCapacity),
setarg(3,HT,NewTable),
expand_copy(Table,1,Capacity,NewTable,NewCapacity).
expand_copy(Table,I,N,NewTable,NewCapacity) :-
( I > N ->
true
;
arg(I,Table,Bucket),
( var(Bucket) ->
true
; Bucket = Key - Value ->
expand_insert(NewTable,NewCapacity,Key,Value)
;
expand_inserts(Bucket,NewTable,NewCapacity)
),
J is I + 1,
expand_copy(Table,J,N,NewTable,NewCapacity)
).
expand_inserts([],_,_).
expand_inserts([K-V|R],Table,Capacity) :-
expand_insert(Table,Capacity,K,V),
expand_inserts(R,Table,Capacity).
expand_insert(Table,Capacity,K,V) :-
term_hash(K,Hash),
Index is (Hash mod Capacity) + 1,
arg(Index,Table,Bucket),
( var(Bucket) ->
Bucket = K - V
; Bucket = _-_ ->
setarg(Index,Table,[K-V,Bucket])
;
setarg(Index,Table,[K-V|Bucket])
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

8
LGPL/chr/chr_messages.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_messages.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_messages.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Jan Wielemaker and Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -137,7 +137,7 @@ depth(Depth) -->
[ '~t(~D)~10| '-[Depth] ].
head(Susp) -->
{ Susp =.. [_,ID,_,_,_,_,Goal|_Args]
{ Susp =.. [_,ID,_,_,_,_|GoalArgs], Goal =.. GoalArgs
},
[ '~w # <~w>'-[Goal, ID] ].
@ -164,7 +164,7 @@ rule_head(H1, []) --> !,
heads(H1),
[ ' <=> ' ].
rule_head(H1, H2) -->
heads(H1), [ ' \\ ' ], heads(H2).
heads(H2), [ ' \\ ' ], heads(H1), [' <=> '].
rule_body(true, B) --> !,

6
LGPL/chr/chr_op.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_op.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_op.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -33,10 +33,10 @@
%%
%% Operator Priorities
:- op( 700, xfx, ::).
:- op(1180, xfx, ==>).
:- op(1180, xfx, <=>).
:- op(1150, fx, constraints).
:- op(1150, fx, chr_constraint).
:- op(1150, fx, handler).
:- op(1150, fx, rules).
:- op(1100, xfx, \).

6
LGPL/chr/chr_op2.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_op2.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_op2.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -36,10 +36,10 @@
% old version, without the type/mode operators
:- op( 700, xfx, ::).
:- op(1180, xfx, ==>).
:- op(1180, xfx, <=>).
:- op(1150, fx, constraints).
:- op(1150, fx, chr_constraint).
:- op(1150, fx, handler).
:- op(1150, fx, rules).
:- op(1100, xfx, \).

456
LGPL/chr/chr_runtime.pl
View File

@ -1,10 +1,10 @@
/* $Id: chr_runtime.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_runtime.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Christian Holzbaur and Tom Schrijvers
E-mail: christian@ai.univie.ac.at
Tom.Schrijvers@cs.kuleuven.ac.be
Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -56,7 +56,7 @@
%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%%
%% * modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
%% * modified by Tom Schrijvers, K.U.Leuven, Tom.Schrijvers@cs.kuleuven.be
%% - ported to hProlog
%% - modified for eager suspension removal
%%
@ -66,7 +66,6 @@
%% SWI-Prolog changes
%%
%% * Added initialization directives for saved-states
%% * Renamed merge/3 --> sbag_merge/3 (name conflict)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(chr_runtime,
@ -85,19 +84,23 @@
'chr allocate_constraint'/4,
'chr activate_constraint'/3,
'chr global_term_ref_1'/1,
'chr default_store'/1,
'chr via_1'/2,
'chr via_2'/3,
'chr via'/2,
'chr newvia_1'/2,
'chr newvia_2'/3,
'chr newvia'/2,
'chr lock'/1,
'chr unlock'/1,
'chr not_locked'/1,
'chr none_locked'/1,
'chr none_locked'/1,
'chr update_mutable'/2,
'chr get_mutable'/2,
'chr create_mutable'/2,
'chr novel_production'/2,
'chr extend_history'/2,
@ -109,45 +112,129 @@
'chr debug command'/2, % Char, Command
'chr chr_indexed_variables'/2,
'chr all_suspensions'/3,
'chr new_merge_attributes'/3,
'chr normalize_attr'/2,
'chr select'/3,
chr_show_store/1, % +Module
find_chr_constraint/1,
chr_trace/0,
chr_notrace/0,
chr_leash/1
]).
%% SWI begin
:- set_prolog_flag(generate_debug_info, false).
%% SWI end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- use_module(library(assoc)).
:- use_module(hprolog).
%:- use_module(library(lists)).
:- include(chr_op).
%% SICStus begin
%% :- use_module(hpattvars).
%% :- use_module(b_globval).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% I N I T I A L I S A T I O N
%% SWI begin
:- dynamic user:exception/3.
:- multifile user:exception/3.
user:exception(undefined_global_variable, Name, retry) :-
chr_runtime_global_variable(Name),
chr_init.
chr_runtime_global_variable(chr_id).
chr_runtime_global_variable(chr_global).
chr_runtime_global_variable(chr_debug).
chr_runtime_global_variable(chr_debug_history).
chr_init :-
nb_setval(id,0),
nb_setval(chr_id,0),
nb_setval(chr_global,_),
nb_setval(chr_debug,mutable(off)),
nb_setval(chr_debug_history,mutable([],0)).
nb_setval(chr_debug,mutable(off)), % XXX
nb_setval(chr_debug_history,mutable([],0)). % XXX
%% SWI end
%% SICStus begin
%% chr_init :-
%% nb_setval(chr_id,0).
%% SICStus end
:- initialization chr_init.
show_store(Mod) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Contents of former chr_debug.pl
%
% chr_show_store(+Module)
%
% Prints all suspended constraints of module Mod to the standard
% output.
chr_show_store(Mod) :-
(
Mod:'$enumerate_suspensions'(Susp),
arg(6,Susp,C),
writeln(C),
Mod:'$enumerate_constraints'(Constraint),
print(Constraint),nl, % allows use of portray to control printing
fail
;
true
).
find_chr_constraint(Constraint) :-
chr:'$chr_module'(Mod),
Mod:'$enumerate_constraints'(Constraint).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr merge_attributes'( As, Bs, Cs) :-
sbag_union(As,Bs,Cs).
% Inlining of some goals is good for performance
% That's the reason for the next section
% There must be correspondence with the predicates as implemented in chr_mutable.pl
% so that user:goal_expansion(G,G). also works (but do not add such a rule)
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% SWI begin
:- multifile user:goal_expansion/2.
:- dynamic user:goal_expansion/2.
user:goal_expansion('chr get_mutable'(Val,Var), Var=mutable(Val)).
user:goal_expansion('chr update_mutable'(Val,Var), setarg(1,Var,Val)).
user:goal_expansion('chr create_mutable'(Val,Var), Var=mutable(Val)).
user:goal_expansion('chr default_store'(X), nb_getval(chr_global,X)).
%% SWI end
% goal_expansion seems too different in SICStus 4 for me to cater for in a
% decent way at this moment - so I stick with the old way to do this
% so that it doesn't get lost, the code from Mats for SICStus 4 is included in comments
%% Mats begin
%% goal_expansion('chr get_mutable'(Val,Var), Lay, _M, get_mutable(Val,Var), Lay).
%% goal_expansion('chr update_mutable'(Val,Var), Lay, _M, update_mutable(Val,Var), Lay).
%% goal_expansion('chr create_mutable'(Val,Var), Lay, _M, create_mutable(Val,Var), Lay).
%% goal_expansion('chr default_store'(A), Lay, _M, global_term_ref_1(A), Lay).
%% Mats begin
%% SICStus begin
%% :- multifile user:goal_expansion/2.
%% :- dynamic user:goal_expansion/2.
%%
%% user:goal_expansion('chr get_mutable'(Val,Var), get_mutable(Val,Var)).
%% user:goal_expansion('chr update_mutable'(Val,Var), update_mutable(Val,Var)).
%% user:goal_expansion('chr create_mutable'(Val,Var), create_mutable(Val,Var)).
%% user:goal_expansion('chr default_store'(A), global_term_ref_1(A)).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr run_suspensions'( Slots) :-
@ -160,19 +247,19 @@ show_store(Mod) :-
run_suspensions([]).
run_suspensions([S|Next] ) :-
arg( 2, S, Mref),
Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
arg( 2, S, Mref), % ARGXXX
'chr get_mutable'( Status, Mref),
( Status==active ->
update_mutable( triggered, Mref),
arg( 4, S, Gref),
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
'chr update_mutable'( triggered, Mref),
arg( 4, S, Gref), % ARGXXX
'chr get_mutable'( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref),
arg( 3, S, Goal),
'chr update_mutable'( Generation, Gref),
arg( 3, S, Goal), % ARGXXX
call( Goal),
% get_mutable( Post, Mref), % XXX Inlined
( Mref = mutable(triggered) -> % Post==triggered ->
update_mutable( removed, Mref)
'chr get_mutable'( Post, Mref),
( Post==triggered ->
'chr update_mutable'( active, Mref) % catching constraints that did not do anything
;
true
)
@ -191,15 +278,15 @@ run_suspensions([S|Next] ) :-
run_suspensions_d([]).
run_suspensions_d([S|Next] ) :-
arg( 2, S, Mref),
Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
arg( 2, S, Mref), % ARGXXX
'chr get_mutable'( Status, Mref),
( Status==active ->
update_mutable( triggered, Mref),
arg( 4, S, Gref),
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
'chr update_mutable'( triggered, Mref),
arg( 4, S, Gref), % ARGXXX
'chr get_mutable'( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref),
arg( 3, S, Goal),
'chr update_mutable'( Generation, Gref),
arg( 3, S, Goal), % ARGXXX
(
'chr debug_event'(wake(S)),
call( Goal)
@ -213,9 +300,9 @@ run_suspensions_d([S|Next] ) :-
'chr debug_event'(redo(S)),
fail
),
% get_mutable( Post, Mref), % XXX Inlined
( Mref = mutable(triggered) -> % Post==triggered ->
update_mutable( removed, Mref)
'chr get_mutable'( Post, Mref),
( Post==triggered ->
'chr update_mutable'( active, Mref) % catching constraints that did not do anything
;
true
)
@ -227,16 +314,7 @@ run_suspensions_d([S|Next] ) :-
locked:attr_unify_hook(_,_) :- fail.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr lock'(T) :-
lock(T).
'chr unlock'(T) :-
unlock(T).
'chr not_locked'(T) :-
not_locked(T).
lock(T) :-
'chr lock'(T) :-
( var(T)
-> put_attr(T, locked, x)
; term_variables(T,L),
@ -246,7 +324,7 @@ lock(T) :-
lockv([]).
lockv([T|R]) :- put_attr( T, locked, x), lockv(R).
unlock(T) :-
'chr unlock'(T) :-
( var(T)
-> del_attr(T, locked)
; term_variables(T,L),
@ -258,10 +336,13 @@ unlockv([T|R]) :- del_attr( T, locked), unlockv(R).
'chr none_locked'( []).
'chr none_locked'( [V|Vs]) :-
not_locked( V),
'chr none_locked'( Vs).
( get_attr(V, locked, _) ->
fail
;
'chr none_locked'(Vs)
).
not_locked( V) :-
'chr not_locked'(V) :-
( var( V) ->
( get_attr( V, locked, _) ->
fail
@ -277,9 +358,9 @@ not_locked( V) :-
% Eager removal from all chains.
%
'chr remove_constraint_internal'( Susp, Agenda) :-
arg( 2, Susp, Mref),
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
update_mutable( removed, Mref), % mark in any case
arg( 2, Susp, Mref), % ARGXXX
'chr get_mutable'( State, Mref),
'chr update_mutable'( removed, Mref), % mark in any case
( compound(State) -> % passive/1
Agenda = []
; State==removed ->
@ -289,24 +370,48 @@ not_locked( V) :-
;
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vars),
global_term_ref_1( Global),
'chr default_store'( Global),
Agenda = [Global|Vars]
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr newvia_1'(X,V) :-
( var(X) ->
X = V
;
nonground(X,V)
).
'chr newvia_2'(X,Y,V) :-
( var(X) ->
X = V
; var(Y) ->
Y = V
; compound(X), nonground(X,V) ->
true
;
compound(Y), nonground(Y,V)
).
%
% The second arg is a witness.
% The formulation with term_variables/2 is
% cycle safe, but it finds a list of all vars.
% We need only one, and no list in particular.
%
'chr newvia'(L,V) :- nonground(L,V).
%~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-~-
'chr via_1'(X,V) :-
( var(X) ->
X = V
; atomic(X) ->
global_term_ref_1(V)
'chr default_store'(V)
; nonground(X,V) ->
true
;
global_term_ref_1(V)
'chr default_store'(V)
).
% 'chr via_1'( X, V) :- var(X), !, X=V.
% 'chr via_1'( T, V) :- compound(T), nonground( T, V), ! .
% 'chr via_1'( _, V) :- global_term_ref_1( V).
'chr via_2'(X,Y,V) :-
( var(X) ->
@ -318,13 +423,8 @@ not_locked( V) :-
; compound(Y), nonground(Y,V) ->
true
;
global_term_ref_1(V)
'chr default_store'(V)
).
% 'chr via_2'( X, _, V) :- var(X), !, X=V.
% 'chr via_2'( _, Y, V) :- var(Y), !, Y=V.
% 'chr via_2'( T, _, V) :- compound(T), nonground( T, V), ! .
% 'chr via_2'( _, T, V) :- compound(T), nonground( T, V), ! .
% 'chr via_2'( _, _, V) :- global_term_ref_1( V).
%
% The second arg is a witness.
@ -336,7 +436,7 @@ not_locked( V) :-
( nonground(L,V) ->
true
;
global_term_ref_1(V)
'chr default_store'(V)
).
nonground( Term, V) :-
@ -345,9 +445,9 @@ nonground( Term, V) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr novel_production'( Self, Tuple) :-
arg( 5, Self, Ref),
Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
( get_assoc( Tuple, History, _) ->
arg( 5, Self, Ref), % ARGXXX
'chr get_mutable'( History, Ref),
( get_ds( Tuple, History, _) ->
fail
;
true
@ -358,26 +458,26 @@ nonground( Term, V) :-
% goes in between the two calls.
%
'chr extend_history'( Self, Tuple) :-
arg( 5, Self, Ref),
Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
put_assoc( Tuple, History, x, NewHistory),
update_mutable( NewHistory, Ref).
arg( 5, Self, Ref), % ARGXXX
'chr get_mutable'( History, Ref),
put_ds( Tuple, History, x, NewHistory),
'chr update_mutable'( NewHistory, Ref).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
constraint_generation( Susp, State, Generation) :-
arg( 2, Susp, Mref),
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
arg( 4, Susp, Gref),
Gref = mutable(Generation). % get_mutable( Generation, Gref). % not incremented meanwhile % XXX Inlined
arg( 2, Susp, Mref), % ARGXXX
'chr get_mutable'( State, Mref),
arg( 4, Susp, Gref), % ARGXXX
'chr get_mutable'( Generation, Gref). % not incremented meanwhile
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr allocate_constraint'( Closure, Self, F, Args) :-
'chr empty_history'( History),
create_mutable( passive(Args), Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
'chr gen_id'( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
'chr create_mutable'(0, Gref),
'chr empty_history'(History),
'chr create_mutable'(History, Href),
'chr create_mutable'(passive(Args), Mref),
'chr gen_id'( Id).
%
% 'chr activate_constraint'( -, +, -).
@ -385,89 +485,85 @@ constraint_generation( Susp, State, Generation) :-
% The transition gc->active should be rare
%
'chr activate_constraint'( Vars, Susp, Generation) :-
arg( 2, Susp, Mref),
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
update_mutable( active, Mref),
arg( 2, Susp, Mref), % ARGXXX
'chr get_mutable'( State, Mref),
'chr update_mutable'( active, Mref),
( nonvar(Generation) -> % aih
true
;
arg( 4, Susp, Gref),
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
arg( 4, Susp, Gref), % ARGXXX
'chr get_mutable'( Gen, Gref),
Generation is Gen+1,
update_mutable( Generation, Gref)
'chr update_mutable'( Generation, Gref)
),
( compound(State) -> % passive/1
term_variables( State, Vs),
'chr none_locked'( Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
; State==removed -> % the price for eager removal ...
Vars = [Global|Vs],
'chr default_store'(Global)
; State == removed -> % the price for eager removal ...
Susp =.. [_,_,_,_,_,_,_|Args],
term_variables( Args, Vs),
global_term_ref_1( Global),
Vars = [Global|Vs]
Vars = [Global|Vs],
'chr default_store'(Global)
;
Vars = []
).
'chr insert_constraint_internal'( [Global|Vars], Self, Closure, F, Args) :-
term_variables( Args, Vars),
'chr none_locked'( Vars),
global_term_ref_1( Global),
'chr empty_history'( History),
create_mutable( active, Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
'chr gen_id'( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :-
'chr default_store'(Global),
term_variables(Args,Vars),
'chr none_locked'(Vars),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
'chr create_mutable'(active, Mref),
'chr create_mutable'(0, Gref),
'chr empty_history'(History),
'chr create_mutable'(History, Href),
'chr gen_id'(Id).
insert_constraint_internal( [Global|Vars], Self, Term, Closure, F, Args) :-
insert_constraint_internal([Global|Vars], Self, Term, Closure, F, Args) :-
'chr default_store'(Global),
term_variables( Term, Vars),
'chr none_locked'( Vars),
global_term_ref_1( Global),
'chr empty_history'( History),
create_mutable( active, Mref),
create_mutable( 0, Gref),
create_mutable( History, Href),
'chr create_mutable'( active, Mref),
'chr create_mutable'( 0, Gref),
'chr create_mutable'( History, Href),
'chr gen_id'( Id),
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args]. % SUSPXXX
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
change_state( Susp, State) :-
arg( 2, Susp, Mref),
update_mutable( State, Mref).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr empty_history'( E) :- empty_assoc( E).
'chr empty_history'( E) :- empty_ds( E).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr gen_id'( Id) :-
incval( id, Id).
incval(id,Id) :-
nb_getval(id,Id),
nb_getval(chr_id,Id),
NextId is Id + 1,
nb_setval(id,NextId).
nb_setval(chr_id,NextId).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
create_mutable(V,mutable(V)).
'chr get_mutable'(V, mutable(V)).
'chr update_mutable'(V,M) :-
setarg(1,M,V).
get_mutable(V, mutable(V)).
%% SWI begin
'chr create_mutable'(V,mutable(V)).
'chr get_mutable'(V,mutable(V)).
'chr update_mutable'(V,M) :- setarg(1,M,V).
%% SWI end
%% SICStus begin
%% 'chr create_mutable'(Val, Mut) :- create_mutable(Val, Mut).
%% 'chr get_mutable'(Val, Mut) :- get_mutable(Val, Mut).
%% 'chr update_mutable'(Val, Mut) :- update_mutable(Val, Mut).
%% SICStus end
update_mutable(V,M) :-
setarg(1,M,V).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr global_term_ref_1'(X) :-
global_term_ref_1(X).
%% SWI begin
'chr default_store'(X) :- nb_getval(chr_global,X).
%% SWI end
global_term_ref_1(X) :-
nb_getval(chr_global,X).
%% SICStus begin
%% 'chr default_store'(A) :- global_term_ref_1(A).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -475,10 +571,10 @@ global_term_ref_1(X) :-
sbag_member( Element, Tail, Head).
% auxiliary to avoid choicepoint for last element
sbag_member( E, _, E).
sbag_member( E, [Head|Tail], _) :-
sbag_member( E, Tail, Head).
% does it really avoid the choicepoint? -jon
sbag_member( E, _, E).
sbag_member( E, [Head|Tail], _) :-
sbag_member( E, Tail, Head).
'chr sbag_del_element'( [], _, []).
'chr sbag_del_element'( [X|Xs], Elem, Set2) :-
@ -489,28 +585,77 @@ sbag_member( E, [Head|Tail], _) :-
'chr sbag_del_element'( Xs, Elem, Xss)
).
sbag_union( A, B, C) :-
sbag_merge( A, B, C).
sbag_merge([],Ys,Ys).
sbag_merge([X | Xs],YL,R) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
'chr merge_attributes'([],Ys,Ys).
'chr merge_attributes'([X | Xs],YL,R) :-
( YL = [Y | Ys] ->
arg(1,X,XId),
arg(1,Y,YId),
arg(1,X,XId), % ARGXXX
arg(1,Y,YId), % ARGXXX
( XId < YId ->
R = [X | T],
sbag_merge(Xs,YL,T)
'chr merge_attributes'(Xs,YL,T)
; XId > YId ->
R = [Y | T],
sbag_merge([X|Xs],Ys,T)
'chr merge_attributes'([X|Xs],Ys,T)
;
R = [X | T],
sbag_merge(Xs,Ys,T)
'chr merge_attributes'(Xs,Ys,T)
)
;
R = [X | Xs]
).
'chr new_merge_attributes'([],A2,A) :-
A = A2.
'chr new_merge_attributes'([E1|AT1],A2,A) :-
( A2 = [E2|AT2] ->
'chr new_merge_attributes'(E1,E2,AT1,AT2,A)
;
A = [E1|AT1]
).
'chr new_merge_attributes'(Pos1-L1,Pos2-L2,AT1,AT2,A) :-
( Pos1 < Pos2 ->
A = [Pos1-L1|AT],
'chr new_merge_attributes'(AT1,[Pos2-L2|AT2],AT)
; Pos1 > Pos2 ->
A = [Pos2-L2|AT],
'chr new_merge_attributes'([Pos1-L1|AT1],AT2,AT)
;
'chr merge_attributes'(L1,L2,L),
A = [Pos1-L|AT],
'chr new_merge_attributes'(AT1,AT2,AT)
).
'chr all_suspensions'([],_,_).
'chr all_suspensions'([Susps|SuspsList],Pos,Attr) :-
all_suspensions(Attr,Susps,SuspsList,Pos).
all_suspensions([],[],SuspsList,Pos) :-
all_suspensions([],[],SuspsList,Pos). % all empty lists
all_suspensions([APos-ASusps|RAttr],Susps,SuspsList,Pos) :-
NPos is Pos + 1,
( Pos == APos ->
Susps = ASusps,
'chr all_suspensions'(SuspsList,NPos,RAttr)
;
Susps = [],
'chr all_suspensions'(SuspsList,NPos,[APos-ASusps|RAttr])
).
'chr normalize_attr'([],[]).
'chr normalize_attr'([Pos-L|R],[Pos-NL|NR]) :-
sort(L,NL),
'chr normalize_attr'(R,NR).
'chr select'([E|T],F,R) :-
( E = F ->
R = T
;
R = [E|NR],
'chr select'(T,F,NR)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- multifile
@ -518,7 +663,7 @@ sbag_merge([X | Xs],YL,R) :-
chr:debug_interact/3. % +Event, +Depth, -Command
'chr debug_event'(Event) :-
nb_getval(chr_debug,mutable(State)),
nb_getval(chr_debug,mutable(State)), % XXX
( State == off ->
true
; chr:debug_event(State, Event) ->
@ -559,11 +704,18 @@ valid_ports([H|T], Valid) :-
),
valid_ports(T, Valid).
user:exception(undefined_global_variable, Name, retry) :-
chr_runtime_debug_global_variable(Name),
chr_debug_init.
:- initialization
chr_runtime_debug_global_variable(chr_leash).
chr_debug_init :-
leashed_ports(default, Ports),
nb_setval(chr_leash, mutable(Ports)).
:- initialization chr_debug_init.
% debug_event(+State, +Event)

305
LGPL/chr/chr_swi.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_swi.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_swi.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers and Jan Wielemaker
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -29,11 +29,13 @@
the GNU General Public License.
*/
%% SWI begin
:- module(chr,
[ op( 700, xfx, ::),
op(1180, xfx, ==>),
[ op(1180, xfx, ==>),
op(1180, xfx, <=>),
op(1150, fx, constraints),
op(1150, fx, chr_constraint),
op(1150, fx, chr_preprocessor),
op(1150, fx, handler),
op(1150, fx, rules),
op(1100, xfx, \),
@ -49,6 +51,7 @@
chr_notrace/0,
chr_leash/1 % +Ports
]).
:- set_prolog_flag(generate_debug_info, false).
:- multifile user:file_search_path/2.
@ -57,15 +60,58 @@
user:file_search_path(chr, library(chr)).
:- use_module(chr(chr_translate)).
:- use_module(chr(chr_runtime)).
:- use_module(chr(chr_debug)).
:- use_module(chr(chr_messages)).
:- use_module(library(gensym)).
:- use_module(chr(chr_hashtable_store)).
:- load_files([ chr(chr_translate),
chr(chr_runtime),
chr(chr_messages),
chr(chr_hashtable_store),
chr(chr_compiler_errors)
],
[ if(not_loaded),
silent(true)
]).
:- dynamic
chr_term/2. % File, Term
:- use_module(library(lists),[member/2]).
%% SWI end
%% SICStus begin
%% :- module(chr,[
%% chr_trace/0,
%% chr_notrace/0,
%% chr_leash/0,
%% chr_flag/3,
%% chr_show_store/1
%% ]).
%%
%% :- op(1180, xfx, ==>),
%% op(1180, xfx, <=>),
%% op(1150, fx, constraints),
%% op(1150, fx, handler),
%% op(1150, fx, rules),
%% op(1100, xfx, \),
%% op(1200, xfx, @),
%% op(1190, xfx, pragma),
%% op( 500, yfx, #),
%% op(1150, fx, chr_type),
%% op(1130, xfx, --->),
%% op(1150, fx, (?)).
%%
%% :- multifile user:file_search_path/2.
%% :- dynamic chr_translated_program/1.
%%
%% user:file_search_path(chr, library(chr)).
%%
%%
%% :- use_module('chr/chr_translate').
%% :- use_module('chr/chr_runtime').
%% :- use_module('chr/chr_hashtable_store').
%% :- use_module('chr/hprolog').
%% SICStus end
:- multifile chr:'$chr_module'/1.
:- dynamic chr_term/3. % File, Term
:- dynamic chr_pp/2. % File, Term
% chr_expandable(+Term)
%
@ -77,73 +123,80 @@ user:file_search_path(chr, library(chr)).
% :- end_constraints.
%
% As they are not we have to use some heuristics. We assume any
% file is a CHR after we've seen :- constraints ... or if the file
% is named *.chr
% file is a CHR after we've seen :- constraints ...
chr_expandable((:- constraints _)).
chr_expandable((constraints _)).
chr_expandable((:- chr_constraint _)).
chr_expandable((:- chr_type _)).
chr_expandable((chr_type _)).
chr_expandable((handler _)) :-
is_chr_file.
chr_expandable((rules _)) :-
is_chr_file.
chr_expandable((_ <=> _)) :-
is_chr_file.
chr_expandable((_ @ _)) :-
is_chr_file.
chr_expandable((_ ==> _)) :-
is_chr_file.
chr_expandable((_ pragma _)) :-
is_chr_file.
chr_expandable(option(_, _)) :-
is_chr_file.
is_chr_file :- true.
/*
source_location(File, _Line),
( chr_term(File, _)
-> true
; file_name_extension(_, chr, File)
).
*/
chr_expandable(option(_, _)).
chr_expandable((:- chr_option(_, _))).
chr_expandable((handler _)).
chr_expandable((rules _)).
chr_expandable((_ <=> _)).
chr_expandable((_ @ _)).
chr_expandable((_ ==> _)).
chr_expandable((_ pragma _)).
% chr_expand(+Term, -Expansion)
%
% Extract CHR declarations and rules from the file and run the
% CHR compiler when reaching end-of-file.
%% SWI begin
extra_declarations([(:- use_module(chr(chr_runtime)))
,(:- style_check(-discontiguous)) % no need to restore; file ends
,(:- set_prolog_flag(generate_debug_info, false))
| Tail], Tail).
%% SWI end
%% SICStus begin
%% extra_declarations([(:-use_module(chr(chr_runtime)))
%% , (:- use_module(chr(hprolog),[term_variables/2,term_variables/3]))
%% , (:-use_module(chr(hpattvars)))
%% | Tail], Tail).
%% SICStus end
chr_expand(Term, []) :-
chr_expandable(Term), !,
source_location(File, _Line),
assert(chr_term(File, Term)).
chr_expand(end_of_file,
[ (:- use_module(chr(chr_runtime))),
(:- style_check(-(discontiguous))), % no need to restore; file ends
(:- set_prolog_flag(generate_debug_info, false))
| Program
]) :-
is_chr_file,
source_location(File, _Line),
findall(T, retract(chr_term(File, T)), CHR0),
prolog_load_context(file,File),
prolog_load_context(term_position,'$stream_position'(_, LineNumber, _, _, _)),
add_pragma_to_chr_rule(Term,line_number(LineNumber),NTerm),
assert(chr_term(File, LineNumber, NTerm)).
chr_expand(Term, []) :-
Term = (:- chr_preprocessor(Preprocessor)), !,
prolog_load_context(file,File),
assert(chr_pp(File, Preprocessor)).
chr_expand(end_of_file, FinalProgram) :-
extra_declarations(FinalProgram,Program),
prolog_load_context(file,File),
findall(T, retract(chr_term(File,_Line,T)), CHR0),
CHR0 \== [],
% length(CHR0, NDecls),
% format('Translating ~w declarations~n', [NDecls]),
prolog_load_context(module, Module),
( Module == user
-> ( memberchk(handler(Handler), CHR0)
-> true
; gensym(chr_handler, Handler)
)
; Handler = Module
),
add_debug_decl(CHR0, CHR1),
add_optimise_decl(CHR1, CHR),
call_chr_translate(File,
[ (:- module(Handler, []))
add_optimise_decl(CHR1, CHR2),
CHR3 = [ (:- module(Module, [])) | CHR2 ],
findall(P, retract(chr_pp(File, P)), Preprocessors),
( Preprocessors = [] ->
CHR3 = CHR
; Preprocessors = [Preprocessor] ->
chr_compiler_errors:chr_info(preprocessor,'\tPreprocessing with ~w.\n',[Preprocessor]),
call_chr_preprocessor(Preprocessor,CHR3,CHR)
;
chr_compiler_errors:print_chr_error(error(syntax(Preprocessors),'Too many preprocessors! Only one is allowed!\n',[])),
fail
),
catch(call_chr_translate(File,
[ (:- module(Module, []))
| CHR
],
Program0),
chr_error(Error),
( chr_compiler_errors:print_chr_error(Error),
fail
)
),
delete_header(Program0, Program).
@ -152,37 +205,56 @@ delete_header([(:- module(_,_))|T0], T) :- !,
delete_header(L, L).
add_debug_decl(CHR, CHR) :-
memberchk(option(debug, _), CHR), !.
add_debug_decl(CHR, [option(debug, Debug)|CHR]) :-
( current_prolog_flag(generate_debug_info, true)
member(option(Name, _), CHR), Name == debug, !.
add_debug_decl(CHR, CHR) :-
member((:- chr_option(Name, _)), CHR), Name == debug, !.
add_debug_decl(CHR, [(:- chr_option(debug, Debug))|CHR]) :-
( chr_current_prolog_flag(generate_debug_info, true)
-> Debug = on
; Debug = off
).
%% SWI begin
chr_current_prolog_flag(Flag,Val) :- current_prolog_flag(Flag,Val).
%% SWI end
add_optimise_decl(CHR, CHR) :-
memberchk(option(optimize, _), CHR), !.
add_optimise_decl(CHR, [option(optimize, full)|CHR]) :-
current_prolog_flag(optimize, true), !.
\+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !.
add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :-
chr_current_prolog_flag(optimize, full), !.
add_optimise_decl(CHR, CHR).
% call_chr_translate(+File, +In, -Out)
%
% The entire chr_translate/2 translation may fail, in which we'd
% The entire chr_translate/2 translation may fail, in which case we'd
% better issue a warning rather than simply ignoring the CHR
% declarations.
call_chr_translate(_, In, _Out) :-
( chr_translate(In, Out0) ->
nb_setval(chr_translated_program,Out0),
fail
).
call_chr_translate(File, In, _Out) :-
( chr_translate_line_info(In, File, Out0) ->
nb_setval(chr_translated_program,Out0),
fail
).
call_chr_translate(_, _In, Out) :-
nb_current(chr_translated_program,Out),!,nb_delete(chr_translated_program).
nb_current(chr_translated_program,Out), !,
nb_delete(chr_translated_program).
call_chr_translate(File, _, []) :-
print_message(error, chr(compilation_failed(File))).
call_chr_preprocessor(Preprocessor,CHR,_NCHR) :-
( call(Preprocessor,CHR,CHR0) ->
nb_setval(chr_preprocessed_program,CHR0),
fail
).
call_chr_preprocessor(_,_,NCHR) :-
nb_current(chr_preprocessed_program,NCHR), !,
nb_delete(chr_preprocessed_program).
call_chr_preprocessor(Preprocessor,_,_) :-
chr_compiler_errors:print_chr_error(error(preprocessor,'Preprocessor `~w\' failed!\n',[Preprocessor])).
%% SWI begin
/*******************************
* SYNCHRONISE TRACER *
@ -248,8 +320,6 @@ prolog:message(chr(CHR)) -->
:- set_prolog_flag(chr_toplevel_show_store,true).
:- multifile chr:'$chr_module'/1.
prolog:message(query(YesNo)) --> !,
['~@'-[chr:print_all_stores]],
'$messages':prolog_message(query(YesNo)).
@ -259,7 +329,7 @@ prolog:message(query(YesNo,Bindings)) --> !,
'$messages':prolog_message(query(YesNo,Bindings)).
print_all_stores :-
( current_prolog_flag(chr_toplevel_show_store,true),
( chr_current_prolog_flag(chr_toplevel_show_store,true),
catch(nb_getval(chr_global, _), _, fail),
chr:'$chr_module'(Mod),
chr_show_store(Mod),
@ -277,5 +347,84 @@ print_all_stores :-
user:term_expansion(In, Out) :-
chr_expand(In, Out).
%% SWI end
%% SICStus begin
%
% :- dynamic
% current_toplevel_show_store/1,
% current_generate_debug_info/1,
% current_optimize/1.
%
% current_toplevel_show_store(on).
%
% current_generate_debug_info(false).
%
% current_optimize(off).
%
% chr_current_prolog_flag(generate_debug_info, X) :-
% chr_flag(generate_debug_info, X, X).
% chr_current_prolog_flag(optimize, X) :-
% chr_flag(optimize, X, X).
%
% chr_flag(Flag, Old, New) :-
% Goal = chr_flag(Flag,Old,New),
% g must_be(Flag, oneof([toplevel_show_store,generate_debug_info,optimize]), Goal, 1),
% chr_flag(Flag, Old, New, Goal).
%
% chr_flag(toplevel_show_store, Old, New, Goal) :-
% clause(current_toplevel_show_store(Old), true, Ref),
% ( New==Old -> true
% ; must_be(New, oneof([on,off]), Goal, 3),
% erase(Ref),
% assertz(current_toplevel_show_store(New))
% ).
% chr_flag(generate_debug_info, Old, New, Goal) :-
% clause(current_generate_debug_info(Old), true, Ref),
% ( New==Old -> true
% ; must_be(New, oneof([false,true]), Goal, 3),
% erase(Ref),
% assertz(current_generate_debug_info(New))
% ).
% chr_flag(optimize, Old, New, Goal) :-
% clause(current_optimize(Old), true, Ref),
% ( New==Old -> true
% ; must_be(New, oneof([full,off]), Goal, 3),
% erase(Ref),
% assertz(current_optimize(New))
% ).
%
%
% all_stores_goal(Goal, CVAs) :-
% chr_flag(toplevel_show_store, on, on), !,
% findall(C-CVAs, find_chr_constraint(C), Pairs),
% andify(Pairs, Goal, CVAs).
% all_stores_goal(true, _).
%
% andify([], true, _).
% andify([X-Vs|L], Conj, Vs) :- andify(L, X, Conj, Vs).
%
% andify([], X, X, _).
% andify([Y-Vs|L], X, (X,Conj), Vs) :- andify(L, Y, Conj, Vs).
%
% :- multifile user:term_expansion/6.
%
% user:term_expansion(In, _, Ids, Out, [], [chr|Ids]) :-
% nonvar(In),
% nonmember(chr, Ids),
% chr_expand(In, Out), !.
%
%% SICStus end
%%% for SSS %%%
add_pragma_to_chr_rule((Name @ Rule), Pragma, Result) :- !,
add_pragma_to_chr_rule(Rule,Pragma,NRule),
Result = (Name @ NRule).
add_pragma_to_chr_rule((Rule pragma Pragmas), Pragma, Result) :- !,
Result = (Rule pragma (Pragma,Pragmas)).
add_pragma_to_chr_rule((Head ==> Body), Pragma, Result) :- !,
Result = ((Head ==> Body) pragma Pragma).
add_pragma_to_chr_rule((Head <=> Body), Pragma, Result) :- !,
Result = ((Head <=> Body) pragma Pragma).
add_pragma_to_chr_rule(Term,_,Term).

90
LGPL/chr/chr_swi_bootstrap.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_swi_bootstrap.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_swi_bootstrap.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -29,18 +29,17 @@
the GNU General Public License.
*/
:- module(chr,
[ chr_compile_step1/2 % +CHRFile, -PlFile
, chr_compile_step2/2 % +CHRFile, -PlFile
, chr_compile_step3/2 % +CHRFile, -PlFile
, chr_compile_step4/2 % +CHRFile, -PlFile
, chr_compile/3
]).
%% SWI begin
:- use_module(library(listing)). % portray_clause/2
:- include('chr_op').
%% SWI end
:- include(chr_op).
/*******************************
* FILE-TO-FILE COMPILER *
@ -77,19 +76,31 @@ chr_compile(From, To, MsgLevel) :-
print_message(MsgLevel, chr(end(From, To))).
insert_declarations(Clauses0, Clauses) :- %vsc
( Clauses0 = [(:- module(M,E))|FileBody]
-> Clauses = [ (:- module(M,E)),
(:- use_module('chr_runtime')),
(:- style_check(-singleton)),
(:- style_check(-discontiguous))
| FileBody
]
; Clauses = [ (:- use_module('chr_runtime')),
(:- style_check(-singleton)),
(:- style_check(-discontiguous))
| Clauses0
]
%% SWI begin with yap change
specific_declarations([(:- use_module('chr_runtime')),
(:- style_check(-discontiguous))|Tail], Tail).
%% SWI end
%% SICStus begin
%% specific_declarations([(:- use_module('chr_runtime')),
%% (:-use_module(chr_hashtable_store)),
%% (:- use_module('hpattvars')),
%% (:- use_module('b_globval')),
%% (:- use_module('hprolog')), % needed ?
%% (:- set_prolog_flag(discontiguous_warnings,off)),
%% (:- set_prolog_flag(single_var_warnings,off))|Tail], Tail).
%% SICStus end
insert_declarations(Clauses0, Clauses) :-
specific_declarations(Decls,Tail),
(Clauses0 = [(:- module(M,E))|FileBody] ->
Clauses = [ (:- module(M,E))|Decls],
Tail = FileBody
;
Clauses = Decls,
Tail = Clauses0
).
% writefile(+File, +From, +Desclarations)
@ -109,14 +120,27 @@ writecontent([D|Ds], Out) :-
writeheader(File, Out) :-
get_time(Now),
convert_time(Now, Date),
format(Out, '/* Generated by CHR bootstrap compiler~n', []),
format(Out, ' From: ~w~n', [File]),
format(Out, ' Date: ~w~n~n', [Date]),
format_date(Out),
format(Out, ' DO NOT EDIT. EDIT THE CHR FILE INSTEAD~n', []),
format(Out, '*/~n~n', []).
%% SWI begin
format_date(Out) :-
get_time(Now),
convert_time(Now, Date),
format(Out, ' Date: ~s~n~n', [Date]). % yap change
%% SWI end
%% SICStus begin
%% :- use_module(library(system), [datime/1]).
%% format_date(Out) :-
%% datime(datime(Year,Month,Day,Hour,Min,Sec)),
%% format(Out, ' Date: ~d-~d-~d ~d:~d:~d~n~n', [Day,Month,Year,Hour,Min,Sec]).
%% SICStus end
/*******************************
* MESSAGES *
@ -137,14 +161,13 @@ prolog:message(chr(end(_From, To))) -->
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
read_chr_file_to_terms(Spec, Terms) :-
absolute_file_name(Spec, [ access(read) ],
Path),
chr_absolute_file_name(Spec, [ access(read) ], Path),
open(Path, read, Fd, []),
read_chr_stream_to_terms(Fd, Terms),
close(Fd).
read_chr_stream_to_terms(Fd, Terms) :-
read_term(Fd, C0, [ module(chr) ]),
chr_local_only_read_term(Fd, C0, [ module(chr) ]),
read_chr_stream_to_terms(C0, Fd, Terms).
read_chr_stream_to_terms(end_of_file, _, []) :- !.
@ -155,5 +178,18 @@ read_chr_stream_to_terms(C, Fd, [C|T]) :-
;
true
),
read_term(Fd, C2, [module(chr)]),
chr_local_only_read_term(Fd, C2, [module(chr)]),
read_chr_stream_to_terms(C2, Fd, T).
%% SWI begin
chr_local_only_read_term(A,B,C) :- read_term(A,B,C).
chr_absolute_file_name(A,B,C) :- absolute_file_name(A,B,C).
%% SWI end
%% SICStus begin
%% chr_local_only_read_term(A,B,_) :- read_term(A,B,[]).
%% chr_absolute_file_name(A,B,C) :- absolute_file_name(A,C,B).
%% SICStus end

41
LGPL/chr/chr_test.pl
View File

@ -1,26 +1,44 @@
/* $Id: chr_test.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_test.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
E-mail: jan@swi.psy.uva.nl
Part of CHR (Constraint Handling Rules)
Copyright (C) 1996 University of Amsterdam. All rights reserved.
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2005,2006, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- asserta(user:file_search_path(chr, '.')).
:- asserta(user:file_search_path(library, '.')).
:- use_module(chr). % == library(chr)
:- use_module(library(chr)).
%% :- use_module(chr). % == library(chr)
:- set_prolog_flag(optimise, true).
%:- set_prolog_flag(trace_gc, true).
:- format('CHR test suite. To run all tests run ?- test.~n~n', []).
% Required to get this always running regardless of user LANG setting.
% Without this the tests won't run on machines with -for example- LANG=ja
% according to NIDE Naoyuki, nide@ics.nara-wu.ac.jp. Thanks!
:- getenv('LANG', _) -> setenv('LANG', 'C'); true.
/*******************************
* SCRIPTS *
*******************************/
@ -50,6 +68,7 @@ follow_links(File, File).
run_test_script(Script) :-
file_base_name(Script, Base),
file_name_extension(Pred, _, Base),
format(' ~w~n',[Script]),
load_files(Script, []), %[silent(true)]),
Pred.

8918
LGPL/chr/chr_translate.chr
View File

File diff suppressed because it is too large Load Diff

127
LGPL/chr/chr_translate_bootstrap.pl
View File

@ -1,9 +1,9 @@
/* $Id: chr_translate_bootstrap.pl,v 1.3 2006-01-08 23:04:41 vsc Exp $
/* $Id: chr_translate_bootstrap.pl,v 1.4 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -40,7 +40,7 @@
%%
%% hProlog CHR compiler:
%%
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
%%
%% * based on the SICStus CHR compilation by Christian Holzbaur
%%
@ -121,11 +121,12 @@
:- module(chr_translate,
[ chr_translate/2 % +Decls, -TranslatedDecls
]).
:- use_module(library(lists)).
:- use_module(hprolog).
:- use_module(library(assoc)).
:- use_module(pairlist).
%% SWI begin
:- use_module(library(lists),[member/2,append/3,permutation/2,reverse/2]).
:- use_module(library(ordsets)).
%% SWI end
:- use_module(hprolog).
:- use_module(pairlist).
:- include(chr_op).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -146,14 +147,14 @@ chr_translate(Declarations,NewDeclarations) :-
generate_attach_increment(Decls,Mod,AttachIncrementClauses),
generate_attr_unify_hook(Decls,Mod,AttrUnifyHookClauses),
constraints_code(Decls,NRules,Mod,ConstraintClauses),
append_lists([ OtherClauses,
AttachAConstraintClauses,
DettachAConstraintClauses,
AttachIncrementClauses,
AttrUnifyHookClauses,
ConstraintClauses
],
NewDeclarations)
append([ OtherClauses,
AttachAConstraintClauses,
DettachAConstraintClauses,
AttachIncrementClauses,
AttrUnifyHookClauses,
ConstraintClauses
],
NewDeclarations)
).
@ -189,7 +190,7 @@ partition_clauses([C|Cs],Ds,Rs,OCs,Mod) :-
Ds = RDs,
Rs = RRs,
OCs = ROCs
; C = option(OptionName,OptionValue) ->
; C = (:- chr_option(OptionName,OptionValue)) ->
handle_option(OptionName,OptionValue),
Ds = RDs,
Rs = RRs,
@ -201,12 +202,8 @@ partition_clauses([C|Cs],Ds,Rs,OCs,Mod) :-
partition_clauses(Cs,RDs,RRs,ROCs,Mod).
is_declaration(D, Constraints) :- %% constraint declaration
( D = (:- Decl) ->
true
;
D = Decl
),
Decl =.. [constraints,Cs],
D = (:- Decl),
( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
conj2list(Cs,Constraints).
%% Data Declaration
@ -355,7 +352,7 @@ check_pragma(passive(ID), PragmaRule, N) :-
check_pragma(Pragma, PragmaRule, N) :-
Pragma = unique(_,_),
!,
format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule,N)]),
format(' `--> Only use this pragma if you know what you are doing.\n',[]).
check_pragma(Pragma, PragmaRule, N) :-
@ -540,11 +537,11 @@ generate_attach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
or_pattern(Position,Pattern),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1),
make_attr(Total,Mask,SuspsList1,NewAttr1),
substitute(Susps,SuspsList,[Susp],SuspsList2),
substitute_eq(Susps,SuspsList,[Susp],SuspsList2),
make_attr(Total,NewMask,SuspsList2,NewAttr2),
copy_term(SuspsList,SuspsList3),
copy_term_nat(SuspsList,SuspsList3),
nth(Position,SuspsList3,[Susp]),
chr_delete(SuspsList3,[Susp],RestSuspsList),
set_elems(RestSuspsList,[]),
@ -622,9 +619,9 @@ generate_detach_a_constraint_t_p(Total,Position,CFct / CAty ,Mod,Clause) :-
and_pattern(Position,DelPattern),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
substitute(Susps,SuspsList,[],SuspsList1),
substitute_eq(Susps,SuspsList,[],SuspsList1),
make_attr(Total,NewMask,SuspsList1,Attr1),
substitute(Susps,SuspsList,NewSusps,SuspsList2),
substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
make_attr(Total,Mask,SuspsList2,Attr2),
Body =
(
@ -1101,7 +1098,7 @@ unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
Ids = ids(Ids1,Ids2),
apply_unique_patterns_to_constraints(H1,Ids1,NPatternList,MorePragmas1),
apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
append([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
NPRule = pragma(Rule,Ids,NPragmas,Name),
N1 is N + 1,
unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
@ -1140,9 +1137,9 @@ apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
% variables from Term2 and their corresponding values in Term1.
subsumes(Term1,Term2,Unifier) :-
empty_assoc(S0),
empty_ds(S0),
subsumes_aux(Term1,Term2,S0,S),
assoc_to_list(S,L),
ds_to_list(S,L),
build_unifier(L,Unifier).
subsumes_aux(Term1, Term2, S0, S) :-
@ -1153,10 +1150,10 @@ subsumes_aux(Term1, Term2, S0, S) :-
; Term1 == Term2
-> S = S0
; var(Term2),
get_assoc(Term1,S0,V)
get_ds(Term1,S0,V)
-> V == Term2, S = S0
; var(Term2),
put_assoc(Term1, S0, Term2, S)
put_ds(Term1, S0, Term2, S)
).
subsumes_aux(0, _, _, S, S) :- ! .
@ -1182,8 +1179,8 @@ discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
term_variables(C1,Vs),
select_pragma_unique_variables(List,Vs,Key),
Pattern0 = unique(C1,Key),
copy_term(Pattern0,Pattern),
( prolog_flag(verbose,V), V == yes ->
copy_term_nat(Pattern0,Pattern),
( verbosity_on ->
format('Found unique pattern ~w in rule ~d~@\n',
[Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
;
@ -1428,7 +1425,7 @@ rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,Act
nth(Pos,SuspsList,VarSusps)
),
different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
create_get_mutable(active,State,GetMutable),
create_get_mutable_ref(active,State,GetMutable),
Goal1 =
(
'chr sbag_member'(Susp,VarSusps),
@ -1495,7 +1492,7 @@ common_variables(T,Ts,Vs) :-
gen_get_mod_constraints(Mod,L,Goal,Susps) :-
( L == [] ->
Goal =
( 'chr global_term_ref_1'(Global),
( 'chr default_store'(Global),
get_attr(Global,Mod,TSusps),
TSusps = Susps
)
@ -1768,7 +1765,7 @@ simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Ru
head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
create_get_mutable(active,OtherState,GetMutable),
create_get_mutable_ref(active,OtherState,GetMutable),
IteratorSuspTest =
( OtherSusp = OtherSuspension,
GetMutable
@ -1842,8 +1839,8 @@ simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Ru
gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
length(Args,N),
Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
create_get_mutable(active,State,GetState),
create_get_mutable(Generation,NewGeneration,GetGeneration),
create_get_mutable_ref(active,State,GetState),
create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
ConditionalCall =
( Susp = Suspension,
GetState,
@ -1988,7 +1985,7 @@ propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Mod,Id,L,T) :-
functor(CurrentHead,_OtherF,OtherA),
gen_vars(OtherA,OtherVars),
Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
create_get_mutable(active,State,GetMutable),
create_get_mutable_ref(active,State,GetMutable),
CurrentSuspTest = (
OtherSusp = Suspension,
GetMutable
@ -2111,7 +2108,7 @@ propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,N,C
OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
create_get_mutable(active,State,GetMutable),
create_get_mutable_ref(active,State,GetMutable),
CurrentSuspTest = (
OtherSusp = OtherSuspension,
GetMutable,
@ -2281,14 +2278,15 @@ order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
%% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
%% |___/
create_get_mutable(V,M,GM) :-
GM = (M = mutable(V)).
% GM = 'chr get_mutable'(V,M)
%( ground(V) ->
% GM = (M == mutable(V))
%;
% GM = (M = mutable(V))
%).
%% SWI begin
create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
%% SWI end
%% SICStus begin
%% create_get_mutable_ref(V,M,GM) :- GM = (get_mutable(V,M)).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -2415,14 +2413,14 @@ build_head(F,A,Id,Args,Head) :-
buildName(Fct,Aty,List,Result) :-
atom_concat(Fct, (/) ,FctSlash),
atom_concat(FctSlash,Aty,FctSlashAty),
atomic_concat(FctSlash,Aty,FctSlashAty),
buildName_(List,FctSlashAty,Result).
buildName_([],Name,Name).
buildName_([N|Ns],Name,Result) :-
buildName_(Ns,Name,Name1),
atom_concat(Name1,'__',NameDash), % '_' is a char :-(
atom_concat(NameDash,N,Result).
atomic_concat(NameDash,N,Result).
vars_susp(A,Vars,Susp,VarsSusp) :-
length(Vars,A),
@ -2463,7 +2461,23 @@ list2conj([G|Gs],C) :-
atom_concat_list([X],X) :- ! .
atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
atom_concat(X,B,A).
atomic_concat(X,B,A).
atomic_concat(A,B,C) :-
make_atom(A,AA),
make_atom(B,BB),
atom_concat(AA,BB,C).
make_atom(A,AA) :-
(
atom(A) ->
AA = A
;
number(A) ->
number_codes(A,AL),
atom_codes(AA,AL)
).
set_elems([],_).
set_elems([X|Xs],X) :-
@ -2486,3 +2500,10 @@ default(X,Def) :-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% SWI begin
verbosity_on :- prolog_flag(verbose,V), V == yes.
%% SWI end
%% SICStus begin
%% verbosity_on. % at the moment
%% SICStus end

4945
LGPL/chr/chr_translate_bootstrap1.chr
View File

File diff suppressed because it is too large Load Diff

352
LGPL/chr/chr_translate_bootstrap2.chr
View File

@ -1,9 +1,9 @@
/* $Id: chr_translate_bootstrap2.chr,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: chr_translate_bootstrap2.chr,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -40,7 +40,7 @@
%%
%% hProlog CHR compiler:
%%
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.ac.be
%% * by Tom Schrijvers, K.U. Leuven, Tom.Schrijvers@cs.kuleuven.be
%%
%% * based on the SICStus CHR compilation by Christian Holzbaur
%%
@ -112,22 +112,24 @@
:- module(chr_translate,
[ chr_translate/2 % +Decls, -TranslatedDecls
]).
:- use_module(library(lists)).
:- use_module(hprolog).
:- use_module(library(assoc)).
:- use_module(pairlist).
%% SWI begin
:- use_module(library(lists),[append/3,member/2,delete/3,reverse/2,permutation/2]).
:- use_module(library(ordsets)).
%% SWI end
:- use_module(hprolog).
:- use_module(pairlist).
:- use_module(a_star).
:- use_module(clean_code).
:- use_module(builtins).
:- use_module(find).
:- include(chr_op2).
option(debug,off).
option(optimize,full).
:- chr_option(debug,off).
:- chr_option(optimize,full).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- constraints
:- chr_constraint
constraint/2, % constraint(F/A,ConstraintIndex)
get_constraint/2,
@ -187,25 +189,25 @@ option(optimize,full).
get_rule/2
.
option(mode,constraint(+,+)).
option(mode,constraint_count(+)).
option(mode,constraint_index(+,+)).
option(mode,max_constraint_index(+)).
option(mode,target_module(+)).
option(mode,attached(+,+)).
option(mode,indexed_argument(+,+)).
option(mode,constraint_mode(+,+)).
option(mode,may_trigger(+)).
option(mode,store_type(+,+)).
option(mode,actual_store_types(+,+)).
option(mode,assumed_store_type(+,+)).
option(mode,rule_count(+)).
option(mode,passive(+,+)).
option(mode,pragma_unique(+,+,?)).
option(mode,occurrence(+,+,+,+)).
option(mode,max_occurrence(+,+)).
option(mode,allocation_occurrence(+,+)).
option(mode,rule(+,+)).
:- chr_option(mode,constraint(+,+)).
:- chr_option(mode,constraint_count(+)).
:- chr_option(mode,constraint_index(+,+)).
:- chr_option(mode,max_constraint_index(+)).
:- chr_option(mode,target_module(+)).
:- chr_option(mode,attached(+,+)).
:- chr_option(mode,indexed_argument(+,+)).
:- chr_option(mode,constraint_mode(+,+)).
:- chr_option(mode,may_trigger(+)).
:- chr_option(mode,store_type(+,+)).
:- chr_option(mode,actual_store_types(+,+)).
:- chr_option(mode,assumed_store_type(+,+)).
:- chr_option(mode,rule_count(+)).
:- chr_option(mode,passive(+,+)).
:- chr_option(mode,pragma_unique(+,+,?)).
:- chr_option(mode,occurrence(+,+,+,+)).
:- chr_option(mode,max_occurrence(+,+)).
:- chr_option(mode,allocation_occurrence(+,+)).
:- chr_option(mode,rule(+,+)).
constraint(FA,Index) \ get_constraint(Query,Index)
<=> Query = FA.
@ -382,12 +384,12 @@ chr_translate(Declarations,NewDeclarations) :-
store_management_preds(Constraints,StoreClauses), % depends on actual code used
insert_declarations(OtherClauses, Clauses0),
chr_module_declaration(CHRModuleDeclaration),
append_lists([Clauses0,
StoreClauses,
ConstraintClauses,
CHRModuleDeclaration
],
NewDeclarations)
append([Clauses0,
StoreClauses,
ConstraintClauses,
CHRModuleDeclaration
],
NewDeclarations)
).
store_management_preds(Constraints,Clauses) :-
@ -398,30 +400,40 @@ store_management_preds(Constraints,Clauses) :-
generate_extra_clauses(Constraints,ExtraClauses),
generate_insert_delete_constraints(Constraints,DeleteClauses),
generate_store_code(Constraints,StoreClauses),
append_lists([AttachAConstraintClauses
,IndexedClauses
,AttachIncrementClauses
,AttrUnifyHookClauses
,ExtraClauses
,DeleteClauses
,StoreClauses]
,Clauses).
append([AttachAConstraintClauses
,IndexedClauses
,AttachIncrementClauses
,AttrUnifyHookClauses
,ExtraClauses
,DeleteClauses
,StoreClauses]
,Clauses).
%% SWI begin vsc: yap changes
specific_declarations([(:- use_module('chr_runtime'))
,(:- use_module('chr_hashtable_store'))
,(:- style_check(-discontiguous))
|Tail],Tail).
%% SWI end
%% SICStus begin
%% specific_declarations([(:- use_module('chr_runtime')),
%% (:- use_module('chr_hashtable_store')),
%% (:- set_prolog_flag(discontiguous_warnings,off)),
%% (:- set_prolog_flag(single_var_warnings,off))
%% |Tail],Tail).
%% SICStus end
insert_declarations(Clauses0, Clauses) :-
( Clauses0 = [(:- module(M,E))|FileBody]
-> Clauses = [ (:- module(M,E)),
(:- use_module('chr_runtime')),
(:- use_module('chr_hashtable_store')),
(:- style_check(-singleton)),
(:- style_check(-discontiguous))
| FileBody
]
; Clauses = [ (:- use_module('chr_runtime')),
(:- use_module('chr_hashtable_store')),
(:- style_check(-singleton)),
(:- style_check(-discontiguous))
| Clauses0
]
specific_declarations(Decls,Tail),
( Clauses0 = [ (:- module(M,E))|FileBody] ->
Clauses = [ (:- module(M,E))|Decls],
Tail = FileBody
;
Clauses = Decls,
Tail = Clauses0
).
@ -469,11 +481,15 @@ partition_clauses([C|Cs],Ds,Rs,OCs) :-
Ds = RDs,
Rs = RRs,
OCs = ROCs
; C = option(OptionName,OptionValue) ->
; C = (:- chr_option(OptionName,OptionValue)) ->
handle_option(OptionName,OptionValue),
Ds = RDs,
Rs = RRs,
OCs = ROCs
; C = (:- chr_type _) ->
Ds = RDs,
Rs = RRs,
OCs = ROCs
; Ds = RDs,
Rs = RRs,
OCs = [C|ROCs]
@ -481,12 +497,8 @@ partition_clauses([C|Cs],Ds,Rs,OCs) :-
partition_clauses(Cs,RDs,RRs,ROCs).
is_declaration(D, Constraints) :- %% constraint declaration
( D = (:- Decl) ->
true
;
D = Decl
),
Decl =.. [constraints,Cs],
D = (:- Decl),
( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
conj2list(Cs,Constraints).
%% Data Declaration
@ -648,7 +660,7 @@ check_pragma(Pragma, PragmaRule) :-
!,
PragmaRule = pragma(_,_,_,_,RuleNb),
pragma_unique(RuleNb,ID,Vars),
format('CHR compiler WARNING: undocument pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
format('CHR compiler WARNING: undocumented pragma ~w in ~@.\n',[Pragma,format_rule(PragmaRule)]),
format(' `--> Only use this pragma if you know what you are doing.\n',[]).
check_pragma(Pragma, PragmaRule) :-
@ -801,7 +813,7 @@ option_definition(optimize,experimental,Flags) :-
guard_via_reschedule - on
].
option_definition(optimize,full,Flags) :-
Flags = [ unique_analyse_optimise - on,
Flags = [ unique_analyse_optimise - off,
check_unnecessary_active - full,
reorder_heads - on,
set_semantics_rule - on,
@ -856,6 +868,7 @@ option_definition(debug,off,Flags) :-
Flags = [ debugable - off ].
option_definition(type_definition, _, []). % JW: ignored by bootstrap compiler
option_definition(type_declaration, _, []). % JW: ignored by bootstrap compiler
option_definition(verbosity,_,[]).
init_chr_pp_flags :-
chr_pp_flag_definition(Name,[DefaultValue|_]),
@ -911,7 +924,7 @@ generate_attach_detach_a_constraint_all([Constraint|Constraints],Clauses) :-
Clauses2 = []
),
generate_attach_detach_a_constraint_all(Constraints,Clauses3),
append_lists([Clauses1,Clauses2,Clauses3],Clauses).
append([Clauses1,Clauses2,Clauses3],Clauses).
generate_attach_a_constraint(Constraint,[Clause1,Clause2]) :-
generate_attach_a_constraint_empty_list(Constraint,Clause1),
@ -969,13 +982,13 @@ generate_attach_body_n(F/A,Var,Susp,Body) :-
or_pattern(Position,Pattern),
get_max_constraint_index(Total),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
substitute(Susps,SuspsList,[Susp|Susps],SuspsList1),
nth1(Position,SuspsList,Susps),
substitute_eq(Susps,SuspsList,[Susp|Susps],SuspsList1),
make_attr(Total,Mask,SuspsList1,NewAttr1),
substitute(Susps,SuspsList,[Susp],SuspsList2),
substitute_eq(Susps,SuspsList,[Susp],SuspsList2),
make_attr(Total,NewMask,SuspsList2,NewAttr2),
copy_term(SuspsList,SuspsList3),
nth(Position,SuspsList3,[Susp]),
copy_term_nat(SuspsList,SuspsList3),
nth1(Position,SuspsList3,[Susp]),
delete(SuspsList3,[Susp],RestSuspsList),
set_elems(RestSuspsList,[]),
make_attr(Total,Pattern,SuspsList3,NewAttr3),
@ -1055,10 +1068,10 @@ generate_detach_body_n(F/A,Var,Susp,Body) :-
and_pattern(Position,DelPattern),
get_max_constraint_index(Total),
make_attr(Total,Mask,SuspsList,Attr),
nth(Position,SuspsList,Susps),
substitute(Susps,SuspsList,[],SuspsList1),
nth1(Position,SuspsList,Susps),
substitute_eq(Susps,SuspsList,[],SuspsList1),
make_attr(Total,NewMask,SuspsList1,Attr1),
substitute(Susps,SuspsList,NewSusps,SuspsList2),
substitute_eq(Susps,SuspsList,NewSusps,SuspsList2),
make_attr(Total,Mask,SuspsList2,Attr2),
get_target_module(Mod),
Body =
@ -1157,7 +1170,7 @@ generate_remove_clause(RemoveClause) :-
(
remove_constraint_internal(Susp, Agenda, Delete) :-
arg( 2, Susp, Mref),
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
'chr get_mutable'( State, Mref),
'chr update_mutable'( removed, Mref), % mark in any case
( compound(State) -> % passive/1
Agenda = [],
@ -1178,13 +1191,13 @@ generate_activate_clause(ActivateClause) :-
(
activate_constraint(Store, Vars, Susp, Generation) :-
arg( 2, Susp, Mref),
Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
'chr get_mutable'( State, Mref),
'chr update_mutable'( active, Mref),
( nonvar(Generation) -> % aih
true
;
arg( 4, Susp, Gref),
Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
'chr get_mutable'( Gen, Gref),
Generation is Gen+1,
'chr update_mutable'( Generation, Gref)
),
@ -1206,11 +1219,11 @@ generate_allocate_clause(AllocateClause) :-
(
allocate_constraint( Closure, Self, F, Args) :-
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
Gref = mutable(0),
'chr create_mutable'(0,Gref), % Gref = mutable(0),
'chr empty_history'(History),
Href = mutable(History),
'chr create_mutable'(History,Href), % Href = mutable(History),
chr_indexed_variables(Self,Vars),
Mref = mutable(passive(Vars)),
'chr create_mutable'(passive(Vars),Mref), % Mref = mutable(passive(Vars)),
'chr gen_id'( Id)
).
@ -1221,10 +1234,10 @@ generate_insert_constraint_internal(Clause) :-
Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args],
chr_indexed_variables(Self,Vars),
'chr none_locked'(Vars),
Mref = mutable(active),
Gref = mutable(0),
Href = mutable(History),
'chr create_mutable'(active,Mref), % Mref = mutable(active),
'chr create_mutable'(0,Gref), % Gref = mutable(0),
'chr empty_history'(History),
'chr create_mutable'(History,Href), % Href = mutable(History),
'chr gen_id'(Id)
).
@ -1434,17 +1447,19 @@ generate_insert_constraint_body(default,C,Susp,Body) :-
),
Body =
(
'chr global_term_ref_1'(Store),
'chr default_store'(Store),
AttachBody
).
generate_insert_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
generate_multi_hash_insert_constraint_bodies(Indexes,C,Susp,Body).
generate_insert_constraint_body(global_ground,C,Susp,Body) :-
global_ground_store_name(C,StoreName),
make_get_store_goal(StoreName,Store,GetStoreGoal),
make_update_store_goal(StoreName,[Susp|Store],UpdateStoreGoal),
Body =
(
nb_getval(StoreName,Store),
b_setval(StoreName,[Susp|Store])
GetStoreGoal, % nb_getval(StoreName,Store),
UpdateStoreGoal % b_setval(StoreName,[Susp|Store])
).
generate_insert_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
find_with_var_identity(
@ -1462,10 +1477,11 @@ generate_multi_hash_insert_constraint_bodies([],_,_,true).
generate_multi_hash_insert_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
multi_hash_store_name(FA,Index,StoreName),
multi_hash_key(FA,Index,Susp,KeyBody,Key),
make_get_store_goal(StoreName,Store,GetStoreGoal),
Body =
(
KeyBody,
nb_getval(StoreName,Store),
GetStoreGoal, % nb_getval(StoreName,Store),
insert_ht(Store,Key,Susp)
),
generate_multi_hash_insert_constraint_bodies(Indexes,FA,Susp,Bodies).
@ -1483,14 +1499,14 @@ generate_delete_constraint_body(default,C,Susp,Body) :-
generate_detach_body_1(C,Store,Susp,DetachBody),
Body =
(
'chr global_term_ref_1'(Store),
'chr default_store'(Store),
DetachBody
)
;
generate_detach_body_n(C,Store,Susp,DetachBody),
Body =
(
'chr global_term_ref_1'(Store),
'chr default_store'(Store),
DetachBody
)
).
@ -1498,11 +1514,13 @@ generate_delete_constraint_body(multi_hash(Indexes),C,Susp,Body) :-
generate_multi_hash_delete_constraint_bodies(Indexes,C,Susp,Body).
generate_delete_constraint_body(global_ground,C,Susp,Body) :-
global_ground_store_name(C,StoreName),
make_get_store_goal(StoreName,Store,GetStoreGoal),
make_update_store_goal(StoreName,NStore,UpdateStoreGoal),
Body =
(
nb_getval(StoreName,Store),
GetStoreGoal, % nb_getval(StoreName,Store),
'chr sbag_del_element'(Store,Susp,NStore),
b_setval(StoreName,NStore)
UpdateStoreGoal % b_setval(StoreName,NStore)
).
generate_delete_constraint_body(multi_store(StoreTypes),C,Susp,Body) :-
find_with_var_identity(
@ -1520,10 +1538,11 @@ generate_multi_hash_delete_constraint_bodies([],_,_,true).
generate_multi_hash_delete_constraint_bodies([Index|Indexes],FA,Susp,(Body,Bodies)) :-
multi_hash_store_name(FA,Index,StoreName),
multi_hash_key(FA,Index,Susp,KeyBody,Key),
make_get_store_goal(StoreName,Store,GetStoreGoal),
Body =
(
KeyBody,
nb_getval(StoreName,Store),
GetStoreGoal, % nb_getval(StoreName,Store),
delete_ht(Store,Key,Susp)
),
generate_multi_hash_delete_constraint_bodies(Indexes,FA,Susp,Bodies).
@ -1565,21 +1584,24 @@ multi_store_generate_store_code([ST|STs],C,L,T) :-
multi_hash_store_initialisations([],_,L,L).
multi_hash_store_initialisations([Index|Indexes],FA,L,T) :-
multi_hash_store_name(FA,Index,StoreName),
L = [(:- (new_ht(HT),nb_setval(StoreName,HT)) )|L1],
make_init_store_goal(StoreName,HT,InitStoreGoal),
L = [(:- (new_ht(HT),InitStoreGoal)) | L1],
multi_hash_store_initialisations(Indexes,FA,L1,T).
global_ground_store_initialisation(C,L,T) :-
global_ground_store_name(C,StoreName),
L = [(:- nb_setval(StoreName,[]))|T].
make_init_store_goal(StoreName,[],InitStoreGoal),
L = [(:- InitStoreGoal)|T].
multi_hash_via_lookups([],_,L,L).
multi_hash_via_lookups([Index|Indexes],C,L,T) :-
multi_hash_via_lookup_name(C,Index,PredName),
Head =.. [PredName,Key,SuspsList],
multi_hash_store_name(C,Index,StoreName),
make_get_store_goal(StoreName,HT,GetStoreGoal),
Body =
(
nb_getval(StoreName,HT),
GetStoreGoal, % nb_getval(StoreName,HT),
lookup_ht(HT,Key,SuspsList)
),
L = [(Head :- Body)|L1],
@ -1655,7 +1677,7 @@ enumerate_store_body(default,C,Susp,Body) :-
get_max_constraint_index(MaxIndex),
Body1 =
(
'chr global_term_ref_1'(GlobalStore),
'chr default_store'(GlobalStore),
get_attr(GlobalStore,Mod,Attr)
),
( MaxIndex > 1 ->
@ -1673,9 +1695,10 @@ enumerate_store_body(multi_hash([Index|_]),C,Susp,Body) :-
multi_hash_enumerate_store_body(Index,C,Susp,Body).
enumerate_store_body(global_ground,C,Susp,Body) :-
global_ground_store_name(C,StoreName),
make_get_store_goal(StoreName,List,GetStoreGoal),
Body =
(
nb_getval(StoreName,List),
GetStoreGoal, % nb_getval(StoreName,List),
'chr sbag_member'(Susp,List)
).
enumerate_store_body(multi_store(STs),C,Susp,Body) :-
@ -1686,9 +1709,10 @@ enumerate_store_body(multi_store(STs),C,Susp,Body) :-
multi_hash_enumerate_store_body(I,C,Susp,B) :-
multi_hash_store_name(C,I,StoreName),
make_get_store_goal(StoreName,HT,GetStoreGoal),
B =
(
nb_getval(StoreName,HT),
GetStoreGoal, % nb_getval(StoreName,HT),
value_ht(HT,Susp)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -1936,36 +1960,6 @@ gen_uncond_attach_goal(FA,Susp,AttachGoal,Generation) :-
)
).
occurrences_code(O,MO,C,Id,NId,L,T) :-
( O > MO ->
NId = Id,
L = T
;
occurrence_code(O,C,Id,Id1,L,L1),
NO is O + 1,
occurrences_code(NO,MO,C,Id1,NId,L1,T)
).
occurrences_code(O,C,Id,NId,L,T) :-
get_occurrence(C,O,RuleNb,ID),
( is_passive(RuleNb,ID) ->
NId = Id,
L = T
;
get_rule(RuleNb,PragmaRule),
PragmaRule = pragma(rule(Heads1,Heads2,_,_),ids(IDs1,IDs2),_,_,_),
( select2(IDs1,Heads1,ID,Head1,RIDs1,RHeads1) ->
NId = Id,
head1_code(Head1,RHeads1,RIDs1,PragmaRule,C,Id,L,T)
; select2(IDs2,Heads2,ID,Head2,RIDs2,RHeads2) ->
length(RHeads2,RestHeadNb),
head2_code(Head2,RHeads2,RIDs2,PragmaRule,RestHeadNb,C,Id,L,L1),
inc_id(Id,NId),
gen_alloc_inc_clause(C,Id,L1,T)
)
).
%% Generate all the code for a constraint based on all CHR rules
rules_code([],_,Id,Id,L,L).
rules_code([R |Rs],I,Id1,Id3,L,T) :-
@ -2238,7 +2232,7 @@ unique_analyse_optimise_main([PRule|PRules],N,PatternList,[NPRule|NPRules]) :-
apply_unique_patterns_to_constraints(H2,Ids2,NPatternList,MorePragmas2),
globalize_unique_pragmas(MorePragmas1,RuleNb),
globalize_unique_pragmas(MorePragmas2,RuleNb),
append_lists([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
append([MorePragmas1,MorePragmas2,Pragmas],NPragmas),
NPRule = pragma(Rule,Ids,NPragmas,Name,RuleNb),
N1 is N + 1,
unique_analyse_optimise_main(PRules,N1,NPatternList,NPRules).
@ -2261,18 +2255,18 @@ apply_unique_patterns_to_constraints([C|Cs],[Id|Ids],Patterns,Pragmas) :-
apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
Pattern = unique(PatternConstraint,PatternKey),
subsumes(Constraint,PatternConstraint,Unifier),
( setof( V,
T^Term^Vs^(
find_with_var_identity( V,
Unifier
,
(
member(T,PatternKey),
lookup_eq(Unifier,T,Term),
term_variables(Term,Vs),
member(V,Vs)
),
Vars) ->
true
;
Vars = []
),
Vars2),
sort(Vars2,Vars3),
Vars = Vars3,
Pragma = unique(Id,Vars).
% subsumes(+Term1, +Term2, -Unifier)
@ -2282,9 +2276,9 @@ apply_unique_pattern(Constraint,Id,Pattern,Pragma) :-
% variables from Term2 and their corresponding values in Term1.
subsumes(Term1,Term2,Unifier) :-
empty_assoc(S0),
empty_ds(S0),
subsumes_aux(Term1,Term2,S0,S),
assoc_to_list(S,L),
ds_to_list(S,L),
build_unifier(L,Unifier).
subsumes_aux(Term1, Term2, S0, S) :-
@ -2295,10 +2289,10 @@ subsumes_aux(Term1, Term2, S0, S) :-
; Term1 == Term2
-> S = S0
; var(Term2),
get_assoc(Term1,S0,V)
get_ds(Term1,S0,V)
-> V == Term2, S = S0
; var(Term2),
put_assoc(Term1, S0, Term2, S)
put_ds(Term1, S0, Term2, S)
).
subsumes_aux(0, _, _, S, S) :- ! .
@ -2327,8 +2321,8 @@ discover_unique_pattern(PragmaRule,RuleNb,Pattern) :-
term_variables(C1,Vs),
select_pragma_unique_variables(List,Vs,Key),
Pattern0 = unique(C1,Key),
copy_term(Pattern0,Pattern),
( prolog_flag(verbose,V), V == yes ->
copy_term_nat(Pattern0,Pattern),
( verbosity_on ->
format('Found unique pattern ~w in rule ~d~@\n',
[Pattern,RuleNb,(Name=yes(N) -> write(": "),write(N) ; true)])
;
@ -2569,7 +2563,7 @@ rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,Act
;
get_constraint_index(F/A,Pos),
make_attr(N,_Mask,SuspsList,Attr),
nth(Pos,SuspsList,VarSusps)
nth1(Pos,SuspsList,VarSusps)
)
;
lookup_passive_head(StoreType,H,[ActiveHead|PrevHs],VarDict,ViaGoal,VarSusps),
@ -2579,7 +2573,7 @@ rest_heads_retrieval_and_matching_n([H|Hs],[ID|IDs],Pragmas,PrevHs,PrevSusps,Act
head_arg_matches(Pairs,VarDict,MatchingGoal,VarDict1),
Suspension =.. [suspension,_,State,_,_,_,_|Vars],
different_from_other_susps(H,Susp,PrevHs,PrevSusps,DiffSuspGoals),
create_get_mutable(active,State,GetMutable),
create_get_mutable_ref(active,State,GetMutable),
Goal1 =
(
'chr sbag_member'(Susp,VarSusps),
@ -2617,7 +2611,7 @@ check_unique_keys([V|Vs],Dict) :-
% Generates tests to ensure the found constraint differs from previously found constraints
% TODO: detect more cases where constraints need be different
different_from_other_susps(Head,Susp,Heads,Susps,DiffSuspGoals) :-
( bagof(DiffSuspGoal, Pos ^ ( nth(Pos,Heads,PreHead), \+ Head \= PreHead, nth(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
( bagof(DiffSuspGoal, Pos ^ ( nth1(Pos,Heads,PreHead), \+ Head \= PreHead, nth1(Pos,Susps,PreSusp), DiffSuspGoal = (Susp \== PreSusp) ),DiffSuspGoalList) ->
list2conj(DiffSuspGoalList,DiffSuspGoals)
;
DiffSuspGoals = true
@ -2649,7 +2643,7 @@ gen_get_mod_constraints(L,Goal,Susps) :-
get_target_module(Mod),
( L == [] ->
Goal =
( 'chr global_term_ref_1'(Global),
( 'chr default_store'(Global),
get_attr(Global,Mod,TSusps),
TSusps = Susps
)
@ -2682,12 +2676,15 @@ guard_body_copies2(Rule,VarDict,GuardCopyList,BodyCopy) :-
term_variables(RestGuardList,GuardVars),
term_variables(RestGuardListCopyCore,GuardCopyVars),
( chr_pp_flag(guard_locks,on),
bagof(('chr lock'(Y)) - ('chr unlock'(Y)),
X ^ (member(X,GuardVars), % X is a variable appearing in the original guard
find_with_var_identity(('chr lock'(Y)) - ('chr unlock'(Y)),
VarDict,
(member(X,GuardVars), % X is a variable appearing in the original guard
lookup_eq(VarDict,X,Y), % translate X into new variable
memberchk_eq(Y,GuardCopyVars) % redundant check? or multiple entries for X possible?
),
LocksUnlocks) ->
LocksUnlocks)
->
once(pairup(Locks,Unlocks,LocksUnlocks))
;
Locks = [],
@ -2942,7 +2939,7 @@ simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Pr
head_arg_matches(Head1Pairs,VarDict1,FirstMatching,VarDict2),
OtherSuspension =.. [suspension,_,OtherState,_,_,_,_|OtherVars],
create_get_mutable(active,OtherState,GetMutable),
create_get_mutable_ref(active,OtherState,GetMutable),
IteratorSuspTest =
( OtherSusp = OtherSuspension,
GetMutable
@ -3029,8 +3026,8 @@ simpagation_head2_worker_body(Head2,Head1,ID1,RestHeads1,IDs1,RestHeads2,IDs2,Pr
gen_state_cond_call(Susp,N,Call,Generation,ConditionalCall) :-
length(Args,N),
Suspension =.. [suspension,_,State,_,NewGeneration,_,_|Args],
create_get_mutable(active,State,GetState),
create_get_mutable(Generation,NewGeneration,GetGeneration),
create_get_mutable_ref(active,State,GetState),
create_get_mutable_ref(Generation,NewGeneration,GetGeneration),
ConditionalCall =
( Susp = Suspension,
GetState,
@ -3170,7 +3167,7 @@ propagation_body(CurrentHead,PreHeads,Rule,RuleNb,RestHeadNb,F/A,Id,L,T) :-
functor(CurrentHead,_OtherF,OtherA),
gen_vars(OtherA,OtherVars),
Suspension =.. [suspension,_,State,_,_,_,_|OtherVars],
create_get_mutable(active,State,GetMutable),
create_get_mutable_ref(active,State,GetMutable),
CurrentSuspTest = (
OtherSusp = Suspension,
GetMutable
@ -3303,7 +3300,7 @@ propagation_accumulator([NextHead|RestHeads],[CurrentHead|PreHeads],Rule,F/A,Id,
OtherSuspension =.. [suspension,_,State,_,_,_,_|OtherVars],
different_from_other_susps(CurrentHead,OtherSusp,PreHeads,PreSusps,DiffSuspGoals),
create_get_mutable(active,State,GetMutable),
create_get_mutable_ref(active,State,GetMutable),
CurrentSuspTest = (
OtherSusp = OtherSuspension,
GetMutable,
@ -3463,8 +3460,13 @@ order_score_vars([V|Vs],KnownVars,RestVars,Score,NScore) :-
%% |___|_| |_|_|_|_| |_|_|_| |_|\__, |
%% |___/
create_get_mutable(V,M,GM) :-
GM = (M = mutable(V)).
%% SWI begin
create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
%% SWI end
%% SICStus begin
%% create_get_mutable_ref(V,M,GM) :- GM = get_mutable(V,M).
%% SICStus end
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
@ -3501,14 +3503,14 @@ build_head(F,A,Id,Args,Head) :-
buildName(Fct,Aty,List,Result) :-
atom_concat(Fct, (/) ,FctSlash),
atom_concat(FctSlash,Aty,FctSlashAty),
atomic_concat(FctSlash,Aty,FctSlashAty),
buildName_(List,FctSlashAty,Result).
buildName_([],Name,Name).
buildName_([N|Ns],Name,Result) :-
buildName_(Ns,Name,Name1),
atom_concat(Name1,'__',NameDash), % '_' is a char :-(
atom_concat(NameDash,N,Result).
atomic_concat(NameDash,N,Result).
vars_susp(A,Vars,Susp,VarsSusp) :-
length(Vars,A),
@ -3559,7 +3561,23 @@ list2disj([G|Gs],C) :-
atom_concat_list([X],X) :- ! .
atom_concat_list([X|Xs],A) :-
atom_concat_list(Xs,B),
atom_concat(X,B,A).
atomic_concat(X,B,A).
atomic_concat(A,B,C) :-
make_atom(A,AA),
make_atom(B,BB),
atom_concat(AA,BB,C).
make_atom(A,AA) :-
(
atom(A) ->
AA = A
;
number(A) ->
number_codes(A,AL),
atom_codes(AA,AL)
).
make_name(Prefix,F/A,Name) :-
atom_concat_list([Prefix,F,(/),A],Name).
@ -3596,7 +3614,7 @@ lookup_passive_head(default,Head,PreJoin,VarDict,Goal,AllSusps) :-
functor(Head,F,A),
get_constraint_index(F/A,Pos),
make_attr(N,_,SuspsList,Attr),
nth(Pos,SuspsList,AllSusps)
nth1(Pos,SuspsList,AllSusps)
).
lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
once((
@ -3616,7 +3634,7 @@ lookup_passive_head(multi_hash(Indexes),Head,_PreJoin,VarDict,Goal,AllSusps) :-
lookup_passive_head(global_ground,Head,PreJoin,_VarDict,Goal,AllSusps) :-
functor(Head,F,A),
global_ground_store_name(F/A,StoreName),
Goal = nb_getval(StoreName,AllSusps),
make_get_store_goal(StoreName,AllSusps,Goal), % Goal = nb_getval(StoreName,AllSusps),
update_store_type(F/A,global_ground).
lookup_passive_head(multi_store(StoreTypes),Head,PreJoin,VarDict,Goal,AllSusps) :-
once((
@ -3657,3 +3675,13 @@ validate_store_type_assumptions([]).
validate_store_type_assumptions([C|Cs]) :-
validate_store_type_assumption(C),
validate_store_type_assumptions(Cs).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% SWI begin
verbosity_on :- prolog_flag(verbose,V), V == yes.
%% SWI end
%% SICStus begin
%% verbosity_on. % at the moment
%% SICStus end

14
LGPL/chr/clean_code.pl
View File

@ -1,6 +1,6 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Tom Schrijvers
% Email: Tom.Schrijvers@cs.kuleuven.ac.be
% Email: Tom.Schrijvers@cs.kuleuven.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% ____ _ ____ _ _
@ -20,7 +20,7 @@
clean_clauses/2
]).
:- use_module(hprolog, [memberchk_eq/2]).
:- use_module(hprolog).
clean_clauses([],[]).
clean_clauses([C|Cs],[NC|NCs]) :-
@ -36,6 +36,9 @@ clean_clause(Clause,NClause) :-
;
NClause = (NHead :- NBody)
)
; Clause = '$source_location'(File,Line) : ActualClause ->
NClause = '$source_location'(File,Line) : NActualClause,
clean_clause(ActualClause,NActualClause)
;
NClause = Clause
).
@ -143,9 +146,10 @@ move_unification_into_head_([G|Gs],Head,NHead,NBody) :-
conj2list(Conj,L) :- %% transform conjunctions to list
conj2list(Conj,L,[]).
conj2list(Conj,L,T) :-
Conj = (true,G2), !,
conj2list(G2,L,T).
conj2list(G,L,T) :-
var(G), !,
L = [G|T].
conj2list(true,L,L) :- !.
conj2list(Conj,L,T) :-
Conj = (G1,G2), !,
conj2list(G1,L,T1),

7
LGPL/chr/find.pl
View File

@ -1,9 +1,9 @@
/* $Id: find.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: find.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Bart Demoen, Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven
@ -46,7 +46,8 @@
find_with_var_identity(Template, IdVars, Goal, Answers) :-
Key = foo(IdVars),
findall(Key - Template, Goal, As),
copy_term_nat(Template-Key-Goal,TemplateC-KeyC-GoalC),
findall(KeyC - TemplateC, GoalC, As),
smash(As,Key,Answers).
smash([],_,[]).

956
LGPL/chr/guard_entailment.chr
View File

@ -1,459 +1,511 @@
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Jon Sneyers
% Email: jon@cs.kuleuven.ac.be
% Copyright: K.U.Leuven 2004
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(guard_entailment,
[
entails_guard/2,
simplify_guards/5
]).
%:- use_module(library(chr)).
:- use_module(library(lists)).
[ entails_guard/2,
simplify_guards/5
]).
:- include(chr_op).
:- use_module(hprolog).
:- use_module(builtins).
option(debug,off).
option(optimize,full).
:- constraints known/1,test/1,cleanup/0,variables/1.
% knowing the same thing twice is redundant
idempotence @ known(G) \ known(G) <=> true.
%--------------------------------------
% Rules to check if the argument of
% test/1 is entailed by known stuff
%--------------------------------------
% everything follows from an inconsistent theory
fail_implies_everything @ known(fail) \ test(X) <=> true.
% if it's known, it's entailed
trivial_entailment @ known(G) \ test(G) <=> true.
varfirst_nmatch @ test(X\==A) <=> nonvar(X) | test(A\==X).
distribute_nmatch @ test(X\==A) <=> nonvar(A),functor(A,Fu,Ar) |
A =.. [F|AArgs],
length(XArgs,Ar), B =.. [Fu|XArgs],
add_args_nmatch(XArgs,AArgs,ArgCond),
C = (\+ functor(X,Fu,Ar) ; (functor(X,Fu,Ar),X=B,ArgCond)),
test(C).
% eq implies leq
eq_implies_leq1 @ known(X=:=Y) \ test(X=<Y) <=> true.
eq_implies_leq2 @ known(X=:=Z) \ test(X=<Y) <=> number(Y), number(Z), Z=<Y |true.
eq_implies_leq3 @ known(X=:=Z) \ test(Y=<X) <=> number(Y), number(Z), Y=<Z |true.
% stronger inequality implies a weaker one
leq_implies_leq1 @ known(X=<Z) \ test(X=<Y) <=> number(Y), number(Z), Z=<Y |true.
leq_implies_leq2 @ known(X=<Y) \ test(Z=<Y) <=> number(X), number(Z), Z=<X | true.
% X =< Z implies X =\= Y for all Y > Z
leq_implies_neq1 @ known(X=<Z) \ test(X=\=Y) <=> number(Y), number(Z), Y>Z | true.
leq_implies_neq2 @ known(X=<Y) \ test(Y=\=Z) <=> number(X), number(Z), Z<X | true.
%--------------------------------------
% Rules to translate some stuff
%--------------------------------------
% we only want =<, =:= and =\=
known_g2l @ known(X>Y) <=> known(Y<X).
known_geq2leq @ known(X>=Y) <=> known(Y=<X).
known_l2leq_neq @ known(X<Y) <=> known(X=<Y), known(X=\=Y).
known_is2eq @ known(X is Y) <=> known(X=:=Y).
test_g2l @ test(X>Y) <=> test(Y<X).
test_geq2leq @test(X>=Y) <=> test(Y=<X).
test_l2leq_neq @test(X<Y) <=> test(((X=<Y),(X=\=Y))).
test_is2eq @ test(X is Y) <=> test(X=:=Y).
% propagate == and \== to =:= and =\= (which is a weaker statement)
match2eq1 @ known(X==Y) ==> number(X) | known(X=:=Y).
match2eq2 @known(X==Y) ==> number(Y) | known(X=:=Y).
nmatch2neq1 @ known(X\==Y) ==> number(X) | known(X=\=Y).
nmatch2neq2 @ known(X\==Y) ==> number(Y) | known(X=\=Y).
%--------------------------------------
% Rules to extend the known stuff
%--------------------------------------
% if we derived inconsistency, all other knowledge is redundant
fail_is_better_than_anything_else @ known(fail) \ known(_) <=> true.
% conjunctions
conj @ known((A,B)) <=> known(A), known(B).
% no need to remember trivial stuff
forget_trivial01 @ known(X=:=X) <=> true.
forget_trivial02 @ known(X==X) <=> true.
forget_trivial03 @ known(X=<X) <=> true.
forget_trivial04 @ known(X=X) <=> true.
%--------------------------------------
% Rules for = and \= (and functor)
%--------------------------------------
unify_vars1 @ known(X=Y) <=> var(X) | X=Y.
unify_vars2 @ known(X=Y) <=> var(Y) | X=Y.
%functor @ known(functor(X,F,A)) <=> var(X),ground(F),ground(A) | functor(X,F,A).
inconsistency4 @ known(X\=Y) <=> var(X),var(Y),X=Y | known(fail).
inconsistency4 @ known(X\=Y) <=> ground(X),ground(Y),X=Y | known(fail).
functor @ variables(V),known(functor(X,F,A)) <=>
var(X), ground(F), ground(A) |
functor(X,F,A),
X =.. [_|Args],
append(Args,V,NewV),
variables(NewV).
functor_inconsistency1 @ known(functor(X,F1,A1)) <=> nonvar(X), \+ functor(X,F1,A1) | known(fail).
negfunctor_trivial @ known(\+ functor(X,F1,A1)) <=> nonvar(X), functor(X,F1,A1) | known(fail).
functor_inconsistency2 @ known(functor(X,F1,A1)), known(functor(X,F2,A2)) <=>
nonvar(F1),nonvar(A1),nonvar(F2),nonvar(A2)
% (F1 \= F2 ; A1 \= A2) is entailed by idempotence
| known(fail).
nunify_inconsistency @ known(X\=X) <=> known(fail).
nonvar_unification @ known(X=Y) <=> nonvar(X), nonvar(Y),functor(X,F,A) |
( functor(Y,F,A),X=Y ->
true
;
known(fail)
).
nunify_expand @ known(X\=Y) <=> var(X),nonvar(Y), functor(Y,F,A), A>0 |
length(Args,A),
Y =.. [F|YArgs],
Y1 =.. [F|Args],
add_args_nunif(YArgs,Args,Nunif),
C = (\+ functor(X,F,A) ; (X = Y1, Nunif )),
known(C).
nunify_expand2 @ known(X\=Y) <=> nonvar(X),nonvar(Y), functor(X,F,A) |
(functor(Y,F,A) ->
X =.. [F|XArgs],
Y =.. [F|YArgs],
add_args_nunif(XArgs,YArgs,Nunif),
known(Nunif)
;
true
).
nunify_symmetry @ known(X\=Y) ==> known(Y\=X).
%--------------------------------------
% Rules for =<
%--------------------------------------
groundleq2 @ known(X=<Y) <=> number(X), number(Y), X>Y | known(fail).
% only keep the strictest inequality
remove_redundant_leq1 @ known(X=<Y) \ known(X=<Z) <=> number(Y), number(Z), Y=<Z | true.
remove_redundant_leq1 @ known(Z=<Y) \ known(X=<Y) <=> number(X), number(Z), X=<Z | true.
leq_antisymmetry @ known(X=<Y), known(Y=<X) <=> known(X=:=Y).
leq_transitivity @ known(X=<Y), known(Y=<Z) ==> known(X=<Z).
strict_leq_transitivity @ known(X=<Y),known(X=\=Y),known(Y=<Z),known(Y=\=Z) ==> known(X=\=Z).
%--------------------------------------
% Rules for =:= (and =\=)
%--------------------------------------
groundeq2 @ known(X=:=Y) <=> number(X), number(Y), X=\=Y | known(fail).
groundneq2 @ known(X=\=Y) <=> number(X), number(Y), X=:=Y | known(fail).
neq_inconsistency @ known(X=\=X) <=> known(fail).
inconsistency @ known(X=:=Y), known(X=\=Y) <=> known(fail).
eq_transitivity @ known(X=:=Y), known(Y=:=Z) ==> X \== Z | known(X=:=Z).
eq_symmetry @ known(X=:=Y) ==> known(Y=:=X).
neq_symmetry @ known(X=\=Y) ==> known(Y=\=X).
%--------------------------------------
% Rules for number/1, float/1, integer/1
%--------------------------------------
notnumber @ known(number(X)) <=> nonvar(X), \+ number(X) | known(fail).
notfloat @ known(float(X)) <=> nonvar(X), \+ float(X)| known(fail).
notinteger @ known(integer(X)) <=> nonvar(X), \+ integer(X) | known(fail).
int2number @ known(integer(X)) ==> known(number(X)).
float2number @ known(float(X)) ==> known(number(X)).
%--------------------------------------
% Rules for \+
%--------------------------------------
inconsistency2 @ known(X), known(\+ X) <=> known(fail).
%--------------------------------------
% Rules for == and \==
%--------------------------------------
inconsistency3 @ known(X\==Y), known(X==Y) <=> known(fail).
eq_transitivity2 @ known(X==Y), known(Y==Z) ==> known(X==Z).
neq_substitution @ known(X==Y), known(Y\==Z) ==> known(X\==Z).
eq_symmetry2 @ known(X==Y) ==> known(Y==X).
neq_symmetry2 @ known(X\==Y) ==> known(Y\==X).
neq_inconsistency @ known(X\==X) ==> known(fail).
functorsmatch@ known(X\==Y) <=> nonvar(X), nonvar(Y), functor(X,F,A) |
(functor(Y,F,A) ->
X =.. [F|XArgs],
Y =.. [F|YArgs],
add_args_nmatch(XArgs,YArgs,ArgCond),
known(ArgCond)
;
true
).
eq_implies_unif @ known(X==Y) ==> known(X=Y).
%--------------------------------------
% Rules for var/1 and nonvar/1
%--------------------------------------
ground2nonvar @ known(ground(X)) ==> known(nonvar(X)).
compound2nonvar @ known(compound(X)) ==> known(nonvar(X)).
atomic2nonvar @ known(atomic(X)) ==> known(nonvar(X)).
number2nonvar @ known(number(X)) ==> known(nonvar(X)).
atom2nonvar @ known(atom(X)) ==> known(nonvar(X)).
var_inconsistency @ known(var(X)), known(nonvar(X)) <=> known(fail).
%--------------------------------------
% Rules for disjunctions
%--------------------------------------
%ad-hoc disjunction optimization:
simplify_disj1 @ known(A) \ known((\+ A; B)) <=> known(B).
simplify_disj1b @ known(A) \ known((\+ A, C; B)) <=> known(B).
simplify_disj1c @ known(\+ A) \ known((A; B)) <=> known(B).
simplify_disj1d @ known(\+ A) \ known((A, C; B)) <=> known(B).
simplify_disj2 @ known((fail; B)) <=> known(B).
simplify_disj3 @ known((B ; fail)) <=> known(B).
simplify_disj4 @ known(functor(X,F1,A1)) \ known((\+ functor(X,F,A); B)) <=>
% F1 \== F or A1 \== A
true. % the disjunction does not provide any additional information
simplify_disj5 @ known((\+ functor(X,F,A); B)) <=>
nonvar(X), functor(X,F,A) |
known(B).
simplify_disj6 @ known((\+ functor(X,F,A); B)) <=>
nonvar(X), \+ functor(X,F,A) |
true. % the disjunction does not provide any additional information
test_simplify_disj1 @test((fail;B)) <=> test(B).
test_simplify_disj2 @test((B;fail)) <=> test(B).
%--------------------------------------
% Rules to test unifications
%--------------------------------------
trivial_unif @ test(X=Y) <=> X=Y | X=Y.
testgroundunif @ test(X=A) <=> ground(X),ground(A) | X=A.
varfirst @ test(X=A) <=> nonvar(X),var(A) | test(A=X).
distribute_unif @ variables(V) \ test(X=A) <=> var(X),nonvar(A),
functor(A,F,Arit),Arit>0,
A =.. [F|AArgs],\+ all_unique_vars(AArgs,V) |
C=(functor(X,F,Arit),X=A),
test(C).
distribute_unif2 @ test(X=A) <=> var(X),nonvar(A),
functor(A,F,Arit),%Arit>0,
A =.. [F|AArgs] % , all_unique_vars(AArgs)
|
C=functor(X,F,Arit),
test(C).
distribute_unif3 @ test(X=A) <=> nonvar(X),nonvar(A),functor(A,F,Arit),
A =.. [F|AArgs] |
functor(X,F,Arit),
X =.. [F|XArgs],
add_args_unif(XArgs,AArgs,ArgCond),
test(ArgCond).
testvarunif @ variables(V) \ test(X=A) <=> \+ (memberchk_eq(A,V),memberchk_eq(X,V)) | X=A.
testvarunif @ variables(V) \ test(functor(X,F,A)) <=>
var(X),ground(F),ground(A),\+ memberchk_eq(X,V) |
functor(X,F,A). % X is a singleton variable
% trivial truths
true_is_true @ test(true) <=> true.
trivial01 @ test(X==Y) <=> X==Y | true.
trivial02 @ test(X=:=Y) <=> X==Y | true.
trivial03 @ test(X=<Y) <=> X==Y | true.
trivial04 @ test(X=<Y) <=> ground(X), ground(Y), X=<Y | true.
trivial05 @ test(X=<Y) <=> ground(X), ground(Y), X>Y | fail.
trivial06 @ test(X=:=Y) <=> ground(X), ground(Y), X=:=Y | true.
trivial07 @ test(X=:=Y) <=> ground(X), ground(Y), X=\=Y | fail.
trivial08 @ test(X=\=Y) <=> ground(X), ground(Y), X=\=Y | true.
trivial09 @ test(X=\=Y) <=> ground(X), ground(Y), X=:=Y | fail.
trivial10 @ test(functor(X,F1,A1)) <=> nonvar(X), functor(X,F1,A1) | true.
trivial11 @ test(functor(X,F1,A1)) <=> nonvar(X) | fail.
trivial12 @ test(ground(X)) <=> ground(X) | true.
trivial13 @ test(number(X)) <=> number(X) | true.
trivial14 @ test(float(X)) <=> float(X) | true.
trivial15 @ test(integer(X)) <=> integer(X) | true.
trivial16 @ test(number(X)) <=> nonvar(X) | fail.
trivial17 @ test(float(X)) <=> nonvar(X) | fail.
trivial18 @ test(integer(X)) <=> nonvar(X) | fail.
trivial19 @ test(\+ functor(X,F1,A1)) <=> nonvar(X), functor(X,F1,A1) | fail.
trivial20 @ test(\+ functor(X,F1,A1)) <=> nonvar(X) | true.
trivial21 @ test(\+ ground(X)) <=> ground(X) | fail.
trivial22 @ test(\+ number(X)) <=> number(X) | fail.
trivial23 @ test(\+ float(X)) <=> float(X) | fail.
trivial24 @ test(\+ integer(X)) <=> integer(X) | fail.
trivial25 @ test(\+ number(X)) <=> nonvar(X) | true.
trivial26 @ test(\+ float(X)) <=> nonvar(X) | true.
trivial27 @ test(\+ integer(X)) <=> nonvar(X) | true.
test_conjunction @ test((A,B)) <=> test(A), known(A), test(B).
test_disjunction @ test((A;B)) <=> true | negate_b(A,NotA),negate_b(B,NotB),
(known(NotB),test(A) ; known(NotA),test(B)).
% disjunctions in the known stuff --> both options should entail the goals
% delay disjunction unfolding until everything is added, perhaps we can
% find entailed things without using the disjunctions
disjunction @ test(X), known((A;B)) <=>
true |
\+ try(A,X),!,
negate_b(A,NotA),
known(NotA),
\+ try(B,X).
% not entailed or entailment not detected
could_not_prove_entailment @ test(_) <=> fail.
clean_store1 @ cleanup \ known(_) <=> true.
clean_store2 @ cleanup \ variables(_) <=> true.
clean_store3 @ cleanup <=> true.
%--------------------------------------
% End of CHR part
%--------------------------------------
entails_guard(List,Guard) :-
copy_term_nat((List,Guard),(CopyList,CopyGuard)),
term_variables(CopyList,CLVars),
variables(CLVars),
entails_guard2(CopyList),
!,test(CopyGuard),!,
cleanup.
:- use_module(chr_compiler_errors).
:- chr_option(debug, off).
:- chr_option(optimize, full).
:- chr_option(verbosity,off).
%:- chr_option(dynattr,on).
:- chr_constraint known/1, test/1, cleanup/0, variables/1.
entails_guard(A, B) :-
copy_term_nat((A, B), (C, F)),
term_variables(C, D),
variables(D),
sort(C, E),
entails_guard2(E), !,
test(F), !,
cleanup.
entails_guard2([]).
entails_guard2([A|R]) :-
known(A), entails_guard2(R).
simplify_guards(List,Body,GuardList,SimplifiedGuards,NewBody) :-
% write(starting),nl,
copy_term_nat((List,GuardList),(CopyList,CopyGuard)),
term_variables(CopyList,CLVars),
% write(variables(CLVars)),nl,
variables(CLVars),
% write(gonna_add(CopyList)),nl,
entails_guard2(CopyList),
% write(ok_gonna_add),nl,
!,
% write(gonna_simplify(CopyGuard)),nl,
simplify(CopyGuard,L),
% write(ok_gonna_simplify(CopyGuard,L)),nl,
simplified(GuardList,L,SimplifiedGuards,Body,NewBody),
% write(ok_done),nl,
!,
cleanup.
simplified([],[],[],B,B).
simplified([G|RG],[keep|RL],[G|RSG],B,NB) :- simplified(RG,RL,RSG,B,NB).
simplified([G|RG],[fail|RL],fail,B,B).
simplified([G|RG],[true|RL],[X|RSG],B,NB) :-
builtins:binds_b(G,GVars), term_variables(RG,RGVars),
intersect_eq(GVars,RGVars,SharedWithRestOfGuard),!,
( SharedWithRestOfGuard = [] ->
term_variables(B,BVars),
intersect_eq(GVars,BVars,SharedWithBody),!,
( SharedWithBody = [] ->
X=true, % e.g. c(X) <=> Y=X | true.
NB=NB2
;
X=true, % e.g. c(X) <=> Y=X | writeln(Y).
NB=(G,NB2)
entails_guard2([A|B]) :-
known(A),
entails_guard2(B).
simplify_guards(A, H, B, G, I) :-
copy_term_nat((A, B), (C, E)),
term_variables(C, D),
variables(D),
sort(C,Z),
entails_guard2(Z), !,
simplify(E, F),
simplified(B, F, G, H, I), !,
cleanup.
simplified([], [], [], A, A).
simplified([A|B], [keep|C], [A|D], E, F) :-
simplified(B, C, D, E, F).
simplified([_|_], [fail|_], fail, A, A).
simplified([A|B], [true|L], [I|M], F, J) :-
builtins:binds_b(A, C),
term_variables(B, D),
intersect_eq(C, D, E), !,
( E=[]
-> term_variables(F, G),
intersect_eq(C, G, H), !,
( H=[]
-> I=true,
J=K
; I=true,
J= (A, K)
)
;
X=G, % e.g. c(X) <=> Y=X,p(Y) | true.
NB=NB2
; I=A,
J=K
),
simplified(RG,RL,RSG,B,NB2).
simplified(B, L, M, F, K).
simplify([], []).
simplify([A|D], [B|E]) :-
( \+try(true, A)
-> B=true
; builtins:negate_b(A, C),
( \+try(true, C)
-> B=fail
; B=keep
)
),
known(A),
simplify(D, E).
try(A, B) :-
( known(A)
-> true
; chr_error(internal, 'Entailment Checker: try/2.\n', [])
),
( test(B)
-> fail
; true
).
add_args_unif([], [], true).
add_args_unif([A|C], [B|D], (A=B, E)) :-
add_args_unif(C, D, E).
add_args_nunif([], [], fail).
add_args_nunif([A|C], [B|D], (A\=B;E)) :-
add_args_nunif(C, D, E).
add_args_nmatch([], [], fail).
add_args_nmatch([A|C], [B|D], (A\==B;E)) :-
add_args_nmatch(C, D, E).
all_unique_vars(A, B) :-
all_unique_vars(A, B, []).
all_unique_vars([], _, _).
all_unique_vars([A|D], B, C) :-
var(A),
\+memberchk_eq(A, B),
\+memberchk_eq(A, C),
all_unique_vars(D, [A|C]).
:- chr_constraint'test/1_1_$default'/1, 'test/1_1_$special_,/2'/2, 'test/1_1_$special_\\+/1'/1, 'test/1_1_$special_integer/1'/1, 'test/1_1_$special_float/1'/1, 'test/1_1_$special_number/1'/1, 'test/1_1_$special_ground/1'/1, 'test/1_1_$special_=:=/2'/2, 'test/1_1_$special_==/2'/2, 'test/1_1_$special_true/0'/0, 'test/1_1_$special_functor/3'/3, 'test/1_1_$special_=/2'/2, 'test/1_1_$special_;/2'/2, 'test/1_1_$special_is/2'/2, 'test/1_1_$special_</2'/2, 'test/1_1_$special_>=/2'/2, 'test/1_1_$special_>/2'/2, 'test/1_1_$special_=\\=/2'/2, 'test/1_1_$special_=</2'/2, 'test/1_1_$special_\\==/2'/2, 'known/1_1_$default'/1, 'known/1_1_$special_;/2'/2, 'known/1_1_$special_nonvar/1'/1, 'known/1_1_$special_var/1'/1, 'known/1_1_$special_atom/1'/1, 'known/1_1_$special_atomic/1'/1, 'known/1_1_$special_compound/1'/1, 'known/1_1_$special_ground/1'/1, 'known/1_1_$special_integer/1'/1, 'known/1_1_$special_float/1'/1, 'known/1_1_$special_number/1'/1, 'known/1_1_$special_=\\=/2'/2, 'known/1_1_$special_\\+/1'/1, 'known/1_1_$special_functor/3'/3, 'known/1_1_$special_\\=/2'/2, 'known/1_1_$special_=/2'/2, 'known/1_1_$special_,/2'/2, 'known/1_1_$special_\\==/2'/2, 'known/1_1_$special_==/2'/2, 'known/1_1_$special_is/2'/2, 'known/1_1_$special_</2'/2, 'known/1_1_$special_>=/2'/2, 'known/1_1_$special_>/2'/2, 'known/1_1_$special_=</2'/2, 'known/1_1_$special_=:=/2'/2, 'known/1_1_$special_fail/0'/0.
test((A, B))<=>'test/1_1_$special_,/2'(A, B).
test(\+A)<=>'test/1_1_$special_\\+/1'(A).
test(integer(A))<=>'test/1_1_$special_integer/1'(A).
test(float(A))<=>'test/1_1_$special_float/1'(A).
test(number(A))<=>'test/1_1_$special_number/1'(A).
test(ground(A))<=>'test/1_1_$special_ground/1'(A).
test(A=:=B)<=>'test/1_1_$special_=:=/2'(A, B).
test(A==B)<=>'test/1_1_$special_==/2'(A, B).
test(true)<=>'test/1_1_$special_true/0'.
test(functor(A, B, C))<=>'test/1_1_$special_functor/3'(A, B, C).
test(A=B)<=>'test/1_1_$special_=/2'(A, B).
test((A;B))<=>'test/1_1_$special_;/2'(A, B).
test(A is B)<=>'test/1_1_$special_is/2'(A, B).
test(A<B)<=>'test/1_1_$special_</2'(A, B).
test(A>=B)<=>'test/1_1_$special_>=/2'(A, B).
test(A>B)<=>'test/1_1_$special_>/2'(A, B).
test(A=\=B)<=>'test/1_1_$special_=\\=/2'(A, B).
test(A=<B)<=>'test/1_1_$special_=</2'(A, B).
test(A\==B)<=>'test/1_1_$special_\\==/2'(A, B).
test(A)<=>'test/1_1_$default'(A).
known((A;B))<=>'known/1_1_$special_;/2'(A, B).
known(nonvar(A))<=>'known/1_1_$special_nonvar/1'(A).
known(var(A))<=>'known/1_1_$special_var/1'(A).
known(atom(A))<=>'known/1_1_$special_atom/1'(A).
known(atomic(A))<=>'known/1_1_$special_atomic/1'(A).
known(compound(A))<=>'known/1_1_$special_compound/1'(A).
known(ground(A))<=>'known/1_1_$special_ground/1'(A).
known(integer(A))<=>'known/1_1_$special_integer/1'(A).
known(float(A))<=>'known/1_1_$special_float/1'(A).
known(number(A))<=>'known/1_1_$special_number/1'(A).
known(A=\=B)<=>'known/1_1_$special_=\\=/2'(A, B).
known(\+A)<=>'known/1_1_$special_\\+/1'(A).
known(functor(A, B, C))<=>'known/1_1_$special_functor/3'(A, B, C).
known(A\=B)<=>'known/1_1_$special_\\=/2'(A, B).
known(A=B)<=>'known/1_1_$special_=/2'(A, B).
known((A, B))<=>'known/1_1_$special_,/2'(A, B).
known(A\==B)<=>'known/1_1_$special_\\==/2'(A, B).
known(A==B)<=>'known/1_1_$special_==/2'(A, B).
known(A is B)<=>'known/1_1_$special_is/2'(A, B).
known(A<B)<=>'known/1_1_$special_</2'(A, B).
known(A>=B)<=>'known/1_1_$special_>=/2'(A, B).
known(A>B)<=>'known/1_1_$special_>/2'(A, B).
known(A=<B)<=>'known/1_1_$special_=</2'(A, B).
known(A=:=B)<=>'known/1_1_$special_=:=/2'(A, B).
known(fail)<=>'known/1_1_$special_fail/0'.
known(A)<=>'known/1_1_$default'(A).
'known/1_1_$special_;/2'(A, B)\'known/1_1_$special_;/2'(A, B)<=>true.
'known/1_1_$special_nonvar/1'(A)\'known/1_1_$special_nonvar/1'(A)<=>true.
'known/1_1_$special_var/1'(A)\'known/1_1_$special_var/1'(A)<=>true.
'known/1_1_$special_atom/1'(A)\'known/1_1_$special_atom/1'(A)<=>true.
'known/1_1_$special_atomic/1'(A)\'known/1_1_$special_atomic/1'(A)<=>true.
'known/1_1_$special_compound/1'(A)\'known/1_1_$special_compound/1'(A)<=>true.
'known/1_1_$special_ground/1'(A)\'known/1_1_$special_ground/1'(A)<=>true.
'known/1_1_$special_integer/1'(A)\'known/1_1_$special_integer/1'(A)<=>true.
'known/1_1_$special_float/1'(A)\'known/1_1_$special_float/1'(A)<=>true.
'known/1_1_$special_number/1'(A)\'known/1_1_$special_number/1'(A)<=>true.
'known/1_1_$special_=\\=/2'(A, B)\'known/1_1_$special_=\\=/2'(A, B)<=>true.
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_\\+/1'(A)<=>true.
'known/1_1_$special_functor/3'(A, B, C)\'known/1_1_$special_functor/3'(A, B, C)<=>true.
'known/1_1_$special_\\=/2'(A, B)\'known/1_1_$special_\\=/2'(A, B)<=>true.
'known/1_1_$special_=/2'(A, B)\'known/1_1_$special_=/2'(A, B)<=>true.
'known/1_1_$special_,/2'(A, B)\'known/1_1_$special_,/2'(A, B)<=>true.
'known/1_1_$special_\\==/2'(A, B)\'known/1_1_$special_\\==/2'(A, B)<=>true.
'known/1_1_$special_==/2'(A, B)\'known/1_1_$special_==/2'(A, B)<=>true.
'known/1_1_$special_is/2'(A, B)\'known/1_1_$special_is/2'(A, B)<=>true.
'known/1_1_$special_</2'(A, B)\'known/1_1_$special_</2'(A, B)<=>true.
'known/1_1_$special_>=/2'(A, B)\'known/1_1_$special_>=/2'(A, B)<=>true.
'known/1_1_$special_>/2'(A, B)\'known/1_1_$special_>/2'(A, B)<=>true.
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_=</2'(A, B)<=>true.
'known/1_1_$special_=:=/2'(A, B)\'known/1_1_$special_=:=/2'(A, B)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_fail/0'<=>true.
'known/1_1_$default'(A)\'known/1_1_$default'(A)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_,/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_\\+/1'(_)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_integer/1'(_)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_float/1'(_)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_number/1'(_)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_ground/1'(_)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_=:=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_==/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_true/0'<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_functor/3'(_, _, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_;/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_is/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_</2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_>=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_>/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_=\\=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_=</2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$special_\\==/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$default'(_)<=>true.
'known/1_1_$special_;/2'(A, B)\'test/1_1_$special_;/2'(A, B)<=>true.
'known/1_1_$special_nonvar/1'(A)\'test/1_1_$default'(nonvar(A))<=>true.
'known/1_1_$special_var/1'(A)\'test/1_1_$default'(var(A))<=>true.
'known/1_1_$special_atom/1'(A)\'test/1_1_$default'(atom(A))<=>true.
'known/1_1_$special_atomic/1'(A)\'test/1_1_$default'(atomic(A))<=>true.
'known/1_1_$special_compound/1'(A)\'test/1_1_$default'(compound(A))<=>true.
'known/1_1_$special_ground/1'(A)\'test/1_1_$special_ground/1'(A)<=>true.
'known/1_1_$special_integer/1'(A)\'test/1_1_$special_integer/1'(A)<=>true.
'known/1_1_$special_float/1'(A)\'test/1_1_$special_float/1'(A)<=>true.
'known/1_1_$special_number/1'(A)\'test/1_1_$special_number/1'(A)<=>true.
'known/1_1_$special_=\\=/2'(A, B)\'test/1_1_$special_=\\=/2'(A, B)<=>true.
'known/1_1_$special_\\+/1'(A)\'test/1_1_$special_\\+/1'(A)<=>true.
'known/1_1_$special_functor/3'(A, B, C)\'test/1_1_$special_functor/3'(A, B, C)<=>true.
'known/1_1_$special_\\=/2'(A, B)\'test/1_1_$default'(A\=B)<=>true.
'known/1_1_$special_=/2'(A, B)\'test/1_1_$special_=/2'(A, B)<=>true.
'known/1_1_$special_,/2'(A, B)\'test/1_1_$special_,/2'(A, B)<=>true.
'known/1_1_$special_\\==/2'(A, B)\'test/1_1_$special_\\==/2'(A, B)<=>true.
'known/1_1_$special_==/2'(A, B)\'test/1_1_$special_==/2'(A, B)<=>true.
'known/1_1_$special_is/2'(A, B)\'test/1_1_$special_is/2'(A, B)<=>true.
'known/1_1_$special_</2'(A, B)\'test/1_1_$special_</2'(A, B)<=>true.
'known/1_1_$special_>=/2'(A, B)\'test/1_1_$special_>=/2'(A, B)<=>true.
'known/1_1_$special_>/2'(A, B)\'test/1_1_$special_>/2'(A, B)<=>true.
'known/1_1_$special_=</2'(A, B)\'test/1_1_$special_=</2'(A, B)<=>true.
'known/1_1_$special_=:=/2'(A, B)\'test/1_1_$special_=:=/2'(A, B)<=>true.
'known/1_1_$special_fail/0'\'test/1_1_$default'(fail)<=>true.
'known/1_1_$default'(A)\'test/1_1_$default'(A)<=>true.
'test/1_1_$special_\\==/2'(F, A)<=>nonvar(A), functor(A, C, B)|A=..[_|E], length(D, B), G=..[C|D], add_args_nmatch(D, E, H), I= (\+functor(F, C, B);functor(F, C, B), F=G, H), test(I).
'test/1_1_$special_\\==/2'(A, B)<=>nonvar(A)|'test/1_1_$special_\\==/2'(B, A).
'known/1_1_$special_=:=/2'(A, B)\'test/1_1_$special_=</2'(A, B)<=>true.
'known/1_1_$special_=:=/2'(A, C)\'test/1_1_$special_=</2'(A, B)<=>number(B), number(C), C=<B|true.
'known/1_1_$special_=:=/2'(A, C)\'test/1_1_$special_=</2'(B, A)<=>number(B), number(C), B=<C|true.
'known/1_1_$special_=</2'(A, C)\'test/1_1_$special_=</2'(A, B)<=>number(B), number(C), C=<B|true.
'known/1_1_$special_=</2'(B, A)\'test/1_1_$special_=</2'(C, A)<=>number(B), number(C), C=<B|true.
'known/1_1_$special_=</2'(A, C)\'test/1_1_$special_=\\=/2'(A, B)<=>number(B), number(C), B>C|true.
'known/1_1_$special_=</2'(B, A)\'test/1_1_$special_=\\=/2'(A, C)<=>number(B), number(C), C<B|true.
'known/1_1_$special_>/2'(B, A)<=>'known/1_1_$special_</2'(A, B).
'known/1_1_$special_>=/2'(B, A)<=>'known/1_1_$special_=</2'(A, B).
'known/1_1_$special_</2'(A, B)<=>'known/1_1_$special_=</2'(A, B), 'known/1_1_$special_=\\=/2'(A, B).
'known/1_1_$special_is/2'(A, B)<=>'known/1_1_$special_=:=/2'(A, B).
'test/1_1_$special_>/2'(B, A)<=>'test/1_1_$special_</2'(A, B).
'test/1_1_$special_>=/2'(B, A)<=>'test/1_1_$special_=</2'(A, B).
'test/1_1_$special_</2'(A, B)<=>'test/1_1_$special_,/2'(A=<B, A=\=B).
'test/1_1_$special_is/2'(A, B)<=>'test/1_1_$special_=:=/2'(A, B).
'known/1_1_$special_==/2'(A, B)==>number(A)|'known/1_1_$special_=:=/2'(A, B).
'known/1_1_$special_==/2'(B, A)==>number(A)|'known/1_1_$special_=:=/2'(B, A).
'known/1_1_$special_\\==/2'(A, B)==>number(A)|'known/1_1_$special_=\\=/2'(A, B).
'known/1_1_$special_\\==/2'(B, A)==>number(A)|'known/1_1_$special_=\\=/2'(B, A).
'known/1_1_$special_fail/0'\'known/1_1_$special_;/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_nonvar/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_var/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_atom/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_atomic/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_compound/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_ground/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_integer/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_float/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_number/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_=\\=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_\\+/1'(_)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_functor/3'(_, _, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_\\=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_,/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_\\==/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_==/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_is/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_</2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_>=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_>/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_=</2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_=:=/2'(_, _)<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$special_fail/0'<=>true.
'known/1_1_$special_fail/0'\'known/1_1_$default'(_)<=>true.
'known/1_1_$special_,/2'(A, B)<=>known(A), known(B).
'known/1_1_$special_=:=/2'(A, A)<=>true.
'known/1_1_$special_==/2'(A, A)<=>true.
'known/1_1_$special_=</2'(A, A)<=>true.
'known/1_1_$special_=/2'(A, A)<=>true.
'known/1_1_$special_=/2'(A, B)<=>var(A)|A=B.
'known/1_1_$special_=/2'(B, A)<=>var(A)|B=A.
'known/1_1_$special_\\=/2'(A, B)<=>ground(A), ground(B), A=B|'known/1_1_$special_fail/0'.
variables(E), 'known/1_1_$special_functor/3'(A, B, C)<=>var(A), ground(B), ground(C)|functor(A, B, C), A=..[_|D], append(D, E, F), variables(F).
'known/1_1_$special_functor/3'(A, B, C)<=>nonvar(A), \+functor(A, B, C)|'known/1_1_$special_fail/0'.
'known/1_1_$special_\\+/1'(functor(A, B, C))<=>nonvar(A), functor(A, B, C)|'known/1_1_$special_fail/0'.
'known/1_1_$special_functor/3'(A, B, C), 'known/1_1_$special_functor/3'(A, D, E)<=>nonvar(B), nonvar(C), nonvar(D), nonvar(E)|'known/1_1_$special_fail/0'.
'known/1_1_$special_\\=/2'(A, A)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=/2'(A, B)<=>nonvar(A), nonvar(B), functor(A, C, D)|functor(B, C, D), A=B->true;'known/1_1_$special_fail/0'.
'known/1_1_$special_\\=/2'(A, B)<=>var(A), nonvar(B), functor(B, D, C), C>0|length(E, C), B=..[D|F], G=..[D|E], add_args_nunif(F, E, H), I= (\+functor(A, D, C);A=G, H), known(I).
'known/1_1_$special_\\=/2'(A, B)<=>nonvar(A), nonvar(B), functor(A, C, D)|functor(B, C, D)->A=..[C|E], B=..[C|F], add_args_nunif(E, F, G), known(G);true.
'known/1_1_$special_\\=/2'(B, A)==>'known/1_1_$special_\\=/2'(A, B).
'known/1_1_$special_=</2'(A, B)<=>number(A), number(B), A>B|'known/1_1_$special_fail/0'.
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_=</2'(A, C)<=>number(B), number(C), B=<C|true.
'known/1_1_$special_=</2'(C, A)\'known/1_1_$special_=</2'(B, A)<=>number(B), number(C), B=<C|true.
'known/1_1_$special_=</2'(B, A), 'known/1_1_$special_=</2'(A, B)<=>'known/1_1_$special_=:=/2'(B, A).
'known/1_1_$special_=</2'(B, A), 'known/1_1_$special_=</2'(A, C)==>'known/1_1_$special_=</2'(B, C).
'known/1_1_$special_=</2'(A, B), 'known/1_1_$special_=\\=/2'(A, B), 'known/1_1_$special_=</2'(B, C), 'known/1_1_$special_=\\=/2'(B, C)==>'known/1_1_$special_=\\=/2'(A, C).
'known/1_1_$special_=:=/2'(A, B)<=>number(A), number(B), A=\=B|'known/1_1_$special_fail/0'.
'known/1_1_$special_=\\=/2'(A, B)<=>number(A), number(B), A=:=B|'known/1_1_$special_fail/0'.
'known/1_1_$special_=\\=/2'(A, A)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=:=/2'(A, B), 'known/1_1_$special_=\\=/2'(A, B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=:=/2'(B, A), 'known/1_1_$special_=:=/2'(A, C)==>B\==C|'known/1_1_$special_=:=/2'(B, C).
'known/1_1_$special_=:=/2'(B, A)==>'known/1_1_$special_=:=/2'(A, B).
'known/1_1_$special_=\\=/2'(B, A)==>'known/1_1_$special_=\\=/2'(A, B).
'known/1_1_$special_number/1'(A)<=>nonvar(A), \+number(A)|'known/1_1_$special_fail/0'.
'known/1_1_$special_float/1'(A)<=>nonvar(A), \+float(A)|'known/1_1_$special_fail/0'.
'known/1_1_$special_integer/1'(A)<=>nonvar(A), \+integer(A)|'known/1_1_$special_fail/0'.
'known/1_1_$special_integer/1'(A)==>'known/1_1_$special_number/1'(A).
'known/1_1_$special_float/1'(A)==>'known/1_1_$special_number/1'(A).
'known/1_1_$special_;/2'(A, B), 'known/1_1_$special_\\+/1'((A;B))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_nonvar/1'(A), 'known/1_1_$special_\\+/1'(nonvar(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_var/1'(A), 'known/1_1_$special_\\+/1'(var(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_atom/1'(A), 'known/1_1_$special_\\+/1'(atom(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_atomic/1'(A), 'known/1_1_$special_\\+/1'(atomic(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_compound/1'(A), 'known/1_1_$special_\\+/1'(compound(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_ground/1'(A), 'known/1_1_$special_\\+/1'(ground(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_integer/1'(A), 'known/1_1_$special_\\+/1'(integer(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_float/1'(A), 'known/1_1_$special_\\+/1'(float(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_number/1'(A), 'known/1_1_$special_\\+/1'(number(A))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=\\=/2'(A, B), 'known/1_1_$special_\\+/1'(A=\=B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_\\+/1'(A), 'known/1_1_$special_\\+/1'(\+A)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_functor/3'(A, B, C), 'known/1_1_$special_\\+/1'(functor(A, B, C))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_\\=/2'(A, B), 'known/1_1_$special_\\+/1'(A\=B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=/2'(A, B), 'known/1_1_$special_\\+/1'(A=B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_,/2'(A, B), 'known/1_1_$special_\\+/1'((A, B))<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_\\==/2'(A, B), 'known/1_1_$special_\\+/1'(A\==B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_==/2'(A, B), 'known/1_1_$special_\\+/1'(A==B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_is/2'(A, B), 'known/1_1_$special_\\+/1'(A is B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_</2'(A, B), 'known/1_1_$special_\\+/1'(A<B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_>=/2'(A, B), 'known/1_1_$special_\\+/1'(A>=B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_>/2'(A, B), 'known/1_1_$special_\\+/1'(A>B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=</2'(A, B), 'known/1_1_$special_\\+/1'(A=<B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_=:=/2'(A, B), 'known/1_1_$special_\\+/1'(A=:=B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_fail/0', 'known/1_1_$special_\\+/1'(fail)<=>'known/1_1_$special_fail/0'.
'known/1_1_$default'(A), 'known/1_1_$special_\\+/1'(A)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_\\==/2'(A, B), 'known/1_1_$special_==/2'(A, B)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_==/2'(B, A), 'known/1_1_$special_==/2'(A, C)==>'known/1_1_$special_==/2'(B, C).
'known/1_1_$special_==/2'(B, A), 'known/1_1_$special_\\==/2'(A, C)==>'known/1_1_$special_\\==/2'(B, C).
'known/1_1_$special_==/2'(B, A)==>'known/1_1_$special_==/2'(A, B).
'known/1_1_$special_\\==/2'(B, A)==>'known/1_1_$special_\\==/2'(A, B).
'known/1_1_$special_\\==/2'(A, A)==>'known/1_1_$special_fail/0'.
'known/1_1_$special_\\==/2'(A, B)<=>nonvar(A), nonvar(B), functor(A, C, D)|functor(B, C, D)->A=..[C|E], B=..[C|F], add_args_nmatch(E, F, G), known(G);true.
'known/1_1_$special_==/2'(A, B)==>'known/1_1_$special_=/2'(A, B).
'known/1_1_$special_ground/1'(A)==>'known/1_1_$special_nonvar/1'(A).
'known/1_1_$special_compound/1'(A)==>'known/1_1_$special_nonvar/1'(A).
'known/1_1_$special_atomic/1'(A)==>'known/1_1_$special_nonvar/1'(A).
'known/1_1_$special_number/1'(A)==>'known/1_1_$special_nonvar/1'(A).
'known/1_1_$special_atom/1'(A)==>'known/1_1_$special_nonvar/1'(A).
'known/1_1_$special_var/1'(A), 'known/1_1_$special_nonvar/1'(A)<=>'known/1_1_$special_fail/0'.
'known/1_1_$special_;/2'(A, B)\'known/1_1_$special_;/2'(\+ (A;B), C)<=>known(C).
'known/1_1_$special_nonvar/1'(A)\'known/1_1_$special_;/2'(\+nonvar(A), B)<=>known(B).
'known/1_1_$special_var/1'(A)\'known/1_1_$special_;/2'(\+var(A), B)<=>known(B).
'known/1_1_$special_atom/1'(A)\'known/1_1_$special_;/2'(\+atom(A), B)<=>known(B).
'known/1_1_$special_atomic/1'(A)\'known/1_1_$special_;/2'(\+atomic(A), B)<=>known(B).
'known/1_1_$special_compound/1'(A)\'known/1_1_$special_;/2'(\+compound(A), B)<=>known(B).
'known/1_1_$special_ground/1'(A)\'known/1_1_$special_;/2'(\+ground(A), B)<=>known(B).
'known/1_1_$special_integer/1'(A)\'known/1_1_$special_;/2'(\+integer(A), B)<=>known(B).
'known/1_1_$special_float/1'(A)\'known/1_1_$special_;/2'(\+float(A), B)<=>known(B).
'known/1_1_$special_number/1'(A)\'known/1_1_$special_;/2'(\+number(A), B)<=>known(B).
'known/1_1_$special_=\\=/2'(A, B)\'known/1_1_$special_;/2'(\+A=\=B, C)<=>known(C).
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'(\+ \+A, B)<=>known(B).
'known/1_1_$special_functor/3'(A, B, C)\'known/1_1_$special_;/2'(\+functor(A, B, C), D)<=>known(D).
'known/1_1_$special_\\=/2'(A, B)\'known/1_1_$special_;/2'(\+A\=B, C)<=>known(C).
'known/1_1_$special_=/2'(A, B)\'known/1_1_$special_;/2'(\+A=B, C)<=>known(C).
'known/1_1_$special_,/2'(A, B)\'known/1_1_$special_;/2'(\+ (A, B), C)<=>known(C).
'known/1_1_$special_\\==/2'(A, B)\'known/1_1_$special_;/2'(\+A\==B, C)<=>known(C).
'known/1_1_$special_==/2'(A, B)\'known/1_1_$special_;/2'(\+A==B, C)<=>known(C).
'known/1_1_$special_is/2'(A, B)\'known/1_1_$special_;/2'(\+A is B, C)<=>known(C).
'known/1_1_$special_</2'(A, B)\'known/1_1_$special_;/2'(\+A<B, C)<=>known(C).
'known/1_1_$special_>=/2'(A, B)\'known/1_1_$special_;/2'(\+A>=B, C)<=>known(C).
'known/1_1_$special_>/2'(A, B)\'known/1_1_$special_;/2'(\+A>B, C)<=>known(C).
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_;/2'(\+A=<B, C)<=>known(C).
'known/1_1_$special_=:=/2'(A, B)\'known/1_1_$special_;/2'(\+A=:=B, C)<=>known(C).
'known/1_1_$special_fail/0'\'known/1_1_$special_;/2'(\+fail, A)<=>known(A).
'known/1_1_$default'(A)\'known/1_1_$special_;/2'(\+A, B)<=>known(B).
'known/1_1_$special_;/2'(A, B)\'known/1_1_$special_;/2'((\+ (A;B), _), C)<=>known(C).
'known/1_1_$special_nonvar/1'(A)\'known/1_1_$special_;/2'((\+nonvar(A), _), B)<=>known(B).
'known/1_1_$special_var/1'(A)\'known/1_1_$special_;/2'((\+var(A), _), B)<=>known(B).
'known/1_1_$special_atom/1'(A)\'known/1_1_$special_;/2'((\+atom(A), _), B)<=>known(B).
'known/1_1_$special_atomic/1'(A)\'known/1_1_$special_;/2'((\+atomic(A), _), B)<=>known(B).
'known/1_1_$special_compound/1'(A)\'known/1_1_$special_;/2'((\+compound(A), _), B)<=>known(B).
'known/1_1_$special_ground/1'(A)\'known/1_1_$special_;/2'((\+ground(A), _), B)<=>known(B).
'known/1_1_$special_integer/1'(A)\'known/1_1_$special_;/2'((\+integer(A), _), B)<=>known(B).
'known/1_1_$special_float/1'(A)\'known/1_1_$special_;/2'((\+float(A), _), B)<=>known(B).
'known/1_1_$special_number/1'(A)\'known/1_1_$special_;/2'((\+number(A), _), B)<=>known(B).
'known/1_1_$special_=\\=/2'(A, B)\'known/1_1_$special_;/2'((\+A=\=B, _), C)<=>known(C).
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'((\+ \+A, _), B)<=>known(B).
'known/1_1_$special_functor/3'(A, B, C)\'known/1_1_$special_;/2'((\+functor(A, B, C), _), D)<=>known(D).
'known/1_1_$special_\\=/2'(A, B)\'known/1_1_$special_;/2'((\+A\=B, _), C)<=>known(C).
'known/1_1_$special_=/2'(A, B)\'known/1_1_$special_;/2'((\+A=B, _), C)<=>known(C).
'known/1_1_$special_,/2'(A, B)\'known/1_1_$special_;/2'((\+ (A, B), _), C)<=>known(C).
'known/1_1_$special_\\==/2'(A, B)\'known/1_1_$special_;/2'((\+A\==B, _), C)<=>known(C).
'known/1_1_$special_==/2'(A, B)\'known/1_1_$special_;/2'((\+A==B, _), C)<=>known(C).
'known/1_1_$special_is/2'(A, B)\'known/1_1_$special_;/2'((\+A is B, _), C)<=>known(C).
'known/1_1_$special_</2'(A, B)\'known/1_1_$special_;/2'((\+A<B, _), C)<=>known(C).
'known/1_1_$special_>=/2'(A, B)\'known/1_1_$special_;/2'((\+A>=B, _), C)<=>known(C).
'known/1_1_$special_>/2'(A, B)\'known/1_1_$special_;/2'((\+A>B, _), C)<=>known(C).
'known/1_1_$special_=</2'(A, B)\'known/1_1_$special_;/2'((\+A=<B, _), C)<=>known(C).
'known/1_1_$special_=:=/2'(A, B)\'known/1_1_$special_;/2'((\+A=:=B, _), C)<=>known(C).
'known/1_1_$special_fail/0'\'known/1_1_$special_;/2'((\+fail, _), A)<=>known(A).
'known/1_1_$default'(A)\'known/1_1_$special_;/2'((\+A, _), B)<=>known(B).
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'(A, B)<=>known(B).
'known/1_1_$special_\\+/1'(A)\'known/1_1_$special_;/2'((A, _), B)<=>known(B).
'known/1_1_$special_;/2'(fail, A)<=>known(A).
'known/1_1_$special_;/2'(A, fail)<=>known(A).
'known/1_1_$special_;/2'(true, _)<=>true.
'known/1_1_$special_;/2'(_, true)<=>true.
'known/1_1_$special_functor/3'(A, _, _)\'known/1_1_$special_;/2'(\+functor(A, _, _), _)<=>true.
'known/1_1_$special_;/2'(\+functor(A, B, C), D)<=>nonvar(A), functor(A, B, C)|known(D).
'known/1_1_$special_;/2'(\+functor(A, B, C), _)<=>nonvar(A), \+functor(A, B, C)|true.
'test/1_1_$special_;/2'(fail, A)<=>test(A).
'test/1_1_$special_;/2'(A, fail)<=>test(A).
% 'test/1_1_$special_=/2'(A, B)<=>A=B|A=B.
'test/1_1_$special_=/2'(A, B)<=>ground(A), ground(B)|A=B.
% 'test/1_1_$special_=/2'(A, B)<=>nonvar(A), var(B)|'test/1_1_$special_=/2'(B, A).
% variables(F)\'test/1_1_$special_=/2'(A, B)<=>var(A), nonvar(B), functor(B, D, C), C>0, B=..[D|E], \+all_unique_vars(E, F)|G= (functor(A, D, C), A=B), test(G).
simplify([],[]).
simplify([G|R],[SG|RS]) :-
( \+ try(true,G) ->
SG = true
;
builtins:negate_b(G,NotG),
(\+ try(true,NotG) ->
SG = fail
;
SG = keep
)
),
known(G),
simplify(R,RS).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% AUXILIARY PREDICATES
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
try(A,X) :- (known(A) ->
true
;
format(' ERROR: entailment checker: this is not supposed to happen.\n',[])
),
(test(X) ->
fail
;
true).
lookup([],[],_,_) :- fail.
lookup([K|R],[V|R2],X,Y) :-
(X == K ->
Y=V
;
lookup(R,R2,X,Y)
).
add_args_unif([],[],true).
add_args_unif([X|RX],[Y|RY],(X=Y,RC)) :-
add_args_unif(RX,RY,RC).
add_args_nunif([],[],fail).
add_args_nunif([X|RX],[Y|RY],(X\=Y;RC)) :-
add_args_nunif(RX,RY,RC).
add_args_nmatch([],[],fail).
add_args_nmatch([X|RX],[Y|RY],(X\==Y;RC)) :-
add_args_nmatch(RX,RY,RC).
all_unique_vars(T,V) :- all_unique_vars(T,V,[]).
all_unique_vars([],V,C).
all_unique_vars([V|R],Vars,C) :-
var(V),
\+ memberchk_eq(V,Vars),
\+ memberchk_eq(V,C),
all_unique_vars(R,[V|C]).
% variables(F) \ 'test/1_1_$special_=/2'(A, B) <=>
% var(A),
% nonvar(B),
% \+ memberchk_eq(A,F),
% functor(B, C, D),
% B=..[C|_]
% |
% E=functor(A, C, D),
% test(E).
% 'test/1_1_$special_=/2'(A, B)<=>nonvar(A), nonvar(B), functor(B, C, D), B=..[C|F]|functor(A, C, D), A=..[C|E], add_args_unif(E, F, G), test(G).
variables(D)\'test/1_1_$special_functor/3'(A, B, C)<=>var(A), ground(B), ground(C), \+memberchk_eq(A, D)|functor(A, B, C).
'test/1_1_$special_true/0'<=>true.
'test/1_1_$special_==/2'(A, B)<=>A==B|true.
'test/1_1_$special_=:=/2'(A, B)<=>A==B|true.
'test/1_1_$special_=</2'(A, B)<=>A==B|true.
'test/1_1_$special_=</2'(A, B)<=>ground(A), ground(B), A=<B|true.
'test/1_1_$special_=</2'(A, B)<=>ground(A), ground(B), A>B|fail.
'test/1_1_$special_=:=/2'(A, B)<=>ground(A), ground(B), A=:=B|true.
'test/1_1_$special_=:=/2'(A, B)<=>ground(A), ground(B), A=\=B|fail.
'test/1_1_$special_=\\=/2'(A, B)<=>ground(A), ground(B), A=\=B|true.
'test/1_1_$special_=\\=/2'(A, B)<=>ground(A), ground(B), A=:=B|fail.
'test/1_1_$special_functor/3'(A, B, C)<=>nonvar(A), functor(A, B, C)|true.
'test/1_1_$special_functor/3'(A, _, _)<=>nonvar(A)|fail.
'test/1_1_$special_ground/1'(A)<=>ground(A)|true.
'test/1_1_$special_number/1'(A)<=>number(A)|true.
'test/1_1_$special_float/1'(A)<=>float(A)|true.
'test/1_1_$special_integer/1'(A)<=>integer(A)|true.
'test/1_1_$special_number/1'(A)<=>nonvar(A)|fail.
'test/1_1_$special_float/1'(A)<=>nonvar(A)|fail.
'test/1_1_$special_integer/1'(A)<=>nonvar(A)|fail.
'test/1_1_$special_\\+/1'(functor(A, B, C))<=>nonvar(A), functor(A, B, C)|fail.
'test/1_1_$special_\\+/1'(functor(A, _, _))<=>nonvar(A)|true.
'test/1_1_$special_\\+/1'(ground(A))<=>ground(A)|fail.
'test/1_1_$special_\\+/1'(number(A))<=>number(A)|fail.
'test/1_1_$special_\\+/1'(float(A))<=>float(A)|fail.
'test/1_1_$special_\\+/1'(integer(A))<=>integer(A)|fail.
'test/1_1_$special_\\+/1'(number(A))<=>nonvar(A)|true.
'test/1_1_$special_\\+/1'(float(A))<=>nonvar(A)|true.
'test/1_1_$special_\\+/1'(integer(A))<=>nonvar(A)|true.
'test/1_1_$special_,/2'(A, B)<=>test(A), known(A), test(B).
'test/1_1_$special_;/2'(A, B)<=>true|negate_b(A, D), negate_b(B, C), (known(C), test(A);known(D), test(B)).
'test/1_1_$special_,/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, (B, C)), !, negate_b(A, D), known(D), \+try(E, (B, C)).
'test/1_1_$special_\\+/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, \+B), !, negate_b(A, C), known(C), \+try(D, \+B).
'test/1_1_$special_integer/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, integer(B)), !, negate_b(A, C), known(C), \+try(D, integer(B)).
'test/1_1_$special_float/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, float(B)), !, negate_b(A, C), known(C), \+try(D, float(B)).
'test/1_1_$special_number/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, number(B)), !, negate_b(A, C), known(C), \+try(D, number(B)).
'test/1_1_$special_ground/1'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, ground(B)), !, negate_b(A, C), known(C), \+try(D, ground(B)).
'test/1_1_$special_=:=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=:=C), !, negate_b(A, D), known(D), \+try(E, B=:=C).
'test/1_1_$special_==/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B==C), !, negate_b(A, D), known(D), \+try(E, B==C).
'test/1_1_$special_true/0', 'known/1_1_$special_;/2'(A, C)<=>true|\+try(A, true), !, negate_b(A, B), known(B), \+try(C, true).
'test/1_1_$special_functor/3'(B, C, D), 'known/1_1_$special_;/2'(A, F)<=>true|\+try(A, functor(B, C, D)), !, negate_b(A, E), known(E), \+try(F, functor(B, C, D)).
'test/1_1_$special_=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=C), !, negate_b(A, D), known(D), \+try(E, B=C).
'test/1_1_$special_;/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, (B;C)), !, negate_b(A, D), known(D), \+try(E, (B;C)).
'test/1_1_$special_is/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B is C), !, negate_b(A, D), known(D), \+try(E, B is C).
'test/1_1_$special_</2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B<C), !, negate_b(A, D), known(D), \+try(E, B<C).
'test/1_1_$special_>=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B>=C), !, negate_b(A, D), known(D), \+try(E, B>=C).
'test/1_1_$special_>/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B>C), !, negate_b(A, D), known(D), \+try(E, B>C).
'test/1_1_$special_=\\=/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=\=C), !, negate_b(A, D), known(D), \+try(E, B=\=C).
'test/1_1_$special_=</2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B=<C), !, negate_b(A, D), known(D), \+try(E, B=<C).
'test/1_1_$special_\\==/2'(B, C), 'known/1_1_$special_;/2'(A, E)<=>true|\+try(A, B\==C), !, negate_b(A, D), known(D), \+try(E, B\==C).
'test/1_1_$default'(B), 'known/1_1_$special_;/2'(A, D)<=>true|\+try(A, B), !, negate_b(A, C), known(C), \+try(D, B).
'test/1_1_$special_,/2'(_, _)<=>fail.
'test/1_1_$special_\\+/1'(_)<=>fail.
'test/1_1_$special_integer/1'(_)<=>fail.
'test/1_1_$special_float/1'(_)<=>fail.
'test/1_1_$special_number/1'(_)<=>fail.
'test/1_1_$special_ground/1'(_)<=>fail.
'test/1_1_$special_=:=/2'(_, _)<=>fail.
'test/1_1_$special_==/2'(_, _)<=>fail.
'test/1_1_$special_true/0'<=>fail.
'test/1_1_$special_functor/3'(_, _, _)<=>fail.
'test/1_1_$special_=/2'(_, _)<=>fail.
'test/1_1_$special_;/2'(_, _)<=>fail.
'test/1_1_$special_is/2'(_, _)<=>fail.
'test/1_1_$special_</2'(_, _)<=>fail.
'test/1_1_$special_>=/2'(_, _)<=>fail.
'test/1_1_$special_>/2'(_, _)<=>fail.
'test/1_1_$special_=\\=/2'(_, _)<=>fail.
'test/1_1_$special_=</2'(_, _)<=>fail.
'test/1_1_$special_\\==/2'(_, _)<=>fail.
'test/1_1_$default'(_)<=>fail.
cleanup\'known/1_1_$special_;/2'(_, _)<=>true.
cleanup\'known/1_1_$special_nonvar/1'(_)<=>true.
cleanup\'known/1_1_$special_var/1'(_)<=>true.
cleanup\'known/1_1_$special_atom/1'(_)<=>true.
cleanup\'known/1_1_$special_atomic/1'(_)<=>true.
cleanup\'known/1_1_$special_compound/1'(_)<=>true.
cleanup\'known/1_1_$special_ground/1'(_)<=>true.
cleanup\'known/1_1_$special_integer/1'(_)<=>true.
cleanup\'known/1_1_$special_float/1'(_)<=>true.
cleanup\'known/1_1_$special_number/1'(_)<=>true.
cleanup\'known/1_1_$special_=\\=/2'(_, _)<=>true.
cleanup\'known/1_1_$special_\\+/1'(_)<=>true.
cleanup\'known/1_1_$special_functor/3'(_, _, _)<=>true.
cleanup\'known/1_1_$special_\\=/2'(_, _)<=>true.
cleanup\'known/1_1_$special_=/2'(_, _)<=>true.
cleanup\'known/1_1_$special_,/2'(_, _)<=>true.
cleanup\'known/1_1_$special_\\==/2'(_, _)<=>true.
cleanup\'known/1_1_$special_==/2'(_, _)<=>true.
cleanup\'known/1_1_$special_is/2'(_, _)<=>true.
cleanup\'known/1_1_$special_</2'(_, _)<=>true.
cleanup\'known/1_1_$special_>=/2'(_, _)<=>true.
cleanup\'known/1_1_$special_>/2'(_, _)<=>true.
cleanup\'known/1_1_$special_=</2'(_, _)<=>true.
cleanup\'known/1_1_$special_=:=/2'(_, _)<=>true.
cleanup\'known/1_1_$special_fail/0'<=>true.
cleanup\'known/1_1_$default'(_)<=>true.
cleanup\variables(_)<=>true.
cleanup<=>true.

122
LGPL/chr/hprolog.pl
View File

@ -1,47 +1,69 @@
:- module(hprolog,
[ prolog_flag/3, % +Flag, -Old, +New
append_lists/2, % +ListOfLists, -List
[ append/2, % +ListOfLists, -List
nth/3, % ?Index, ?List, ?Element
substitute/4, % +OldVal, +OldList, +NewVal, -NewList
substitute_eq/4, % +OldVal, +OldList, +NewVal, -NewList
memberchk_eq/2, % +Val, +List
intersect_eq/3, % +List1, +List2, -Intersection
list_difference_eq/3, % +List, -Subtract, -Rest
take/3, % +N, +List, -FirstElements
drop/3, % +N, +List, -LastElements
split_at/4, % +N, +List, -FirstElements, -LastElements
max_go_list/2, % +List, -Max
or_list/2, % +ListOfInts, -BitwiseOr
sublist/2,
sublist/2, % ?Sublist, +List
bounded_sublist/3, % ?Sublist, +List, +Bound
min_list/2,
chr_delete/3,
strip_attributes/2,
restore_attributes/2
init_store/2,
get_store/2,
update_store/2,
make_get_store_goal/3,
make_update_store_goal/3,
make_init_store_goal/3,
empty_ds/1,
ds_to_list/2,
get_ds/3,
put_ds/4
]).
:- use_module(library(lists)).
:- use_module(library(assoc)).
% prolog_flag(+Flag, -Old, +New)
%
% Combine ISO prolog flag reading and writing
empty_ds(DS) :- empty_assoc(DS).
ds_to_list(DS,LIST) :- assoc_to_list(DS,LIST).
get_ds(A,B,C) :- get_assoc(A,B,C).
put_ds(A,B,C,D) :- put_assoc(A,B,C,D).
init_store(Name,Value) :- nb_setval(Name,Value).
get_store(Name,Value) :- nb_getval(Name,Value).
update_store(Name,Value) :- b_setval(Name,Value).
make_init_store_goal(Name,Value,Goal) :- Goal = nb_setval(Name,Value).
make_get_store_goal(Name,Value,Goal) :- Goal = nb_getval(Name,Value).
make_update_store_goal(Name,Value,Goal) :- Goal = b_setval(Name,Value).
prolog_flag(Flag, Old, New) :-
current_prolog_flag(Flag, Old),
( Old == New
-> true
; set_prolog_flag(Flag, New)
).
/*******************************
* MORE LIST OPERATIONS *
*******************************/
% append_lists(+ListOfLists, -List)
% append(+ListOfLists, -List)
%
% Convert a one-level nested list into a flat one. E.g.
% append_lists([[a,b], [c]], X) --> X = [a,b,c]. See also
% append([[a,b], [c]], X) --> X = [a,b,c]. See also
% flatten/3.
append_lists([],[]).
append_lists([X|Xs],L) :-
append([],[]).
append([X],X) :- !.
append([X|Xs],L) :-
append(X,T,L),
append_lists(Xs,T).
append(Xs,T).
% nth(?Index, ?List, ?Element)
@ -52,18 +74,18 @@ nth(Index, List, Element) :-
nth1(Index, List, Element).
% substitute(+OldVal, +OldList, +NewVal, -NewList)
% substitute_eq(+OldVal, +OldList, +NewVal, -NewList)
%
% Substitute OldVal by NewVal in OldList and unify the result
% with NewList. JW: Shouldn't this be called substitute_eq/4?
% with NewList.
substitute(_, [], _, []) :- ! .
substitute(X, [U|Us], Y, [V|Vs]) :-
substitute_eq(_, [], _, []) :- ! .
substitute_eq(X, [U|Us], Y, [V|Vs]) :-
( X == U
-> V = Y,
substitute(X, Us, Y, Vs)
substitute_eq(X, Us, Y, Vs)
; V = U,
substitute(X, Us, Y, Vs)
substitute_eq(X, Us, Y, Vs)
).
% memberchk_eq(+Val, +List)
@ -116,6 +138,19 @@ take(N, [H|TA], [H|TB]) :-
N2 is N - 1,
take(N2, TA, TB).
% Drop the first N elements from List and unify the remainder with
% LastElements.
drop(0,LastElements,LastElements) :- !.
drop(N,[_|Tail],LastElements) :-
N > 0,
N1 is N - 1,
drop(N1,Tail,LastElements).
split_at(0,L,[],L) :- !.
split_at(N,[H|T],[H|L1],L2) :-
M is N -1,
split_at(M,T,L1,L2).
% max_go_list(+List, -Max)
%
@ -144,6 +179,7 @@ or_list([H|T], Or0, Or) :-
or_list(T, Or1, Or).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
sublist(L, L).
sublist(Sub, [H|T]) :-
'$sublist1'(T, H, Sub).
@ -154,6 +190,20 @@ sublist(Sub, [H|T]) :-
'$sublist1'([H|T], X, [X|Sub]) :-
'$sublist1'(T, H, Sub).
bounded_sublist(Sublist,_,_) :-
Sublist = [].
bounded_sublist(Sublist,[H|List],Bound) :-
Bound > 0,
(
Sublist = [H|Rest],
NBound is Bound - 1,
bounded_sublist(Rest,List,NBound)
;
bounded_sublist(Sublist,List,Bound)
).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
min_list([H|T], Min) :-
'$min_list1'(T, H, Min).
@ -172,23 +222,3 @@ chr_delete([H|T], X, L) :-
chr_delete(T, X, RT)
).
strip_attributes([],[]).
strip_attributes([V|R],[V2|R2]) :-
( attvar(V) ->
get_attrs(V,VAttrs),
remove_attrs(V,VAttrs,V2)
; V2 = []
),
strip_attributes(R,R2).
remove_attrs(_V,[],[]).
remove_attrs(V,att(X,Y,OtherAttrs),[(X,Y)|R]) :-
del_attr(V,X),
remove_attrs(V,OtherAttrs,R).
restore_attributes([],[]).
restore_attributes([_V|R],[[]|R2]) :-
restore_attributes(R,R2).
restore_attributes([V|R],[[(X,Y)|RVAttr]|R2]) :-
put_attr(V,X,Y),
restore_attributes([V|R],[RVAttr|R2]).

4
LGPL/chr/listmap.pl
View File

@ -1,9 +1,9 @@
/* $Id: listmap.pl,v 1.1 2005-10-28 17:41:30 vsc Exp $
/* $Id: listmap.pl,v 1.2 2007-10-16 23:17:03 vsc Exp $
Part of CHR (Constraint Handling Rules)
Author: Tom Schrijvers
E-mail: Tom.Schrijvers@cs.kuleuven.ac.be
E-mail: Tom.Schrijvers@cs.kuleuven.be
WWW: http://www.swi-prolog.org
Copyright (C): 2003-2004, K.U. Leuven

2
changes-5.1.html
View File

@ -17,6 +17,8 @@
<h2>Yap-5.1.3:</h2>
<ul>
<li> FIXED: latest SWI chr.</li>
<li> FIXED: allow abolishing imports.</li>
<li> FIXED: YAP_EnterGoal would set YENV[E_CB] before setting YENV
(obs from Trevor Walker).</li>
<li> FIXED: setarg/3 should always set a global variable.</li>

11
library/assoc.yap
View File

@ -49,12 +49,13 @@
rb_del_max/4
]).
empty_assoc(T) :-
rb_empty(T).
empty_assoc(t).
assoc_to_list(t, L) :- !, L = [].
assoc_to_list(T, L) :-
rb_visit(T, L).
is_assoc(t) :- !.
is_assoc(T) :-
is_rbtree(T).
@ -64,7 +65,7 @@ min_assoc(T,K,V) :-
max_assoc(T,K,V) :-
rb_max(T,K,V).
gen_assoc(K,T,V) :-
gen_assoc(T,K,V) :-
rb_in(K,V,T).
get_assoc(K,T,V) :-
@ -85,12 +86,14 @@ list_to_assoc(L, T) :-
ord_list_to_assoc(L, T) :-
ord_list_to_rbtree(L, T).
map_assoc(t, _) :- !.
map_assoc(P, T) :-
yap_flag(typein_module, M0),
extract_mod(P, M0, M, G),
functor(G, Name, 1),
rb_map(T, M:Name).
map_assoc(t, T, T) :- !.
map_assoc(P, T, NT) :-
yap_flag(typein_module, M0),
extract_mod(P, M0, M, G),
@ -105,6 +108,8 @@ extract_mod(G, M, M, G ).
put_assoc(K, T, V, NT) :-
rb_update(T, K, V, NT), !.
put_assoc(K, t, V, NT) :- !,
rbtrees:rb_new(K,V,NT).
put_assoc(K, T, V, NT) :-
rb_insert(T, K, V, NT).

17
library/swi.yap
View File

@ -35,6 +35,10 @@
:- dynamic
user:file_search_path/2.
prolog:is_list(L) :- var(L), !, fail.
prolog:is_list([]).
prolog:is_list([_|List]) :- prolog:is_list(List).
user:file_search_path(swi, Home) :-
current_prolog_flag(home, Home).
user:file_search_path(foreign, swi(ArchLib)) :-
@ -44,6 +48,19 @@ user:file_search_path(foreign, swi(lib)).
:- meta_predicate prolog:predsort(:,+,-).
prolog:plus(X, Y, Z) :-
integer(X),
integer(Y), !,
Z is X + Y.
prolog:plus(X, Y, Z) :-
integer(X),
integer(Z), !,
Y is Z - X.
prolog:plus(X, Y, Z) :-
integer(Y),
integer(Z), !,
X is Z - Y.
%% predsort(:Compare, +List, -Sorted) is det.
%
% Sorts similar to sort/2, but determines the order of two terms

5
pl/boot.yap
View File

@ -292,7 +292,10 @@ true :- true.
'$execute_command'((:-G),_,Option,_) :- !,
'$current_module'(M),
% allow user expansion
'$precompile_term'((:- G), _, (:- G1), M),
(G=constraints(_)->start_low_level_trace; true),
expand_term((:- G), O),
O = (:- G1),
stop_low_level_trace,
'$process_directive'(G1, Option, M),
fail.
'$execute_command'((?-G),V,_,Source) :- !,

2
pl/consult.yap
View File

@ -343,7 +343,7 @@ use_module(M,F,Is) :-
'$do_startup_reconsult'(X) :-
( '$access_yap_flags'(15, 0) ->
'$system_catch'(load_files(X, []),Module,Error,'$Error'(Error))
'$system_catch'(load_files(X, [silent(true)]),Module,Error,'$Error'(Error))
;
set_value('$verbose',off),
'$system_catch'(load_files(X, [silent(true),skip_unix_comments]),Module,_,fail)

12
pl/directives.yap
View File

@ -193,18 +193,18 @@ yap_flag(enhanced,off) :- set_value('$enhanced',[]).
%
% SWI compatibility flag
%
yap_flag(generate_debugging_info,X) :-
yap_flag(generate_debug_info,X) :-
var(X), !,
'$access_yap_flags'(18,Options),
(Options =:= 0 -> X = false ; X = true ).
yap_flag(generate_debugging_info,true) :- !,
yap_flag(generate_debug_info,true) :- !,
'$set_yap_flags'(18,1),
source.
yap_flag(generate_debugging_info,false) :- !,
yap_flag(generate_debug_info,false) :- !,
'$set_yap_flags'(18,0),
no_source.
yap_flag(generate_debugging_info,X) :-
'$do_error'(domain_error(flag_value,generate_debugging_info+X),yap_flag(generate_debugging_info,X)).
yap_flag(generate_debug_info,X) :-
'$do_error'(domain_error(flag_value,generate_debug_info+X),yap_flag(generate_debug_info,X)).
%
% show state of $
@ -728,7 +728,7 @@ yap_flag(dialect,yap).
V = gc ;
V = gc_margin ;
V = gc_trace ;
V = generate_debugging_info ;
V = generate_debug_info ;
% V = hide ;
V = home ;
V = host_type ;

10
pl/preds.yap
View File

@ -633,6 +633,11 @@ abolish(X) :-
erase(R),
erase(Ref),
fail.
'$abolishd'(T, M) :-
functor(T,N,A),
recorded('$import','$import'(_,M,N,A),R),
erase(R),
fail.
'$abolishd'(T, M) :-
'$purge_clauses'(T,M), fail.
'$abolishd'(T, M) :- '$kill_dynamic'(T,M), fail.
@ -659,6 +664,11 @@ abolish(X) :-
erase(R),
erase(Ref),
fail.
'$abolishs'(T, M) :-
functor(T,N,A),
recorded('$import','$import'(_,M,N,A),R),
erase(R),
fail.
'$abolishs'(G, M) :-
'$purge_clauses'(G, M), fail.
'$abolishs'(_, _).