upgrade chr

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1957 b08c6af1-5177-4d33-ba66-4b1c6b8b522a

C/init.c

@@ -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);

C/iopreds.c

@@ -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));
 }
 

LGPL/chr/Makefile.in

@@ -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 \

LGPL/chr/a_star.pl

@@ -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).

LGPL/chr/binomialheap.pl

@@ -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 ->

LGPL/chr/builtins.pl

@@ -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,[]),

LGPL/chr/chr_compiler_options.pl

@@ -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) :- 
+handle_option(Name,Value) :- 
-	var(Var), !,
+	var(Name), !,
-	format('CHR compiler ERROR: ~w.\n',[option(Var,Value)]),
+	chr_error(syntax((:- chr_option(Name,Value))),'First argument should be an atom, not a variable.\n',[]).
-	format('    `--> First argument should be an atom, not a variable.\n',[]),
-	fail.
 
 handle_option(Name,Value) :- 
 	var(Value), !,
-	format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
+	chr_error(syntax((:- chr_option(Name,Value))),'Second argument cannot be a variable.\n',[]).
-	format('    `--> Second argument should be a nonvariable.\n',[]),
-	fail.
 
 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),
+	chr_error(syntax((:- chr_option(Name,Value))),'Invalid option name ~w: consult the manual for valid options.\n',[Name]).
-	format('CHR compiler WARNING: ~w.\n',[option(Name,Value)]),
-	format('    `--> Invalid option name ~w: should be one of ~w.\n',[Name,Ns]).
 
 handle_option(Name,Value) :- 
-	findall(V,option_definition(Name,V,_),Vs), 
+	chr_error(syntax((:- chr_option(Name,Value))),'Invalid option value ~w: consult the manual for valid option values.\n',[Value]).
-	format('CHR compiler ERROR: ~w.\n',[option(Name,Value)]),
-	format('    `--> Invalid value ~w: should be one of ~w.\n',[Value,Vs]),
-	fail.
 
 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
+		  reduced_indexing	   - on,
-		].
+                  inline_insertremove      - on,
-
+		  mixed_stores		   - off
-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
 		].
 
 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,
+		  observation_analysis     - off,
-		  ai_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.
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

LGPL/chr/chr_compiler_utility.pl

@@ -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) :-
+% time(Phase,Goal) :-
-	statistics(runtime,[T1|_]),
+% 	statistics(runtime,[T1|_]),
-	call(Goal),
+% 	call(Goal),
-	statistics(runtime,[T2|_]),
+% 	statistics(runtime,[T2|_]),
-	T is T2 - T1,
+% 	T is T2 - T1,
-	format('    ~w:\t\t~w ms\n',[Phase,T]).
+% 	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) :-
+conj2list(Var,L,T) :-
-  Conj = (true,G2), !,
+	var(Var), !,
-  conj2list(G2,L,T).
+	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)).	

LGPL/chr/chr_debug.pl

@@ -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
 	;

LGPL/chr/chr_hashtable_store.pl

@@ -1,19 +1,59 @@
+/*  $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.ac.be
+% 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(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) :-
@@ -21,9 +61,9 @@ new_ht(HT) :-
 	new_ht(Capacity,HT).
 
 new_ht(Capacity,HT) :-
-        functor(T1,t,Capacity),
+	functor(T1,t,Capacity),
-        HT = ht(Capacity,0,Table),
+	HT = ht(Capacity,0,Table),
-        Table = T1.
+	Table = T1.
 
 lookup_ht(HT,Key,Values) :-
 	term_hash(Key,Hash),
@@ -35,7 +75,7 @@ lookup_ht(HT,Key,Values) :-
 	    K == Key,	
 	    Values = Vs
 	;
-	    lookup_eq(Bucket,Key,Values)
+	    lookup(Bucket,Key,Values)
 	).
 
 lookup_pair_eq([P | KVs],Key,Pair) :-
@@ -52,46 +92,94 @@ insert_ht(HT,Key,Value) :-
 	LookupIndex is (Hash mod Capacity0) + 1,
 	arg(LookupIndex,Table0,LookupBucket),
 	( var(LookupBucket) ->
-		Inc = yes,
 		LookupBucket = Key - [Value]
 	; LookupBucket = K-Values ->
-	      	( K == Key ->	
+		( K == Key ->	
-			( hprolog:memberchk_eq(Value,Values) ->
+			setarg(2,LookupBucket,[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) ->
+			setarg(2,Pair,[Value|Values])
-				true
-			;	
-				Inc = yes,
-				setarg(2,Pair,[Value|Values])
-			)
 		;
-			Inc = yes,
 			setarg(LookupIndex,Table0,[Key-[Value]|LookupBucket])
 		)
 	),
-	( Inc == yes ->
+	NLoad is Load + 1,
-		NLoad is Load + 1,
+	setarg(2,HT,NLoad),
-		setarg(2,HT,NLoad),
+	( Load == Capacity0 ->
-		( Load == Capacity0 ->
+		expand_ht(HT,_Capacity)
-			expand_ht(HT,_Capacity)
-		;
-			true
-		)
 	;
 		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,
@@ -120,7 +208,11 @@ delete_ht(HT,Key,Value) :-
 				setarg(2,HT,NLoad),
 				( NVs == [] ->
 					pairlist_delete_eq(Bucket,Key,NBucket),
-					setarg(Index,Table,NBucket)
+					( NBucket = [Singleton] ->
+						setarg(Index,Table,Singleton)
+					;
+						setarg(Index,Table,NBucket)
+					)
 				;
 					setarg(2,Pair,NVs)
 				)
@@ -158,31 +250,6 @@ value_ht(I,N,Table,Value) :-
 		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) :-
@@ -226,6 +293,4 @@ expand_insert(Table,Capacity,K,V) :-
 		setarg(Index,Table,[K-V|Bucket])
 	).
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-term_hash(Term,Hash) :-
-	hash_term(Term,Hash).
 	

LGPL/chr/chr_messages.pl

@@ -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) --> !,

LGPL/chr/chr_op.pl

@@ -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, \).

LGPL/chr/chr_op2.pl

@@ -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, \).

LGPL/chr/chr_runtime.pl

@@ -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,
@@ -110,44 +113,128 @@
 
 	    '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,mutable(off)),          % XXX
-	nb_setval(chr_debug_history,mutable([],0)).
+	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),
+		Mod:'$enumerate_constraints'(Constraint),
-		arg(6,Susp,C),
+		print(Constraint),nl, % allows use of portray to control printing
-		writeln(C),
 		fail
 	;
 		true
 	).
 
+find_chr_constraint(Constraint) :-
+	chr:'$chr_module'(Mod),
+	Mod:'$enumerate_constraints'(Constraint).
+
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-'chr merge_attributes'( As, Bs, Cs) :-
+% Inlining of some goals is good for performance
-	sbag_union(As,Bs,Cs).
+% 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),
+	arg( 2, S, Mref), % ARGXXX
-	Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
+	'chr get_mutable'( Status, Mref),
 	( Status==active ->
-	    update_mutable( triggered, Mref),
+	    'chr update_mutable'( triggered, Mref),
-	    arg( 4, S, Gref),
+	    arg( 4, S, Gref), % ARGXXX
-	    Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
+	    'chr get_mutable'( Gen, Gref),
 	    Generation is Gen+1,
-	    update_mutable( Generation, Gref),
+	    'chr update_mutable'( Generation, Gref),
-	    arg( 3, S, Goal),
+	    arg( 3, S, Goal), % ARGXXX
 	    call( Goal),
-	    					% get_mutable( Post, Mref), % XXX Inlined
+	    'chr get_mutable'( Post, Mref),
-	    ( Mref = mutable(triggered) ->	% Post==triggered ->
+	    ( Post==triggered ->
-		update_mutable( removed, Mref)
+		'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),
+	arg( 2, S, Mref), % ARGXXX
-	Mref = mutable(Status), % get_mutable( Status, Mref), % XXX Inlined
+	'chr get_mutable'( Status, Mref),
 	( Status==active ->
-	    update_mutable( triggered, Mref),
+	    'chr update_mutable'( triggered, Mref),
-	    arg( 4, S, Gref),
+	    arg( 4, S, Gref), % ARGXXX
-	    Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
+	    'chr get_mutable'( Gen, Gref),
 	    Generation is Gen+1,
-	    update_mutable( Generation, Gref),
+	    'chr update_mutable'( Generation, Gref),
-	    arg( 3, S, Goal),
+	    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
+	    'chr get_mutable'( Post, Mref),
-	    ( Mref = mutable(triggered) ->	% Post==triggered ->
+	    ( Post==triggered ->
-		update_mutable( removed, Mref)
+		'chr update_mutable'( active, Mref)   % catching constraints that did not do anything
 	    ;
 		true
 	    )
@@ -228,15 +315,6 @@ locked:attr_unify_hook(_,_) :- fail.
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 'chr lock'(T) :-
-	lock(T).
-
-'chr unlock'(T) :-
-	unlock(T).
-
-'chr not_locked'(T) :-
-	not_locked(T).
-
-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),
+	( get_attr(V, locked, _) ->
-	'chr none_locked'( Vs).
+		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),
+	arg( 2, Susp, Mref), % ARGXXX
-	Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
+	'chr get_mutable'( State, Mref), 
-	update_mutable( removed, Mref),		% mark in any case
+	'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),
+	arg( 5, Self, Ref), % ARGXXX
-	Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
+	'chr get_mutable'( History, Ref),
-	( get_assoc( Tuple, History, _) ->
+	( 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),
+	arg( 5, Self, Ref), % ARGXXX
-	Ref = mutable(History), % get_mutable( History, Ref), % XXX Inlined
+	'chr get_mutable'( History, Ref),
-	put_assoc( Tuple, History, x, NewHistory),
+	put_ds( Tuple, History, x, NewHistory),
-	update_mutable( NewHistory, Ref).
+	'chr update_mutable'( NewHistory, Ref).
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 constraint_generation( Susp, State, Generation) :-
-	arg( 2, Susp, Mref),
+	arg( 2, Susp, Mref), % ARGXXX
-	Mref = mutable(State), % get_mutable( State, Mref), % XXX Inlined
+	'chr get_mutable'( State, Mref),
-	arg( 4, Susp, Gref),
+	arg( 4, Susp, Gref), % ARGXXX
-	Gref = mutable(Generation). % get_mutable( Generation, Gref). 	% not incremented meanwhile % XXX Inlined
+	'chr get_mutable'( Generation, Gref). 	% not incremented meanwhile 
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 'chr allocate_constraint'( Closure, Self, F, Args) :-
-	'chr empty_history'( History),
+	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
-	create_mutable( passive(Args), Mref),
+	'chr create_mutable'(0, Gref),
-	create_mutable( 0, Gref),
+	'chr empty_history'(History),
-	create_mutable( History, Href),
+	'chr create_mutable'(History, Href),
-	'chr gen_id'( Id),
+	'chr create_mutable'(passive(Args), Mref),
-	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
+	'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),
+	arg( 2, Susp, Mref), % ARGXXX
-	Mref = mutable(State), % get_mutable( State, Mref),  % XXX Inlined
+	'chr get_mutable'( State, Mref),
-	update_mutable( active, Mref),
+	'chr update_mutable'( active, Mref),
 	( nonvar(Generation) ->			% aih
 	    true
 	;
-	    arg( 4, Susp, Gref),
+	    arg( 4, Susp, Gref), % ARGXXX
-	    Gref = mutable(Gen), % get_mutable( Gen, Gref), % XXX Inlined
+	    '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],
-	    Vars = [Global|Vs]
+	    'chr default_store'(Global)
-	; State==removed ->			% the price for eager removal ...
+	; 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) :-
+'chr insert_constraint_internal'([Global|Vars], Self, Closure, F, Args) :-
-	term_variables( Args, Vars),
+	'chr default_store'(Global),
-	'chr none_locked'( Vars),
+	term_variables(Args,Vars),
-	global_term_ref_1( Global),
+	'chr none_locked'(Vars),
-	'chr empty_history'( History),
+	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args], % SUSPXXX
-	create_mutable( active, Mref),
+	'chr create_mutable'(active, Mref),
-	create_mutable( 0, Gref),
+	'chr create_mutable'(0, Gref),
-	create_mutable( History, Href),
+	'chr empty_history'(History),
-	'chr gen_id'( Id),
+	'chr create_mutable'(History, Href),
-	Self =.. [suspension,Id,Mref,Closure,Gref,Href,F|Args].
+	'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),
+	'chr create_mutable'( active, Mref),
-	create_mutable( 0, Gref),
+	'chr create_mutable'( 0, Gref),
-	create_mutable( History, Href),
+	'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) :-
+'chr empty_history'( E) :- empty_ds( E).
-	arg( 2, Susp, Mref),
-	update_mutable( State, Mref).
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-'chr empty_history'( E) :- empty_assoc( E).
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 'chr gen_id'( Id) :-
-	incval( id, Id).
+	nb_getval(chr_id,Id),
-
-incval(id,Id) :-
-	nb_getval(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)).  
+%% 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
 
-'chr update_mutable'(V,M) :-
+%% SICStus begin
-	setarg(1,M,V).
+%% '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
 
-get_mutable(V, mutable(V)).  
-
-update_mutable(V,M) :-
-	setarg(1,M,V).
 
 %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-'chr global_term_ref_1'(X) :-
+%% SWI begin
-	global_term_ref_1(X).
+'chr default_store'(X) :- nb_getval(chr_global,X).
+%% SWI end
 
-global_term_ref_1(X) :-
+%% SICStus begin
-	nb_getval(chr_global,X).
+%% '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
-
+        % does it really avoid the choicepoint? -jon
-sbag_member( E, _,	     E).
+ sbag_member( E, _,	     E).
-sbag_member( E, [Head|Tail], _) :-
+ sbag_member( E, [Head|Tail], _) :-
-	sbag_member( E, Tail, Head).
+ 	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).
+'chr merge_attributes'([],Ys,Ys).
-
+'chr merge_attributes'([X | Xs],YL,R) :-
-sbag_merge([],Ys,Ys).
-sbag_merge([X | Xs],YL,R) :-
   ( YL = [Y | Ys] ->
-      arg(1,X,XId),
+      arg(1,X,XId), % ARGXXX
-      arg(1,Y,YId),	
+      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)
 
 

LGPL/chr/chr_swi.pl

@@ -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)).
+:- load_files([ chr(chr_translate),
-:- use_module(chr(chr_runtime)).
+		chr(chr_runtime),
-:- use_module(chr(chr_debug)).
+		chr(chr_messages),
-:- use_module(chr(chr_messages)).
+		chr(chr_hashtable_store),
-:- use_module(library(gensym)).
+		chr(chr_compiler_errors)
-:- use_module(chr(chr_hashtable_store)).
+	      ],
+	      [ if(not_loaded),
+		silent(true)
+	      ]).
 
-:- dynamic
+:- use_module(library(lists),[member/2]).
-	chr_term/2.			% File, Term
+%% 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
+%	file is a CHR after we've seen :- constraints ... 
-%	is named *.chr
 
 chr_expandable((:- constraints _)).
 chr_expandable((constraints _)).
+chr_expandable((:- chr_constraint _)).
 chr_expandable((:- chr_type _)).
 chr_expandable((chr_type _)).
-chr_expandable((handler _)) :-
+chr_expandable(option(_, _)).
-	is_chr_file.
+chr_expandable((:- chr_option(_, _))).
-chr_expandable((rules _)) :-
+chr_expandable((handler _)).
-	is_chr_file.
+chr_expandable((rules _)).
-chr_expandable((_ <=> _)) :-
+chr_expandable((_ <=> _)).
-	is_chr_file.
+chr_expandable((_ @ _)).
-chr_expandable((_ @ _)) :-
+chr_expandable((_ ==> _)).
-	is_chr_file.
+chr_expandable((_ pragma _)).
-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_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),
+	prolog_load_context(file,File),
-	assert(chr_term(File, Term)).
+	prolog_load_context(term_position,'$stream_position'(_, LineNumber, _, _, _)),
-chr_expand(end_of_file,
+	add_pragma_to_chr_rule(Term,line_number(LineNumber),NTerm),
-	   [ (:- use_module(chr(chr_runtime))),
+	assert(chr_term(File, LineNumber, NTerm)).
-	     (:- style_check(-(discontiguous))), % no need to restore; file ends
+chr_expand(Term, []) :-
-	     (:- set_prolog_flag(generate_debug_info, false))
+	Term = (:- chr_preprocessor(Preprocessor)), !,
-	   | Program
+	prolog_load_context(file,File),
-	   ]) :-
+	assert(chr_pp(File, Preprocessor)).
-	is_chr_file,
+chr_expand(end_of_file, FinalProgram) :-
-	source_location(File, _Line),
+	extra_declarations(FinalProgram,Program),
-	findall(T, retract(chr_term(File, T)), CHR0),
+	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),
+	add_optimise_decl(CHR1, CHR2),
-	call_chr_translate(File,
+	CHR3 = [ (:- module(Module, [])) | CHR2 ],
-			   [ (:- module(Handler, []))
+	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), !.
+	member(option(Name, _), CHR), Name == debug, !.
-add_debug_decl(CHR, [option(debug, Debug)|CHR]) :-
+add_debug_decl(CHR, CHR) :-
-	(   current_prolog_flag(generate_debug_info, true)
+	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), !.
+	\+(\+(memberchk((:- chr_option(optimize, _)), CHR))), !.
-add_optimise_decl(CHR, [option(optimize, full)|CHR]) :-
+add_optimise_decl(CHR, [(:- chr_option(optimize, full))|CHR]) :-
-	current_prolog_flag(optimize, true), !.
+	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) :-
+call_chr_translate(File, In, _Out) :-
-	   ( chr_translate(In, Out0) ->
+	( chr_translate_line_info(In, File, Out0) ->
-		nb_setval(chr_translated_program,Out0),
+	    nb_setval(chr_translated_program,Out0),
-		fail
+	    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).

LGPL/chr/chr_swi_bootstrap.pl

@@ -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
-
+%% SWI end
-:- include('chr_op').
+:- 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
+%% SWI begin with yap change
-	(   Clauses0 = [(:- module(M,E))|FileBody]
+specific_declarations([(:- use_module('chr_runtime')),
-	->  Clauses = [ (:- module(M,E)),
+		       (:- style_check(-discontiguous))|Tail], Tail).
-			(:- use_module('chr_runtime')),
+%% SWI end
-			(:- style_check(-singleton)),
+
-			(:- style_check(-discontiguous))
+%% SICStus begin
-		      | FileBody
+%% specific_declarations([(:- use_module('chr_runtime')),
-		      ]
+%%                     (:-use_module(chr_hashtable_store)),
-	;   Clauses = [ (:- use_module('chr_runtime')),
+%% 		       (:- use_module('hpattvars')),
-			(:- style_check(-singleton)),
+%% 		       (:- use_module('b_globval')),
-			(:- style_check(-discontiguous))
+%% 		       (:- use_module('hprolog')),  % needed ?
-		      | Clauses0
+%% 		       (:- 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) ],
+	chr_absolute_file_name(Spec, [ access(read) ], Path),
-			   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

LGPL/chr/chr_test.pl

@@ -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.
 

LGPL/chr/chr_translate_bootstrap.pl

@@ -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)).
+%% SWI begin
-:- use_module(hprolog).
+:- use_module(library(lists),[member/2,append/3,permutation/2,reverse/2]).
-:- use_module(library(assoc)).
-:- use_module(pairlist).
 :- 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,
+		append([ OtherClauses,
-			       AttachAConstraintClauses,
+			 AttachAConstraintClauses,
-			       DettachAConstraintClauses,
+			 DettachAConstraintClauses,
-			       AttachIncrementClauses,
+			 AttachIncrementClauses,
-			       AttrUnifyHookClauses,
+			 AttrUnifyHookClauses,
-			       ConstraintClauses
+			 ConstraintClauses
-			     ],
+		       ],
-			     NewDeclarations)
+		       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) ->
+  D = (:- Decl),
-	true
+  ( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
-  ;
-	D = Decl
-  ),
-  Decl =.. [constraints,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),
+	copy_term_nat(Pattern0,Pattern),
-	( prolog_flag(verbose,V), V == yes ->
+	( 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_ref(active,State,GetState),
-   create_get_mutable(Generation,NewGeneration,GetGeneration),
+   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) :-
+%% SWI begin
-	GM = (M = mutable(V)).
+create_get_mutable_ref(V,M,GM) :- GM = (M = mutable(V)).
-	% GM = 'chr get_mutable'(V,M)
+%% SWI end
-	%( ground(V) ->
+
-	%	GM = (M == mutable(V))
+%% SICStus begin
-	%;
+%% create_get_mutable_ref(V,M,GM) :- GM = (get_mutable(V,M)).
-	%	GM = (M = mutable(V))
+%% 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

LGPL/chr/chr_translate_bootstrap2.chr

@@ -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)).
+%% SWI begin
-:- use_module(hprolog).
+:- use_module(library(lists),[append/3,member/2,delete/3,reverse/2,permutation/2]).
-:- use_module(library(assoc)).
-:- use_module(pairlist).
 :- 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).
+:- chr_option(debug,off).
-option(optimize,full).
+:- 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(+,+)).
+:- chr_option(mode,constraint(+,+)).
-option(mode,constraint_count(+)).
+:- chr_option(mode,constraint_count(+)).
-option(mode,constraint_index(+,+)).
+:- chr_option(mode,constraint_index(+,+)).
-option(mode,max_constraint_index(+)).
+:- chr_option(mode,max_constraint_index(+)).
-option(mode,target_module(+)).
+:- chr_option(mode,target_module(+)).
-option(mode,attached(+,+)).
+:- chr_option(mode,attached(+,+)).
-option(mode,indexed_argument(+,+)).
+:- chr_option(mode,indexed_argument(+,+)).
-option(mode,constraint_mode(+,+)).
+:- chr_option(mode,constraint_mode(+,+)).
-option(mode,may_trigger(+)).
+:- chr_option(mode,may_trigger(+)).
-option(mode,store_type(+,+)).
+:- chr_option(mode,store_type(+,+)).
-option(mode,actual_store_types(+,+)).
+:- chr_option(mode,actual_store_types(+,+)).
-option(mode,assumed_store_type(+,+)).
+:- chr_option(mode,assumed_store_type(+,+)).
-option(mode,rule_count(+)).
+:- chr_option(mode,rule_count(+)).
-option(mode,passive(+,+)).
+:- chr_option(mode,passive(+,+)).
-option(mode,pragma_unique(+,+,?)).
+:- chr_option(mode,pragma_unique(+,+,?)).
-option(mode,occurrence(+,+,+,+)).
+:- chr_option(mode,occurrence(+,+,+,+)).
-option(mode,max_occurrence(+,+)).
+:- chr_option(mode,max_occurrence(+,+)).
-option(mode,allocation_occurrence(+,+)).
+:- chr_option(mode,allocation_occurrence(+,+)).
-option(mode,rule(+,+)).
+:- 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,
+		append([Clauses0,
-			      StoreClauses,
+			StoreClauses,
-			      ConstraintClauses,
+			ConstraintClauses,
-			      CHRModuleDeclaration
+			CHRModuleDeclaration
-			     ],
+		       ],
-			     NewDeclarations)
+		       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
+		append([AttachAConstraintClauses
-			     ,IndexedClauses
+		       ,IndexedClauses
-			     ,AttachIncrementClauses
+		       ,AttachIncrementClauses
-			     ,AttrUnifyHookClauses
+		       ,AttrUnifyHookClauses
-			     ,ExtraClauses
+		       ,ExtraClauses
-			     ,DeleteClauses
+		       ,DeleteClauses
-			     ,StoreClauses]
+		       ,StoreClauses]
-			     ,Clauses).
+		      ,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]
+	specific_declarations(Decls,Tail),
-	->  Clauses = [ (:- module(M,E)),
+	( Clauses0 = [ (:- module(M,E))|FileBody] ->
-			(:- use_module('chr_runtime')),
+	    Clauses = [ (:- module(M,E))|Decls],
-			(:- use_module('chr_hashtable_store')),
+	    Tail = FileBody
-			(:- style_check(-singleton)),
+	;
-			(:- style_check(-discontiguous))
+	    Clauses = Decls,
-		      | FileBody
+	    Tail = Clauses0
-		      ]
-	;   Clauses = [ (:- use_module('chr_runtime')),
-			(:- use_module('chr_hashtable_store')),
-			(:- style_check(-singleton)),
-			(:- style_check(-discontiguous))
-		      | 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) ->
+  D = (:- Decl),
-	true
+  ( Decl =.. [chr_constraint,Cs] ; Decl =.. [chr_constraint,Cs]),
-  ;
-	D = Decl
-  ),
-  Decl =.. [constraints,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),
+	nth1(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]),
+	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),
+	nth1(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),
 	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),
+			'chr create_mutable'(active,Mref), % Mref = mutable(active),
-			Gref = mutable(0),
+			'chr create_mutable'(0,Gref), % Gref = mutable(0),
-			Href = mutable(History),
 			'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),
+		GetStoreGoal,     % nb_getval(StoreName,Store),
-		b_setval(StoreName,[Susp|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,
+	find_with_var_identity(	V,
-			T^Term^Vs^(
+			Unifier
+			,
+			(
 				member(T,PatternKey),
 				lookup_eq(Unifier,T,Term),
 				term_variables(Term,Vs),
 				member(V,Vs)
 			),
-			Vars) ->
+			Vars2),
-		true
+	sort(Vars2,Vars3),
-	;
+	Vars = Vars3,
-		Vars = []
-	),
 	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),
+	copy_term_nat(Pattern0,Pattern),
-	( prolog_flag(verbose,V), V == yes ->
+	( 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)),
+	  find_with_var_identity(('chr lock'(Y)) - ('chr unlock'(Y)),
-                X ^ (member(X,GuardVars),		% X is a variable appearing in the original guard
+		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_ref(active,State,GetState),
-   create_get_mutable(Generation,NewGeneration,GetGeneration),
+   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) :-
+%% SWI begin
-	GM = (M = mutable(V)).
+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

LGPL/chr/clean_code.pl

@@ -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) :-
+conj2list(G,L,T) :-
-  Conj = (true,G2), !,
+	var(G), !,
-  conj2list(G2,L,T).
+	L = [G|T].
+conj2list(true,L,L) :- !.
 conj2list(Conj,L,T) :-
   Conj = (G1,G2), !,
   conj2list(G1,L,T1),

LGPL/chr/find.pl

@@ -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([],_,[]).

LGPL/chr/guard_entailment.chr

@@ -1,459 +1,511 @@
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-% Author:	Jon Sneyers
-% Email:	jon@cs.kuleuven.ac.be
-% Copyright:	K.U.Leuven 2004
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-
 :- module(guard_entailment,
-	[
+	  [ entails_guard/2,
-		entails_guard/2,
+	    simplify_guards/5
-		simplify_guards/5
+	  ]).
-	]).
+:- include(chr_op).
-
-%:- use_module(library(chr)).
-:- use_module(library(lists)).
 :- use_module(hprolog).
 :- use_module(builtins).
-
+:- use_module(chr_compiler_errors).
-option(debug,off).
+:- chr_option(debug, off).
-option(optimize,full).
+:- chr_option(optimize, full).
-
+:- chr_option(verbosity,off).
-
+%:- chr_option(dynattr,on).
-:- constraints known/1,test/1,cleanup/0,variables/1.
+:- chr_constraint known/1, test/1, cleanup/0, variables/1.
-
+entails_guard(A, B) :-
-% knowing the same thing twice is redundant
+	copy_term_nat((A, B), (C, F)),
-idempotence @ known(G) \ known(G) <=> true.
+	term_variables(C, D),
-
+	variables(D),
-
+	sort(C, E),
-%--------------------------------------
+	entails_guard2(E), !,
-% Rules to check if the argument of
+	test(F), !,
-% test/1 is entailed by known stuff
+	cleanup.
-%--------------------------------------
-
-% 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.
-
 entails_guard2([]).
-entails_guard2([A|R]) :- 
+entails_guard2([A|B]) :-
-    known(A), entails_guard2(R).
+	known(A),
-
+	entails_guard2(B).
-simplify_guards(List,Body,GuardList,SimplifiedGuards,NewBody) :- 
+simplify_guards(A, H, B, G, I) :-
-%    write(starting),nl,
+	copy_term_nat((A, B), (C, E)),
-    copy_term_nat((List,GuardList),(CopyList,CopyGuard)),
+	term_variables(C, D),
-    term_variables(CopyList,CLVars),
+	variables(D),
-%    write(variables(CLVars)),nl,
+	sort(C,Z),
-    variables(CLVars),
+	entails_guard2(Z), !,
-%    write(gonna_add(CopyList)),nl,
+	simplify(E, F),
-    entails_guard2(CopyList),
+	simplified(B, F, G, H, I), !,
-%    write(ok_gonna_add),nl,
+	cleanup.
-    !,
+simplified([], [], [], A, A).
-%    write(gonna_simplify(CopyGuard)),nl,
+simplified([A|B], [keep|C], [A|D], E, F) :-
-    simplify(CopyGuard,L),
+	simplified(B, C, D, E, F).
-%    write(ok_gonna_simplify(CopyGuard,L)),nl,
+simplified([_|_], [fail|_], fail, A, A).
-    simplified(GuardList,L,SimplifiedGuards,Body,NewBody),
+simplified([A|B], [true|L], [I|M], F, J) :-
-%    write(ok_done),nl,
+	builtins:binds_b(A, C),
-    !,
+	term_variables(B, D),
-    cleanup.
+	intersect_eq(C, D, E), !,
-
+	(   E=[]
-simplified([],[],[],B,B).
+	->  term_variables(F, G),
-simplified([G|RG],[keep|RL],[G|RSG],B,NB) :- simplified(RG,RL,RSG,B,NB).
+	    intersect_eq(C, G, H), !,
-simplified([G|RG],[fail|RL],fail,B,B).
+	    (   H=[]
-simplified([G|RG],[true|RL],[X|RSG],B,NB) :- 
+	    ->  I=true,
-	builtins:binds_b(G,GVars), term_variables(RG,RGVars),
+		J=K
-	intersect_eq(GVars,RGVars,SharedWithRestOfGuard),!,
+	    ;   I=true,
-	( SharedWithRestOfGuard = []	->
+		J= (A, K)
-	    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)
 	    )
-	;
+	;   I=A,
-	    X=G,		% e.g. c(X) <=> Y=X,p(Y) | true.
+	    J=K
-	    NB=NB2
 	),
-	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([],[]).
+% variables(F) \ 'test/1_1_$special_=/2'(A, B) <=> 
-simplify([G|R],[SG|RS]) :-
+% 		var(A), 
-    ( \+ try(true,G) ->
+% 		nonvar(B), 
-	SG = true
+% 		\+ memberchk_eq(A,F),
-    ;
+% 		functor(B, C, D), 
-	builtins:negate_b(G,NotG),
+% 		B=..[C|_]
-	(\+ try(true,NotG) ->
+% 	|
-	    SG = fail    
+% 		E=functor(A, C, D), 
-	;
+% 		test(E).
-	    SG = keep
+% '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.
-    known(G),
+'test/1_1_$special_==/2'(A, B)<=>A==B|true.
-    simplify(R,RS).
+'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.
-%%  AUXILIARY PREDICATES
+'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.
-try(A,X) :- (known(A) ->
+'test/1_1_$special_=\\=/2'(A, B)<=>ground(A), ground(B), A=:=B|fail.
-		true
+'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.
-		format(' ERROR: entailment checker: this is not supposed to happen.\n',[])
+'test/1_1_$special_ground/1'(A)<=>ground(A)|true.
-	    ),
+'test/1_1_$special_number/1'(A)<=>number(A)|true.
-	 (test(X) -> 
+'test/1_1_$special_float/1'(A)<=>float(A)|true.
-		fail
+'test/1_1_$special_integer/1'(A)<=>integer(A)|true.
-	    ;
+'test/1_1_$special_number/1'(A)<=>nonvar(A)|fail.
-		true).
+'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.
-lookup([],[],_,_) :- fail.
+'test/1_1_$special_\\+/1'(functor(A, _, _))<=>nonvar(A)|true.
-lookup([K|R],[V|R2],X,Y) :-
+'test/1_1_$special_\\+/1'(ground(A))<=>ground(A)|fail.
-    (X == K ->
+'test/1_1_$special_\\+/1'(number(A))<=>number(A)|fail.
-	Y=V
+'test/1_1_$special_\\+/1'(float(A))<=>float(A)|fail.
-    ;
+'test/1_1_$special_\\+/1'(integer(A))<=>integer(A)|fail.
-	lookup(R,R2,X,Y)
+'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).
-add_args_unif([],[],true).
+'test/1_1_$special_;/2'(A, B)<=>true|negate_b(A, D), negate_b(B, C), (known(C), test(A);known(D), test(B)).
-add_args_unif([X|RX],[Y|RY],(X=Y,RC)) :-
+'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)).
-    add_args_unif(RX,RY,RC).
+'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)).
-add_args_nunif([],[],fail).
+'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)).
-add_args_nunif([X|RX],[Y|RY],(X\=Y;RC)) :-
+'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)).
-    add_args_nunif(RX,RY,RC).
+'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).
-add_args_nmatch([],[],fail).
+'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).
-add_args_nmatch([X|RX],[Y|RY],(X\==Y;RC)) :-
+'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).
-    add_args_nmatch(RX,RY,RC).
+'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).
-all_unique_vars(T,V) :- all_unique_vars(T,V,[]).
+'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).
-all_unique_vars([],V,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).
-all_unique_vars([V|R],Vars,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).
-    var(V),
+'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).
-    \+ memberchk_eq(V,Vars),
+'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).
-    \+ memberchk_eq(V,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).
-    all_unique_vars(R,[V|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.

LGPL/chr/hprolog.pl

@@ -1,47 +1,69 @@
 :- module(hprolog,
-	  [ prolog_flag/3,		% +Flag, -Old, +New
+	  [ append/2,		        % +ListOfLists, -List
-	    append_lists/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,
+	    init_store/2,
-	    restore_attributes/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)
+empty_ds(DS) :- empty_assoc(DS).
-%	
+ds_to_list(DS,LIST) :- assoc_to_list(DS,LIST).
-%	Combine ISO prolog flag reading and writing
+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([],[]).
-append_lists([X|Xs],L) :-
+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_eq(_, [], _, []) :- ! .
-substitute(X, [U|Us], Y, [V|Vs]) :-
+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]).

LGPL/chr/listmap.pl

@@ -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
 

changes-5.1.html

@@ -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>

library/assoc.yap

@@ -49,12 +49,13 @@
 	rb_del_max/4
     ]).
 
-empty_assoc(T) :-
+empty_assoc(t).
-	rb_empty(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).
 

library/swi.yap

@@ -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

pl/boot.yap

@@ -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) :- !,

pl/consult.yap

@@ -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)

pl/directives.yap

@@ -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) :-
+yap_flag(generate_debug_info,X) :-
-	'$do_error'(domain_error(flag_value,generate_debugging_info+X),yap_flag(generate_debugging_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  ;

pl/preds.yap

@@ -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'(_, _).